! N. R. BADNELL                   NRB  v30.19.8                21/03/24
!
!                          A U T O S T R U C T U R E
!                          *************************
!                      (Copyright (c) 1985-2023 BADNELL)
!
!                                incorporating
!
!                         S U P E R S T R U C T U R E
!                         ***************************
!          (Copyright (c) 1969-1984 EISSNER/JONES/NUSSBAUMER/STOREY)
!
!***********************************************************************
!
!  COMBINED SOURCE DECK FOR SERIAL & PARALLEL (+/- BLAS/LAPACK) VERSIONS
!         - EACH VERSION CAN BE PRODUCED BY A SIMPLE EDIT STRING -
!           ALL ARE PROVIDED AT HTTP://WWW.APAP-NETWORK.ORG/AUTOS
!
!***********************************************************************
!par!                                                               !par
!par!                            + Parallel +                       !par
!par!                                                               !par
!par!     v25.11 First parallelization of resonant n-loop           !par
!par!     v23.10 Parallelization of collision strengths by LSp, Jp  !par
!par!     v22.16 Parallelization of collision algebra by LSp, Jp    !par
!par!     v21.14 nproc restriction removed                          !par
!par!     v20.2  First parallelization of resonant l-loop (CPB)     !par
!par!                                                               !par
!par!***************************************************************!par
!par!                                                               !par
!par      module mpi                ! For broken mpi f90 build      !par
!par      include 'mpif.h'          ! Can comment-out if O.K.       !par
!par      end                                                       !par
!par!                                                               !par
!par      module comm_interface                                     !par
!par!                                                               !par
!par      use mpi                                                   !par
!par!                                                               !par
!par      implicit none                                             !par
!par!                                                               !par
!par      public comm_init          ! Initialize MPI                !par
!par      public comm_barrier       ! MPI barrier                   !par
!par      public comm_finalize      ! Terminate MPI                 !par
!par!                                                               !par
!par      integer,parameter,public  :: sp_mpi=kind(mpi_integer)     !par
!par!                                                               !par
!par      integer(sp_mpi),public  :: iam                            !par
!par      integer(sp_mpi),public  :: nproc                          !par
!par!                                                               !par
!par      integer(sp_mpi),parameter,public  :: izero_mpi=0          !par
!par!                                                               !par
!par      SAVE                                                      !par
!par!                                                               !par
!par      private                                                   !par
!par      integer(sp_mpi) :: mpicom                                 !par
!par!                                                               !par
!par      CONTAINS                                                  !par
!par!                                                               !par
!par!---------------------------------------------------------------!par
!par      subroutine comm_init()                                    !par
!par!                                                               !par
!par      use mpi                                                   !par
!par!                                                               !par
!par      implicit none                                             !par
!par!                                                               !par
!par      integer(sp_mpi) :: ier                                    !par
!par!                                                               !par
!par      mpicom=mpi_comm_world                                     !par
!par!                                                               !par
!par      call mpi_init(ier)                                        !par
!par      call mpi_comm_rank(mpicom,iam,ier)                        !par
!par      call mpi_comm_size(mpicom,nproc,ier)                      !par
!par!                                                               !par
!par      return                                                    !par
!par!                                                               !par
!par      end subroutine comm_init                                  !par
!par!                                                               !par
!par!---------------------------------------------------------------!par
!par      subroutine comm_barrier()                                 !par
!par!                                                               !par
!par      use mpi                                                   !par
!par!                                                               !par
!par      implicit none                                             !par
!par!                                                               !par
!par      integer(sp_mpi) :: ier                                    !par
!par!                                                               !par
!par      call mpi_barrier(mpicom, ier)                             !par
!par!                                                               !par
!par      return                                                    !par
!par!                                                               !par
!par      end subroutine comm_barrier                               !par
!par!---------------------------------------------------------------!par
!par!                                                               !par
!par      subroutine comm_finalize()                                !par
!par!                                                               !par
!par      use mpi                                                   !par
!par!                                                               !par
!par      implicit none                                             !par
!par!                                                               !par
!par      integer(sp_mpi) :: ier                                    !par
!par!                                                               !par
!par      call mpi_finalize(ier)                                    !par
!par!                                                               !par
!par      return                                                    !par
!par!                                                               !par
!par      end subroutine comm_finalize                              !par
!par!---------------------------------------------------------------!par
!par!                                                               !par
!par      end module comm_interface                                 !par
!par!                                                               !par
!par!***************************************************************!par
!
!                             *******************
!
      MODULE PRECSN
!
!-----------------------------------------------------------------------
!
! MODULE SPECIFYING INTEGER/REAL WORD PRECISIONS
! (IN GENERAL, DO NOT SET A "SHORTER" PRECISION .GT. A "LONGER" ONE.)
!
!
!  QP= SHORT INTEGER (NORMALLY 2; USE 4 IF UNSUPPORTED)
!  SP= DEFAULT INTEGER (NORMALLY 4)
!  EP= EXTENDED INTEGER (NORMALLY 8)
!  RP= SHORT REAL (NORMALLY 4)
!  WP= DEFAULT REAL (NORMALLY 8)
!  XP= EXTENDED REAL (NORMALLY 8)                   !16 FOR TESTING ONLY
!  BP= DEFAULT LOGICAL (NORMALLY 1; USE 4 IF UNSUPPORTED)
!
! N.B.THESE NAMES ARE CONSTRAINED SOMEWHAT BY HISTORIC USAGE,
!    E.G. DP IS A WIDELY USED VARIABLE NAME, AS ARE ALL IP-NP.
!
!   THESE NAMES ARE NOT USED ANYWHERE ELSE - UNLESS SOMEONE INTRODUCES
!   CODE BLINDLY - THE PARAMETER STATEMENT WILL FLAG ANY CONFLICT.
!
! INTEGER NOTES:
!
!  EP=4 CAN BE USED SAFELY FOR MANY/MOST CASES.
!    =8 IS NEEDED  FOR LARGE CASES WHERE VARIABLE VALUE EXCEEDS 2**31 -1
!  SP=8 IS NEEDED IN EXTREME CASES WHERE AN ARRAY INDEX EXCEEDS 2**31 -1
!  QP=2 SUFFICES EVEN WHEN SP=8.
!
! REAL NOTES:
!
!  RP   IS ONLY USED FOR ARCHIVING COLLISION STRENGTHS.
!  WP=4 IS *NOT* RECOMMENDED: INACCURATE FOR SMALL CASES, FAILS LARGE.
!  XP=16 IS NOT CURRENTLY NEEDED BY THE PRODUCTION CODE, ALTHOUGH
!        SOME COULOMB FUNCTION ROUTINES MIGHT BENEFIT E.G. FN.FMON1.
!        ALSO, LARGE FACTORIALS (<=> LARGE ANG.MOM. .GT. THAN NORMALLY
!        NEEDED) ARE SUBJECT TO CANCELLATION ERROR - SEE SR.DFACT.
!        BOTH ARE CODED TO USE XP.
!   N.B. XP VERSIONS OF THE GENERIC RE_ALLOC AND RE_ALLOC2 INTRINSICS
!        ARE COMMENTED-OUT AS NOT SUPPORTED BY LEGACY COMPILERS.
!
! LOGICAL NOTES
!
!  BP=1 IS ALL THAT THE CODE REQUIRES, SINCE WE ONLY USE .T. OR .F.
!       I.E. WE DON'T TRY TO PACK LOGICAL VARIABLES. BUT SYSTEM
!       DEFAULT TENDS TO BE BP=4. THERE ARE A FEW LOGICAL ARRAYS
!       IN USE AND SO BP=1 IS USEFUL (IF AVAILABLE).
!  N.B. INQUIRE(EXIST=BEX) REQUIRES DEFAULT LOGICAL BEX.
!       THIS IS HANDLED TRANSPARENTLY.
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      INTEGER QP
      INTEGER SP
      INTEGER EP
!
      INTEGER RP
      INTEGER WP
      INTEGER XP
!
      INTEGER BP
!
      INTEGER SHORTI
      INTEGER DEFLTI
      INTEGER LONGI
!
      INTEGER SHORTR
      INTEGER DEFLTR
      INTEGER LONGR                                    !FOR TESTING ONLY
!
      PARAMETER (SHORTI=SELECTED_INT_KIND(4))          !INTEGER SHORT
      PARAMETER (DEFLTI=SELECTED_INT_KIND(9))          !INTEGER DEFAULT
      PARAMETER (LONGI=SELECTED_INT_KIND(12))          !INTEGER EXTENDED
!
      PARAMETER (SHORTR=SELECTED_REAL_KIND(5,30))      !REAL SHORT
      PARAMETER (DEFLTR=SELECTED_REAL_KIND(10,100))    !REAL DEFAULT
      PARAMETER (LONGR=SELECTED_REAL_KIND(20,1000))    !REAL EXTENDED
!
      PARAMETER (QP=KIND(1_SHORTI))                    !INTEGER*2
!      PARAMETER (QP=KIND(1_DEFLTI))  !***CASE TOO MANY RELAXED ORBITALS
      PARAMETER (SP=KIND(1_DEFLTI))                    !INTEGER*4
!      PARAMETER (SP=KIND(1_LONGI))  !***CASE ARRAY INDEX .GE. 2**31 ***
      PARAMETER (EP=KIND(1_LONGI))                     !INTEGER*8
!
      PARAMETER (RP=KIND(1.0_SHORTR))                  !REAL*4
      PARAMETER (WP=KIND(1.0_DEFLTR))                  !REAL*8
!      PARAMETER (WP=KIND(1.0_LONGR))                   !REAL*16
      PARAMETER (XP=WP)                                !REAL*8,16
!      PARAMETER (XP=KIND(1.0_LONGR))                   !REAL*16
!
      PARAMETER (BP=KIND(.TRUE._1))                    !LOGICAL SHORT
!      PARAMETER (BP=KIND(.TRUE.))                      !LOGICAL DEFAULT
!
      INTEGER(QP) QBUFF2
      INTEGER(SP) IBUFF4
!
      PARAMETER (QBUFF2=(2**14-1)+2**14)                       !2**15 -1
      PARAMETER (IBUFF4=(2**30-1)+2**30)                       !2**31 -1
!
      SAVE
!
!-----------------------------------------------------------------------
!
! OR, IF YOU PREFER (GENERIC MACHINE SAFE SETTINGS SHOWN):
!
!-----------------------------------------------------------------------
!
!      PARAMETER (QP=4)                                !INTEGER SHORT
!      PARAMETER (SP=4)                                !INTEGER DEFAULT
!      PARAMETER (EP=8)                                !INTEGER EXTENDED
!!
!      PARAMETER (RP=4)                                !REAL SHORT
!      PARAMETER (WP=8)                                !REAL DEFAULT
!      PARAMETER (XP=WP)                                !REAL DEFAULT
!!      PARAMETER (XP=16)                               !REAL EXTENDED
!!
!      PARAMETER (BP=4)                                !LOGICAL DEFAULT
!!
      END MODULE PRECSN
!
!                             *******************
!
      MODULE PARAM
!
!-----------------------------------------------------------------------
!
! MODULE INITIALIZING/SPECIFYING PRIMARY DIMENSIONS.
!
! (THE USER WOULD NOT NORMALLY CHANGE THEM, OR THEIR SET-UP BELOW.)
!
!     COMMON /NRBDIM/MXUSED(MXDIM),KNAM(MXDIM)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      LOGICAL(BP) B_F2003,B_F2008
!
      PARAMETER (B_F2003=.FALSE.)         !SET .FALSE. FOR OLD COMPILERS
      PARAMETER (B_F2008=.FALSE.)         !SET .FALSE. FOR OLD COMPILERS
!
      LOGICAL(BP) BFYRZT
!
      INTEGER(SP) MXDIM
!
      PARAMETER (MXDIM=        56_SP) !No. of active dimension variables
!
      INTEGER(SP) MXAAI,MXAAK,MAXAD,MXADJ,MXAJS,MAXB1,MXBIF,MXBLM,MXCAS &
     &           ,MAXCF,MAXCL,MAXDC,MAXDF,MXDFS,MAXDI,MAXDK,MXEL0,MXENG &
     &           ,MXEST,MXFSL,MAXGR,MXGRB,MAXJG,MAXJU,MAXLL,MAXLV,MAXMI &
     &           ,MXNOR,MXPOT,MAXRK,MXRKO,MAXRL,MXRLO,MXRSS,MAXSL,MXSOC &
     &           ,MXSOI,MXST0,MAXTM,MAXTR,MAXUC,MXRKS,MXRLS,MXROS,MXS1C &
     &           ,MXS1I,MXS2C,MXS2I,MAXB2,MAXCT,MXVAR,MXFSS,MXFOO       &
     &           ,MXCHG,MXSTX,MXSYJ
      INTEGER(SP) IXAAI,IXAAK,IAXAD,IXADJ,IXAJS,IAXB1,IXBIF,IXBLM,IXCAS &
     &           ,IAXCF,IAXCL,IAXDC,IAXDF,IXDFS,IAXDI,IAXDK,IXEL0,IXENG &
     &           ,IXEST,IXFSL,IAXGR,IXGRB,IAXJG,      IAXLL,IAXLV,IAXMI &
     &           ,IXNOR,IXPOT,IAXRK,IXRKO,IAXRL,IXRLO,IXRSS,IAXSL,IXSOC &
     &           ,IXSOI,IXST0,IAXTM,IAXTR,IAXUC,IXRKS,IXRLS,IXROS,IXS1C &
     &           ,IXS1I,IXS2C,IXS2I,IAXB2,IAXCT,IXVAR,IXFSS,IXFOO       &
     &           ,IXCHG,IXSTX,IXSYJ
      INTEGER(EP) IAXJU
!
      INTEGER(SP) MXUSED(MXDIM)
!
      CHARACTER(LEN=5) KNAM(MXDIM)
!
! PRIMARY DIMENSIONS FOR AUTOSTRUCTURE; SEE SR.ZERO FOR MORE DETAILED NOTES.
!
! DW: THE FOLLOWING DIMENSIONS ARE GOVERNED BY THE N+1 PROBLEM, REST TARGET ONLY.
!     MAXAD,MXADJ,MAXRK,MXRKO,MAXRL,MXRLO,MXRSS,MAXMI,MAXSL,MAXJG
!
!
! THESE DIMENSIONS ARE SET EXACTLY AUTOMATICALLY INTERNALLY, SO JUST INITIALIZE:
!
      PARAMETER (MXAAI=        -1_SP)   !No. of distinct bound-continuum LSp H-matrix elements.
      PARAMETER (MXAAK=        -1_SP)   !No. of distinct bound-continuum Jp H-matrix elements.
      PARAMETER (MAXAD=        -1_SP)   !Total no. of distinct H-matrix elements, SLp.
      PARAMETER (MXADJ=        -1_SP)   !Total no. of distinct H-matrix elements, Jp.
      PARAMETER (MXAJS=        -1_SP)   !Ditto, set =MXADJ for 2-body f-s else =1.
      PARAMETER (MAXB1=        -1_SP)   !No. of radial mesh points for P-functions.
      PARAMETER (MAXB2=        -1_SP)   !No. of radial mesh points for Q-functions.
      PARAMETER (MXBIF=        -1_SP)   !No. of Born interactions per state (LS or IC).
      PARAMETER (MXBLM=        -1_SP)   !Max Born/E_k lambda multipole retained.
      PARAMETER (MXCAS=        -1_SP)   !No. of cascade coefficients (Jp).
      PARAMETER (MAXCF=        -1_SP)   !No. of configurations - .gt. sqrt(2^31) needs I*8.
      PARAMETER (MXCHG=        -1_SP)   !No. of target SLp groups contrib to SLp sym (DW).
      PARAMETER (MAXCL=        -1_SP)   !No. of closed-shell electrons.
      PARAMETER (MAXCT=        -1_SP)   !Total no. of algebraic terms, inc. max poss buffer.
      PARAMETER (MAXDF=        -1_SP)   !Total no. of terms in an l^q subshell.
      PARAMETER (MXDFS=        -1_SP)   !Size of factorial array - need ~2l!
      PARAMETER (MAXDI=        -1_SP)   !No. of terms within an SLp group.
      PARAMETER (MAXDK=        -1_SP)   !No. of levels within a Jp group.
      PARAMETER (MXEL0=        -1_SP)   !No. of valence electrons.
      PARAMETER (MAXLL=        -1_SP)   !Largest ang. mom. of stored VCCs, else on-the-fly.
      PARAMETER (MXENG=        -1_SP)   !No. of continuum interpolation/scattering energies.
      PARAMETER (MXEST=        -1_SP)   !No. of valence electrons * Total no. of Slater states.
      PARAMETER (MXFSL=        -1_SP)   !No. of bound-continuum Slater integrals.
      PARAMETER (MXFSS=        -1_SP)   !No. of bound-cont 2-body f-s integrals.
      PARAMETER (MXFOO=        -1_SP)   !No. of bound-cont 2-body non-f-s ints. =1 or MXFSL.
      PARAMETER (MAXGR=        -1_SP)   !No. of (distinct) bound orbitals.
      PARAMETER (MXGRB=        -1_SP)   !No. of non-core bound orbitals for Born (min-1).
      PARAMETER (MAXJG=        -1_SP)   !No. of distinct level (Jp) groups.
      PARAMETER (MAXJU=        -1_SP)   !Total no. of CI mixing coefficients (Jp).
      PARAMETER (MAXLV=        -1_SP)   !Total no. of Hamiltonian levels.
      PARAMETER (MXNOR=        -1_SP)   !No. of non-vanishing E1 rates for cascade coeffs.
      PARAMETER (MXPOT=        -1_SP)   !No. of (n)l-dependent potentials stored.
      PARAMETER (MXRKO=        -1_SP)   !No. of Orbit-Orbit integral coeffs.=1 or MAXRK.
      PARAMETER (MXRLO=        -1_SP)   !No. of Orbit-Orbit integrals: =1 or MAXRL.
      PARAMETER (MAXSL=        -1_SP)   !No. of distinct term (SLp) groups.
      PARAMETER (MXSYJ=        -1_SP)   !No. of SLp symms which contrib to Jp sym (DW).
      PARAMETER (MAXTM=        -1_SP)   !Total no. of Hamiltonian terms.
      PARAMETER (MAXTR=        -1_SP)   !No. of term coupling coefficients (<=2*MXADJ-MAXLV).
      PARAMETER (MAXUC=        -1_SP)   !Total no. of CI mixing coefficients (SLp).
      PARAMETER (MXVAR=        -1_SP)   !No. of variational scaling parameters.
!
!
! THESE DIMENSIONS ARE RE-ALLOCATED INTERNALLY AS NECESSARY:
!
! (THE LARGER THE INITIAL VALUE, THE LESS RE-ALLOCATION -COPYING- REQUIRED, I.E. "FASTER",
!  BUT LARGER, AND MAYBE UNNECESSARY, TEMPORARY MEMORY ALLOCATION.)
!
      PARAMETER (MAXDC=  80000000_SP)   !Total no. of vector coupling coefficients.
      PARAMETER (MAXMI=    100000_SP)   !No. of Breit-Pauli integrals, N and V (2-body).
      PARAMETER (MAXRK=   2500000_SP)   !No. of Slater interaction alg. coeffs. and E1/E2 alg.
      PARAMETER (MAXRL=      9995_SP)   !No. of Slater integrals R.
      PARAMETER (MXRSS=  25000000_SP)   !No. of Breit-Pauli magnetic interaction alg. coeffs.
      PARAMETER (MXSOC=  20000000_SP)   !No. of spin-orbit interaction algebraic coeffs.
      PARAMETER (MXSOI=     15000_SP)   !No. of spin-orbit and M1+BP,M2 integrals (1-body).
      PARAMETER (MXST0=    400050_SP)   !Total no. of Slater states. *Only per config on input*.
      PARAMETER (MXSTX=    400000_SP)   !No. of one-body SS interactions (DW, also for s-o now).
!
!
! DIMENSIONS PERTAINING TO SLATER STATE INTERACTIONS:
! (THEY ARE RE-ALLOCATED AS NECESSARY.)
!
      PARAMETER (MXRKS=        MAXRK)   !As MAXRK, MAXRL but resolved by Slater state.
      PARAMETER (MXRLS=        MAXRL)   !AND for a *single* symmetry ONLY.
      PARAMETER (MXROS=        -1_SP)   !As MXRKO but resolved by Slater state, =1 or MXRKS.
      PARAMETER (MXS1C=        MXSOC)   !As MXSOC, MXSOI but resolved by Slater state.
      PARAMETER (MXS1I=        MXSOI)   !AND for a *single* LSJP symmetry ONLY.
      PARAMETER (MXS2C=        MXRSS)   !As MXRSS, MXAMI but resolved by Slater state.
      PARAMETER (MXS2I=        MAXMI)   !AND for a *single* LSJP symmetry ONLY.
!
!
      SAVE
!
      DATA                                                              &
     &  IXAAI/0/,IXAAK/0/,IAXAD/0/,IXADJ/0/,IXAJS/0/,IAXB1/0/,IXBIF/0/  &
     & ,IXBLM/0/,IXCAS/0/,IAXCF/0/,IAXCL/0/,IAXDC/0/,IAXDF/0/,IXDFS/0/  &
     & ,IAXDI/0/,IAXDK/0/,IXEL0/0/,IXENG/0/,IXEST/0/,IXFSL/0/,IAXGR/0/  &
     & ,IXGRB/0/,IAXJG/0/,IAXJU/0/,IAXLL/0/,IAXLV/0/,IAXMI/0/,IXNOR/0/  &
     & ,IXPOT/0/,IAXRK/0/,IXRKO/0/,IAXRL/0/,IXRLO/0/,IXRSS/0/,IAXSL/0/  &
     & ,IXSOC/0/,IXSOI/0/,IXST0/0/,IAXTM/0/,IAXTR/0/,IAXUC/0/,IXRKS/0/  &
     & ,IXRLS/0/,IXROS/0/,IXS1C/0/,IXS1I/0/,IXS2C/0/,IXS2I/0/,IAXB2/0/  &
     & ,IAXCT/0/,IXVAR/0/,IXFSS/0/,IXFOO/0/,IXCHG/0/,IXSTX/0/,IXSYJ/0/
!
      DATA BFYRZT/.TRUE./               !FLAG FOR SR.ZERO
!
      END MODULE PARAM
!
!                             *******************
!
      MODULE UTILITY_STRING
!
!-----------------------------------------------------------------------
!
! MODULE FOR ONVERTING CASE OF STRINGS [a-z] TO [A-Z] OR [A-Z] TO [a-z]
!
! IT CONTAINS
!   FN.STRUPCASE
!   FN.STRLOWCASE
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: SP
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      PRIVATE
!
      PUBLIC :: STRUPCASE
      PUBLIC :: STRLOWCASE
!
      CHARACTER(*) :: LOWER_CASE,UPPER_CASE
!
      PARAMETER (LOWER_CASE='abcdefghijklmnopqrstuvwxyz')
      PARAMETER (UPPER_CASE='ABCDEFGHIJKLMNOPQRSTUVWXYZ')
!
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!
      CONTAINS
!
!-----------------------------------------------------------------------
!
      FUNCTION STRUPCASE(INPUT_STRING) RESULT(OUTPUT_STRING)
!
!-----------------------------------------------------------------------
!
! CONVERTS LOWER CASE STRING [a-z] TO [A-Z] UPPER CASE STRING
! ANYTHING ELSE IS LEFT UNCHANGED
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      CHARACTER(*), INTENT(IN) :: INPUT_STRING
!
      CHARACTER(LEN(INPUT_STRING)) :: OUTPUT_STRING
!
      INTEGER(SP) :: I,N                                !LOCAL VARIABLES
!
!-----------------------------------------------------------------------
!
      OUTPUT_STRING=INPUT_STRING                      !COPY INPUT STRING
!
! LOOP OVER STRING ELEMENTS
!
      DO I=1,LEN(INPUT_STRING)
!
! FIND LOCATION OF LETTER IN LOWER CASE CONSTANT STRING
!
        N=INDEX(LOWER_CASE,INPUT_STRING(I:I))
!
! IF CURRENT SUBSTRING IS A LOWER CASE LETTER, MAKE IT UPPER CASE,
! ELSE LEAVE WHATEVER IS THERE UNCHANGED
!
        IF(N.NE.0)OUTPUT_STRING(I:I)=UPPER_CASE(N:N)
!
      ENDDO
!
!-----------------------------------------------------------------------
!
      END FUNCTION STRUPCASE
!
!-----------------------------------------------------------------------
!
      FUNCTION STRLOWCASE(INPUT_STRING) RESULT(OUTPUT_STRING)
!
!-----------------------------------------------------------------------
!
! CONVERT UPPER CASE STRING [A-Z] TO [a-z] LOWER CASE STRING
! ANYTHING ELSE IS LEFT UNCHANGED
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      CHARACTER(*), INTENT(IN) :: INPUT_STRING
!
      CHARACTER(LEN(INPUT_STRING)) :: OUTPUT_STRING
!
      INTEGER(SP) :: I,N                                !LOCAL VARIABLES
!
!-----------------------------------------------------------------------
!
      OUTPUT_STRING=INPUT_STRING                      !COPY INPUT STRING
!
! LOOP OVER STRING ELEMENTS
!
      DO I=1,LEN(INPUT_STRING)
!
! FIND LOCATION OF LETTER IN UPPER CASE CONSTANT STRING
!
        N=INDEX(UPPER_CASE,INPUT_STRING(I:I))
!
! IF CURRENT SUBSTRING IS AN UPPER CASE LETTER, MAKE IT LOWER CASE
! ELSE LEAVE WHATEVER IS THERE UNCHANGED
!
        IF(N.NE.0)OUTPUT_STRING(I:I)=LOWER_CASE(N:N)
!
      ENDDO
!
!-----------------------------------------------------------------------
!
      END FUNCTION STRLOWCASE
!
!-----------------------------------------------------------------------
!
      END MODULE UTILITY_STRING
!
!                             *******************
!
      module utility_time
!
!-----------------------------------------------------------------------
!
! module for accessing timing routines
!
! it contains
!   sr.nrb_time
!
!-----------------------------------------------------------------------
!
      use precsn, only: wp
!
!-----------------------------------------------------------------------
!
      implicit none
!
      private
!
      public :: nrb_time
!
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!
      contains
!
!-----------------------------------------------------------------------
!
      subroutine nrb_time(time)                                 !,wtime)
!
!-----------------------------------------------------------------------
!
! When using the OpenMP library, i.e. multi-threading maybe in use,
! then use of the usual F95 cpu_time subroutine maybe misleading with
! compilers (e.g. Intel) which report the total cpu time used,
! i.e. summed-over all threads. This timing is likely not meaningful the
! way sr.nrb_time is used, viz. for a mixture of single threading and
! multi-thread operation. Instead, uncomment the wallclock time function
! omp_get_wtime.
! Currently, only one time is returned/used for/by AS.
!
! it calls
!   sr.cpu_time (system)
!   fn.omp_get_wtime (system)
!
!-----------------------------------------------------------------------
!
      implicit none
!
      real(wp) :: time
      real(wp) :: wtime                                          !LAPACK
      real(wp) :: omp_get_wtime                                  !LAPACK
!
!-----------------------------------------------------------------------
!
! initialize (for safety)
!
      time=0
!      wtime=0
!
! choose your timer.
!
! Oracle, Nvidia/PGI compilers return the same value from
! cpu_time and omp_get_wtime, so use cpu_time for portability.
!
! standard fortran95 function
!
      call cpu_time(time)
!
! Intel compiler returns thread-summed time from cpu_time, so use
! omp_get_wtime to get the wallclock time, unless you know better.
!
! OpenMP wallclock time (requires OpenMP library)
!
      wtime=omp_get_wtime()                                      !LAPACK
      time=wtime                                                 !LAPACK
!
!-----------------------------------------------------------------------
!
      return
!
      end subroutine nrb_time
!
!-----------------------------------------------------------------------
!
      end module utility_time
!
!-----------------------------------------------------------------------
!
!                             *******************
!
      MODULE UTILITY_UNIT
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!
!     COMMON /NRBUNI/IUNIT(MXD14),NUNIT
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: SP
      USE PARAM
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      INTEGER(SP) MXD14
!
      PARAMETER (MXD14=100)               !MAX NO. OF FILE UNITS TRACKED
!
      INTEGER(SP) IUNIT(MXD14),NUNIT
!
      INTEGER(SP) MW0,MW1,MW2,MRW3,MW4,MR5,MW6,MW7,MW8,MR9,MRW10,MRW11  &
     &           ,MR12,MW13,MRW14,MRW15,MW16,MW17,MW18,MR19,MR20,MW21   &
     &           ,MW22,MRW23,MRW24,MRW25,MRW26,MW27,MW28,MW29,MW30,MRW31&
     &           ,MRW32,MRW33,MW34
!
      PARAMETER (MW0=0)              !TO SCREEN
      PARAMETER (MW1=1)              !TCC.DAT
      PARAMETER (MW2=2)              !CASC
      PARAMETER (MRW3=3)             !CONFIG.DAT
      PARAMETER (MW4=4)              !TCCDW.DAT
      PARAMETER (MR5=5)              !STANDARD READ
      PARAMETER (MW6=6)              !STD WRITE if global param not used
      PARAMETER (MW7=7)              !oca/ols
      PARAMETER (MW8=8)              !oic
      PARAMETER (MR9=9)              !hffcin/potin
      PARAMETER (MRW10=10)           !RESTART
      PARAMETER (MRW11=11)           !SCRATCH
      PARAMETER (MR12=12)            !radwin
      PARAMETER (MW13=13)            !radout
      PARAMETER (MRW14=14)           !CAVES/TERMS
      PARAMETER (MRW15=15)           !LEVELS
      PARAMETER (MW16=16)            !OVRLAP
      PARAMETER (MW17=17)            !opca/opls
      PARAMETER (MW18=18)            !opic
      PARAMETER (MR19=19)            !SHFTLS
      PARAMETER (MR20=20)            !SHFTIC
      PARAMETER (MW21=21)            !adasex.in.form
      PARAMETER (MW22=22)            !adasexj.in.form
      PARAMETER (MRW23=23)           !OMGINFCA/LS
      PARAMETER (MRW24=24)           !OMGINFIC
      PARAMETER (MRW25=25)           !adf04ca/ls
      PARAMETER (MRW26=26)           !adf04ic
      PARAMETER (MW27=27)            !ocau/olsu
      PARAMETER (MW28=28)            !oicu
      PARAMETER (MW29=29)            !opcau/oplsu
      PARAMETER (MW30=30)            !opicu
      PARAMETER (MRW31=31)           !ITANAL
      PARAMETER (MRW32=32)           !DISKDC
      PARAMETER (MRW33=33)           !DSKDMP
      PARAMETER (MW34=34)            !n-mesh.dat
!
! IN ADDITION, UNIT=80,81,82,... ARE RESERVED FOR LOCAL SCRATCH FILES.
!
      SAVE
!
      DATA NUNIT/34/                 !MAX UNIT NO. IN USE, EX SCRATCH
!
      END MODULE UTILITY_UNIT
!
!                             *******************
!
      MODULE UTILITY
!
!-----------------------------------------------------------------------
!
! LOAD UTILITY MODULES
!
!-----------------------------------------------------------------------
!
      USE UTILITY_STRING
      USE UTILITY_TIME
      USE UTILITY_UNIT
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      END MODULE UTILITY
!
!                             *******************
!
      MODULE REALLOCATE
!
!-----------------------------------------------------------------------
!
! N. R. BADNELL (2018)
!
!-----------------------------------------------------------------------
!
! RE-ALLOCATES AN ARRAY *** PRESERVING THE ORIGINAL CONTENTS ***
!  (N.B. IT CAN DECREASE, AS WELL AS INCREASE, THE UBOUND OF AN ARRAY.
!   BUT IT CAN ONLY INCREASE LBOUND, UNLESS ANOTHER ARGUMENT IS ADDED TO
!   THE CALL STATEMENT AND LBOUND REFERENCING ADJUSTED C.F. UBOUND.)
!
! GENERIC INTERFACES (RE_ALLOC,2) FOR RE_ALLOC,2_IM (=2,4,8) &_RN (=4,8)
! WHICH DECIDE HOW TO RE-ALLOCATE RANK ONE OR TWO ARRAYS: BY USING THE
! F2003 INTRINSIC SR.MOVE_ALLOC, OR NOT, AS SET BY B_F2003=.TRUE.
! OR .FALSE. IN MODULE PARAM.
!
!  IT CONTAINS:
!    SR.RE_ALLOC_I2
!    SR.RE_ALLOC_I4
!    SR.RE_ALLOC_I8
!    SR.RE_ALLOC_R4
!    SR.RE_ALLOC_R8
!!    SR.RE_ALLOC_R16
!    SR.RE_ALLOC_BP
!
!    SR.RE_ALLOC2_I2
!    SR.RE_ALLOC2_I4
!    SR.RE_ALLOC2_I8
!    SR.RE_ALLOC2_R4
!    SR.RE_ALLOC2_R8
!!    SR.RE_ALLOC2_R16
!    SR.RE_ALLOC2_BP
!
!-----------------------------------------------------------------------
!
      PRIVATE :: RE_ALLOC_I2, RE_ALLOC_I4, RE_ALLOC_I8,                 &
     &           RE_ALLOC_R4, RE_ALLOC_R8,                              &
     &           RE_ALLOC_BP
!     &          ,RE_ALLOC_R16
!
      INTERFACE RE_ALLOC
!
      MODULE PROCEDURE RE_ALLOC_I2, RE_ALLOC_I4, RE_ALLOC_I8,           &
     &                 RE_ALLOC_R4, RE_ALLOC_R8,                        &
     &                 RE_ALLOC_BP
!     &                ,RE_ALLOC_R16
!
      END INTERFACE RE_ALLOC
!
      PRIVATE :: RE_ALLOC2_I2, RE_ALLOC2_I4, RE_ALLOC2_I8,              &
     &           RE_ALLOC2_R4, RE_ALLOC2_R8,                            &
     &           RE_ALLOC2_BP
!     &          ,RE_ALLOC2_R16
!
      INTERFACE RE_ALLOC2
!
      MODULE PROCEDURE RE_ALLOC2_I2, RE_ALLOC2_I4, RE_ALLOC2_I8,        &
     &                 RE_ALLOC2_R4, RE_ALLOC2_R8,                      &
     &                 RE_ALLOC2_BP
!     &                ,RE_ALLOC2_R16
!
      END INTERFACE RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      CONTAINS
!
!-----------------------------------------------------------------------
!
      SUBROUTINE RE_ALLOC_I2(A,I1,NA,NT,IERR)
!
!-----------------------------------------------------------------------
!
!  THE ALLOCATABLE ARRAY A(I1:NA) IS RE-ALLOCATED AS A(I1:NT),
!  PRESERVING THE CONTENTS I1:NAT=MIN(NA,NT)
!
!  INPUT ONLY REQUIRES I1.GE.LBOUND(A,1) AND NA.LE.UBOUND(A,1), NOT .EQ.
!  AND SO NT=NA IS STILL RE-ALLOCATED.
!
!  OUTPUT HAS LBOUND(A,1).EQ.I1 AND UBOUND(A,1).EQ.NT
!
! ***THIS VERSION HANDLES INTEGER( 2) ARRAYS - USE RE_ALLOC_RN FOR REALS
!
!  IT CALLS:
!    SR.MOVE_ALLOC (F2003 INTRINSIC, IF B_F2003.EQ..TRUE.)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
      USE PARAM, ONLY: B_F2003
      USE UTILITY
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      INTEGER(SP) I1,NA,NT
      INTEGER(SP) IERR,NAT
!
      integer(sp) iflag1,iflag2
!
      INTEGER( 2), ALLOCATABLE :: A(:)         !Intel/PGI must not split
      INTEGER( 2), ALLOCATABLE :: T(:)         !But o.k. to do so here
!
      NAT=MIN(NA,NT)
!
      IF(B_F2003)THEN         ! *** TEMP: NEED F2003 TO SPEC. BOUND KIND
!
        if(.not.allocated(a))then
          ierr=1
!3        elseif(i1.lt.lbound(a,1,sp))then
          ierr=-1
          iflag1=i1
!3          iflag2=lbound(a,1,sp)
!3        elseif(na.gt.ubound(a,1,sp))then
          ierr=-2
          iflag1=na
!3          iflag2=ubound(a,1,sp)
        else
          ierr=0
        endif
!
      ELSEIF(SP.LT.8)THEN                      !BOUND CANNOT REACH 2**31
!
        if(.not.allocated(a))then
          ierr=1
        elseif(i1.lt.lbound(a,1))then
          ierr=-1
          iflag1=i1
          iflag2=lbound(a,1)
        elseif(na.gt.ubound(a,1))then
          ierr=-2
          iflag1=na
          iflag2=ubound(a,1)
        else
          ierr=0
        endif
!
      ELSE
!
! NOT SAFE TO CHECK BOUNDS, ARRAY INDEX MAYBE .GT.2**31-1, CASE SP=8.
!
        if(.not.allocated(a))then
          ierr=1
        else
          ierr=0
        endif
!
      ENDIF
!
      if(ierr.gt.0)then
!        write(mw6,*)
!     &  'sr.re_alloc: request to re-allocate a non-allocated array'
        write(mw0,*)                                                    &
     &       'sr.re_alloc: request to re-allocate a non-allocated array'
        return
      elseif(ierr.lt.0)then
!        write(mw6,1000)ierr,iflag1,iflag2
! 1000   format('sr.re_alloc: request to copy from outside allocated ',
!     &   'range of input array, ierr=',i2,' illegal range',i7,' : ',i7)
        write(mw0,*)                                                    &
     &       'sr.re_alloc: request to copy from outside allocated range'&
     &       ,iflag1,iflag2
        return
      endif
!
      IF(B_F2003.and.i1.eq.1)THEN              !.eq.1 for Oracle Studio
        ALLOCATE(T(I1:NT),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT)=A(I1:NAT)
        CALL MOVE_ALLOC(T,A)
      ELSE
        ALLOCATE(T(I1:NAT),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT)=A(I1:NAT)
        DEALLOCATE(A)
        ALLOCATE(A(I1:NT),STAT=IERR)
        IF(IERR.NE.0)RETURN
        A(I1:NAT)=T(I1:NAT)
        DEALLOCATE(T)
      ENDIF
!
      RETURN
!
      END SUBROUTINE RE_ALLOC_I2
!
!-----------------------------------------------------------------------
!
      SUBROUTINE RE_ALLOC_I4(A,I1,NA,NT,IERR)
!
!-----------------------------------------------------------------------
!
!  THE ALLOCATABLE ARRAY A(I1:NA) IS RE-ALLOCATED AS A(I1:NT),
!  PRESERVING THE CONTENTS I1:NAT=MIN(NA,NT)
!
!  INPUT ONLY REQUIRES I1.GE.LBOUND(A,1) AND NA.LE.UBOUND(A,1), NOT .EQ.
!  AND SO NT=NA IS STILL RE-ALLOCATED.
!
!  OUTPUT HAS LBOUND(A,1).EQ.I1 AND UBOUND(A,1).EQ.NT
!
! ***THIS VERSION HANDLES INTEGER( 4) ARRAYS - USE RE_ALLOC_R4 FOR REALS
!
!  IT CALLS:
!    SR.MOVE_ALLOC (F2003 INTRINSIC, IF B_F2003.EQ..TRUE.)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
      USE PARAM, ONLY: B_F2003
      USE UTILITY
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      INTEGER(SP) I1,NA,NT
      INTEGER(SP) IERR,NAT
!
      integer(sp) iflag1,iflag2
!
      INTEGER( 4), ALLOCATABLE :: A(:)         !Intel/PGI must not split
      INTEGER( 4), ALLOCATABLE :: T(:)         !But o.k. to do so here
!
      NAT=MIN(NA,NT)
!
      IF(B_F2003)THEN         ! *** TEMP: NEED F2003 TO SPEC. BOUND KIND
!
        if(.not.allocated(a))then
          ierr=1
!3        elseif(i1.lt.lbound(a,1,sp))then
          ierr=-1
          iflag1=i1
!3          iflag2=lbound(a,1,sp)
!3        elseif(na.gt.ubound(a,1,sp))then
          ierr=-2
          iflag1=na
!3          iflag2=ubound(a,1,sp)
        else
          ierr=0
        endif
!
      ELSEIF(SP.LT.8)THEN                      !BOUND CANNOT REACH 2**31
!
        if(.not.allocated(a))then
          ierr=1
        elseif(i1.lt.lbound(a,1))then
          ierr=-1
          iflag1=i1
          iflag2=lbound(a,1)
        elseif(na.gt.ubound(a,1))then
          ierr=-2
          iflag1=na
          iflag2=ubound(a,1)
        else
          ierr=0
        endif
!
      ELSE
!
! NOT SAFE TO CHECK BOUNDS, ARRAY INDEX MAYBE .GT.2**31-1, CASE SP=8.
!
        if(.not.allocated(a))then
          ierr=1
        else
          ierr=0
        endif
!
      ENDIF
!
      if(ierr.gt.0)then
!        write(mw6,*)
!     &  'sr.re_alloc: request to re-allocate a non-allocated array'
        write(mw0,*)                                                    &
     &       'sr.re_alloc: request to re-allocate a non-allocated array'
        return
      elseif(ierr.lt.0)then
!        write(mw6,1000)ierr,iflag1,iflag2
! 1000   format('sr.re_alloc: request to copy from outside allocated ',
!     &   'range of input array, ierr=',i2,' illegal range',i7,' : ',i7)
        write(mw0,*)                                                    &
     &       'sr.re_alloc: request to copy from outside allocated range'&
     &       ,iflag1,iflag2
        return
      endif
!
      IF(B_F2003.and.i1.eq.1)THEN              !.eq.1 for Oracle Studio
        ALLOCATE(T(I1:NT),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT)=A(I1:NAT)
        CALL MOVE_ALLOC(T,A)
      ELSE
        ALLOCATE(T(I1:NAT),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT)=A(I1:NAT)
        DEALLOCATE(A)
        ALLOCATE(A(I1:NT),STAT=IERR)
        IF(IERR.NE.0)RETURN
        A(I1:NAT)=T(I1:NAT)
        DEALLOCATE(T)
      ENDIF
!
      RETURN
!
      END SUBROUTINE RE_ALLOC_I4
!
!-----------------------------------------------------------------------
!
      SUBROUTINE RE_ALLOC_I8(A,I1,NA,NT,IERR)
!
!-----------------------------------------------------------------------
!
!  THE ALLOCATABLE ARRAY A(I1:NA) IS RE-ALLOCATED AS A(I1:NT),
!  PRESERVING THE CONTENTS I1:NAT=MIN(NA,NT)
!
!  INPUT ONLY REQUIRES I1.GE.LBOUND(A,1) AND NA.LE.UBOUND(A,1), NOT .EQ.
!  AND SO NT=NA IS STILL RE-ALLOCATED.
!
!  OUTPUT HAS LBOUND(A,1).EQ.I1 AND UBOUND(A,1).EQ.NT
!
! ***THIS VERSION HANDLES INTEGER( 8) ARRAYS - USE RE_ALLOC_R8 FOR REALS
!
!  IT CALLS:
!    SR.MOVE_ALLOC (F2003 INTRINSIC, IF B_F2003.EQ..TRUE.)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
      USE PARAM, ONLY: B_F2003
      USE UTILITY
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      INTEGER(SP) I1,NA,NT
      INTEGER(SP) IERR,NAT
!
      integer(sp) iflag1,iflag2
!
      INTEGER( 8), ALLOCATABLE :: A(:)         !Intel/PGI must not split
      INTEGER( 8), ALLOCATABLE :: T(:)         !But o.k. to do so here
!
      NAT=MIN(NA,NT)
!
      IF(B_F2003)THEN         ! *** TEMP: NEED F2003 TO SPEC. BOUND KIND
!
        IF(B_F2003)THEN       ! *** TEMP: NEED F2003 TO SPEC. BOUND KIND
!
          if(.not.allocated(a))then
            ierr=1
!3          elseif(i1.lt.lbound(a,1,sp))then
            ierr=-1
            iflag1=i1
!3            iflag2=lbound(a,1,sp)
!3          elseif(na.gt.ubound(a,1,sp))then
            ierr=-2
            iflag1=na
!3            iflag2=ubound(a,1,sp)
          else
            ierr=0
          endif
!
        ELSEIF(SP.LT.8)THEN                    !BOUND CANNOT REACH 2**31
!
          if(.not.allocated(a))then
            ierr=1
          elseif(i1.lt.lbound(a,1))then
            ierr=-1
            iflag1=i1
            iflag2=lbound(a,1)
          elseif(na.gt.ubound(a,1))then
            ierr=-2
            iflag1=na
            iflag2=ubound(a,1)
          else
            ierr=0
          endif
!
        ELSE
!
! NOT SAFE TO CHECK BOUNDS, ARRAY INDEX MAYBE .GT.2**31-1, CASE SP=8.
!
          if(.not.allocated(a))then
            ierr=1
          else
            ierr=0
          endif
!
        ENDIF
!
        if(ierr.gt.0)then
!        write(mw6,*)
!     &  'sr.re_alloc: request to re-allocate a non-allocated array'
          write(mw0,*)                                                  &
     &       'sr.re_alloc: request to re-allocate a non-allocated array'
          return
        elseif(ierr.lt.0)then
!        write(mw6,1000)ierr,iflag1,iflag2
! 1000   format('sr.re_alloc: request to copy from outside allocated ',
!     &   'range of input array, ierr=',i2,' illegal range',i7,' : ',i7)
          write(mw0,*)                                                  &
     &       'sr.re_alloc: request to copy from outside allocated range'&
     &       ,iflag1,iflag2
          return
        endif
!
      ENDIF
!
      IF(B_F2003.and.i1.eq.1)THEN              !.eq.1 for Oracle Studio
        ALLOCATE(T(I1:NT),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT)=A(I1:NAT)
        CALL MOVE_ALLOC(T,A)
      ELSE
        ALLOCATE(T(I1:NAT),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT)=A(I1:NAT)
        DEALLOCATE(A)
        ALLOCATE(A(I1:NT),STAT=IERR)
        IF(IERR.NE.0)RETURN
        A(I1:NAT)=T(I1:NAT)
        DEALLOCATE(T)
      ENDIF
!
      RETURN
!
      END SUBROUTINE RE_ALLOC_I8
!
!-----------------------------------------------------------------------
!
      SUBROUTINE RE_ALLOC_R4(A,I1,NA,NT,IERR)
!
!-----------------------------------------------------------------------
!
!  THE ALLOCATABLE ARRAY A(I1:NA) IS RE-ALLOCATED AS A(I1:NT),
!  PRESERVING THE CONTENTS I1:NAT=MIN(NA,NT)
!
!  INPUT ONLY REQUIRES I1.GE.LBOUND(A,1) AND NA.LE.UBOUND(A,1), NOT .EQ.
!  AND SO NT=NA IS STILL RE-ALLOCATED.
!
!  OUTPUT HAS LBOUND(A,1).EQ.I1 AND UBOUND(A,1).EQ.NT
!
! ***THIS VERSION HANDLES REAL( 4) ARRAYS - USE RE_ALLOC_I4 FOR INTEGERS
!
!  IT CALLS:
!    SR.MOVE_ALLOC (F2003 INTRINSIC, IF B_F2003.EQ..TRUE.)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
      USE PARAM, ONLY: B_F2003
      USE UTILITY
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      INTEGER(SP) I1,NA,NT
      INTEGER(SP) IERR,NAT
!
      integer(sp) iflag1,iflag2
!
      REAL( 4), ALLOCATABLE :: A(:)            !Intel/PGI must not split
      REAL( 4), ALLOCATABLE :: T(:)            !But o.k. to do so here
!
      NAT=MIN(NA,NT)
!
      IF(B_F2003)THEN         ! *** TEMP: NEED F2003 TO SPEC. BOUND KIND
!
        if(.not.allocated(a))then
          ierr=1
!3        elseif(i1.lt.lbound(a,1,sp))then
          ierr=-1
          iflag1=i1
!3          iflag2=lbound(a,1,sp)
!3        elseif(na.gt.ubound(a,1,sp))then
          ierr=-2
          iflag1=na
!3          iflag2=ubound(a,1,sp)
        else
          ierr=0
        endif
!
      ELSEIF(SP.LT.8)THEN                      !BOUND CANNOT REACH 2**31
!
        if(.not.allocated(a))then
          ierr=1
        elseif(i1.lt.lbound(a,1))then
          ierr=-1
          iflag1=i1
          iflag2=lbound(a,1)
        elseif(na.gt.ubound(a,1))then
          ierr=-2
          iflag1=na
          iflag2=ubound(a,1)
        else
          ierr=0
        endif
!
      ELSE
!
! NOT SAFE TO CHECK BOUNDS, ARRAY INDEX MAYBE .GT.2**31-1, CASE SP=8.
!
        if(.not.allocated(a))then
          ierr=1
        else
          ierr=0
        endif
!
      ENDIF
!
      if(ierr.gt.0)then
!        write(mw6,*)
!     &  'sr.re_alloc: request to re-allocate a non-allocated array'
        write(mw0,*)                                                    &
     &       'sr.re_alloc: request to re-allocate a non-allocated array'
        return
      elseif(ierr.lt.0)then
!        write(mw6,1000)ierr,iflag1,iflag2
! 1000   format('sr.re_alloc: request to copy from outside allocated ',
!     &   'range of input array, ierr=',i2,' illegal range',i7,' : ',i7)
        write(mw0,*)                                                    &
     &       'sr.re_alloc: request to copy from outside allocated range'&
     &       ,iflag1,iflag2
        return
      endif
!
      IF(B_F2003.and.i1.eq.1)THEN              !.eq.1 for Oracle Studio
        ALLOCATE(T(I1:NT),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT)=A(I1:NAT)
        CALL MOVE_ALLOC(T,A)
      ELSE
        ALLOCATE(T(I1:NAT),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT)=A(I1:NAT)
        DEALLOCATE(A)
        ALLOCATE(A(I1:NT),STAT=IERR)
        IF(IERR.NE.0)RETURN
        A(I1:NAT)=T(I1:NAT)
        DEALLOCATE(T)
      ENDIF
!
      RETURN
!
      END SUBROUTINE RE_ALLOC_R4
!
!-----------------------------------------------------------------------
!
      SUBROUTINE RE_ALLOC_R8(A,I1,NA,NT,IERR)
!
!-----------------------------------------------------------------------
!
!  THE ALLOCATABLE ARRAY A(I1:NA) IS RE-ALLOCATED AS A(I1:NT),
!  PRESERVING THE CONTENTS I1:NAT=MIN(NA,NT)
!
!  INPUT ONLY REQUIRES I1.GE.LBOUND(A,1) AND NA.LE.UBOUND(A,1), NOT .EQ.
!  AND SO NT=NA IS STILL RE-ALLOCATED.
!
!  OUTPUT HAS LBOUND(A,1).EQ.I1 AND UBOUND(A,1).EQ.NT
!
! ***THIS VERSION HANDLES REAL( 8) ARRAYS - USE RE_ALLOC_I8 FOR INTEGERS
!
!  IT CALLS:
!    SR.MOVE_ALLOC (F2003 INTRINSIC, IF B_F2003.EQ..TRUE.)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
      USE PARAM, ONLY: B_F2003
      USE UTILITY
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      INTEGER(SP) I1,NA,NT
      INTEGER(SP) IERR,NAT
!
      integer(sp) iflag1,iflag2
!
      REAL( 8), ALLOCATABLE :: A(:)            !Intel/PGI must not split
      REAL( 8), ALLOCATABLE :: T(:)            !But o.k. to do so here
!
      NAT=MIN(NA,NT)
!
      IF(B_F2003)THEN         ! *** TEMP: NEED F2003 TO SPEC. BOUND KIND
!
        if(.not.allocated(a))then
          ierr=1
!3        elseif(i1.lt.lbound(a,1,sp))then
          ierr=-1
          iflag1=i1
!3          iflag2=lbound(a,1,sp)
!3        elseif(na.gt.ubound(a,1,sp))then
          ierr=-2
          iflag1=na
!3          iflag2=ubound(a,1,sp)
        else
          ierr=0
        endif
!
      ELSEIF(SP.LT.8)THEN                      !BOUND CANNOT REACH 2**31
!
        if(.not.allocated(a))then
          ierr=1
        elseif(i1.lt.lbound(a,1))then
          ierr=-1
          iflag1=i1
          iflag2=lbound(a,1)
        elseif(na.gt.ubound(a,1))then
          ierr=-2
          iflag1=na
          iflag2=ubound(a,1)
        else
          ierr=0
        endif
!
      ELSE
!
! NOT SAFE TO CHECK BOUNDS, ARRAY INDEX MAYBE .GT.2**31-1, CASE SP=8.
!
        if(.not.allocated(a))then
          ierr=1
        else
          ierr=0
        endif
!
      ENDIF
!
      if(ierr.gt.0)then
!        write(mw6,*)
!     &  'sr.re_alloc: request to re-allocate a non-allocated array'
        write(mw0,*)                                                    &
     &       'sr.re_alloc: request to re-allocate a non-allocated array'
        return
      elseif(ierr.lt.0)then
!        write(mw6,1000)ierr,iflag1,iflag2
! 1000   format('sr.re_alloc: request to copy from outside allocated ',
!     &   'range of input array, ierr=',i2,' illegal range',i7,' : ',i7)
        write(mw0,*)                                                    &
     &       'sr.re_alloc: request to copy from outside allocated range'&
     &       ,iflag1,iflag2
        return
      endif
!
      IF(B_F2003.and.i1.eq.1)THEN              !.eq.1 for Oracle Studio
        ALLOCATE(T(I1:NT),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT)=A(I1:NAT)
        CALL MOVE_ALLOC(T,A)
      ELSE
        ALLOCATE(T(I1:NAT),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT)=A(I1:NAT)
        DEALLOCATE(A)
        ALLOCATE(A(I1:NT),STAT=IERR)
        IF(IERR.NE.0)RETURN
        A(I1:NAT)=T(I1:NAT)
        DEALLOCATE(T)
      ENDIF
!
      RETURN
!
      END SUBROUTINE RE_ALLOC_R8
!
!!----------------------------------------------------------------------
!!
!      SUBROUTINE RE_ALLOC_R16(A,I1,NA,NT,IERR)
!!
!!----------------------------------------------------------------------
!!
!!  THE ALLOCATABLE ARRAY A(I1:NA) IS RE-ALLOCATED AS A(I1:NT),
!!  PRESERVING THE CONTENTS I1:NAT=MIN(NA,NT)
!!
!!  INPUT ONLY REQUIRES I1.GE.LBOUND(A,1) AND NA.LE.UBOUND(A,1), NOT.EQ.
!!  AND SO NT=NA IS STILL RE-ALLOCATED.
!!
!!  OUTPUT HAS LBOUND(A,1).EQ.I1 AND UBOUND(A,1).EQ.NT
!!
!! ***THIS VERSION HANDLES REAL(16)ARRAYS - USE RE_ALLOC_I4 FOR INTEGERS
!!
!!  IT CALLS:
!!    SR.MOVE_ALLOC (F2003 INTRINSIC, IF B_F2003.EQ..TRUE.)
!!
!!----------------------------------------------------------------------
!!
!      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
!      USE PARAM, ONLY: B_F2003
!      USE UTILITY
!!
!!----------------------------------------------------------------------
!!
!      IMPLICIT NONE
!!
!      INTEGER(SP) I1,NA,NT
!      INTEGER(SP) IERR,NAT
!!
!      integer(sp) iflag1,iflag2
!!
!      REAL(16), ALLOCATABLE :: A(:)           !Intel/PGI must not split
!      REAL(16), ALLOCATABLE :: T(:)            !But o.k. to do so here
!!
!      NAT=MIN(NA,NT)
!
!      if(.not.allocated(a))then
!        ierr=1
!      elseif(i1.lt.lbound(a,1))then
!        ierr=-1
!        iflag1=i1
!        iflag2=lbound(a,1)
!      elseif(na.gt.ubound(a,1))then
!        ierr=-2
!        iflag1=na
!        iflag2=ubound(a,1)
!      else
!        ierr=0
!      endif
!!
!      if(ierr.gt.0)then
!!        write(mw6,*)
!!     &  'sr.re_alloc: request to re-allocate a non-allocated array'
!        write(mw0,*)
!     &  'sr.re_alloc: request to re-allocate a non-allocated array'
!        return
!      elseif(ierr.lt.0)then
!!        write(mw6,1000)ierr,iflag1,iflag2
!! 1000   format('sr.re_alloc: request to copy from outside allocated ',
!!     &  'range of input array, ierr=',i2,' illegal range',i7,' : ',i7)
!        write(mw0,*)
!     &   'sr.re_alloc: request to copy from outside allocated range'
!     &   ,iflag1,iflag2
!        return
!      endif
!!
!      IF(B_F2003.and.i1.eq.1)THEN              !.eq.1 for Oracle Studio
!        ALLOCATE(T(I1:NT),STAT=IERR)
!        IF(IERR.NE.0)RETURN
!        T(I1:NAT)=A(I1:NAT)
!        CALL MOVE_ALLOC(T,A)
!      ELSE
!        ALLOCATE(T(I1:NAT),STAT=IERR)
!        IF(IERR.NE.0)RETURN
!        T(I1:NAT)=A(I1:NAT)
!        DEALLOCATE(A)
!        ALLOCATE(A(I1:NT),STAT=IERR)
!        IF(IERR.NE.0)RETURN
!        A(I1:NAT)=T(I1:NAT)
!        DEALLOCATE(T)
!      ENDIF
!!
!      RETURN
!!
!      END SUBROUTINE RE_ALLOC_R16
!!
!----------------------------------------------------------------------
!
      SUBROUTINE RE_ALLOC_BP(A,I1,NA,NT,IERR)
!
!-----------------------------------------------------------------------
!
!  THE ALLOCATABLE ARRAY A(I1:NA) IS RE-ALLOCATED AS A(I1:NT),
!  PRESERVING THE CONTENTS I1:NAT=MIN(NA,NT)
!
!  INPUT ONLY REQUIRES I1.GE.LBOUND(A,1) AND NA.LE.UBOUND(A,1), NOT .EQ.
!  AND SO NT=NA IS STILL RE-ALLOCATED.
!
!  OUTPUT HAS LBOUND(A,1).EQ.I1 AND UBOUND(A,1).EQ.NT
!
! ***THIS VERSION HANDLES LOGICAL ARRAYS
!
!  IT CALLS:
!    SR.MOVE_ALLOC (F2003 INTRINSIC, IF B_F2003.EQ..TRUE.)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
      USE PARAM, ONLY: B_F2003
      USE UTILITY
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      INTEGER(SP) I1,NA,NT
      INTEGER(SP) IERR,NAT
!
      integer(sp) iflag1,iflag2
!
      LOGICAL(BP), ALLOCATABLE :: A(:)         !Intel/PGI must not split
      LOGICAL(BP), ALLOCATABLE :: T(:)         !But o.k. to do so here
!
      NAT=MIN(NA,NT)
!
      IF(B_F2003)THEN         ! *** TEMP: NEED F2003 TO SPEC. BOUND KIND
!
        if(.not.allocated(a))then
          ierr=1
!3        elseif(i1.lt.lbound(a,1,sp))then
          ierr=-1
          iflag1=i1
!3          iflag2=lbound(a,1,sp)
!3        elseif(na.gt.ubound(a,1,sp))then
          ierr=-2
          iflag1=na
!3          iflag2=ubound(a,1,sp)
        else
          ierr=0
        endif
!
      ELSEIF(SP.LT.8)THEN                      !BOUND CANNOT REACH 2**31
!
        if(.not.allocated(a))then
          ierr=1
        elseif(i1.lt.lbound(a,1))then
          ierr=-1
          iflag1=i1
          iflag2=lbound(a,1)
        elseif(na.gt.ubound(a,1))then
          ierr=-2
          iflag1=na
          iflag2=ubound(a,1)
        else
          ierr=0
        endif
!
      ELSE
!
! NOT SAFE TO CHECK BOUNDS, ARRAY INDEX MAYBE .GT.2**31-1, CASE SP=8.
!
        if(.not.allocated(a))then
          ierr=1
        else
          ierr=0
        endif
!
      ENDIF
!
      if(ierr.gt.0)then
!        write(mw6,*)
!     &  'sr.re_alloc: request to re-allocate a non-allocated array'
        write(mw0,*)                                                    &
     &       'sr.re_alloc: request to re-allocate a non-allocated array'
        return
      elseif(ierr.lt.0)then
!        write(mw6,1000)ierr,iflag1,iflag2
! 1000   format('sr.re_alloc: request to copy from outside allocated ',
!     &   'range of input array, ierr=',i2,' illegal range',i7,' : ',i7)
        write(mw0,*)                                                    &
     &       'sr.re_alloc: request to copy from outside allocated range'&
     &       ,iflag1,iflag2
        return
      endif
!
      IF(B_F2003.and.i1.eq.1)THEN              !.eq.1 for Oracle Studio
        ALLOCATE(T(I1:NT),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT)=A(I1:NAT)
        CALL MOVE_ALLOC(T,A)
      ELSE
        ALLOCATE(T(I1:NAT),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT)=A(I1:NAT)
        DEALLOCATE(A)
        ALLOCATE(A(I1:NT),STAT=IERR)
        IF(IERR.NE.0)RETURN
        A(I1:NAT)=T(I1:NAT)
        DEALLOCATE(T)
      ENDIF
!
      RETURN
!
      END SUBROUTINE RE_ALLOC_BP
!
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!
      SUBROUTINE RE_ALLOC2_I2(A,I1,NA1,I2,NA2,NT1,NT2,IERR)
!
!-----------------------------------------------------------------------
!
!  THE ARRAY A(I1:NA1,I2:NA2) IS RE-ALLOCATED AS A(I1:NT1,I2:NT2).
!  PRESERVING THE CONTENTS I1:NAT1=MIN(NA1,NT1), I2:NAT2=MIN(NA2,NT2)
!
!  INPUT ONLY REQUIRES I1.GE.LBOUND(A,1),  I2.GE.LBOUND(A,2)  AND
!                     NA1.LE.UBOUND(A,1), NA2.LE.UBOUND(A,2)  NOT .EQ.
!  AND SO NT=NA IS STILL RE-ALLOCATED.
!
!  OUTPUT HAS LBOUND(A,1).EQ.I1, LBOUND(A,2).EQ.I2  AND
!             UBOUND(A,1).EQ.NT1,UBOUND(A,2).EQ.NT2
!
! ***THIS VERSION HANDLES INTEGER( 2) ARRAYS - USE RE_ALLOC_R8 FOR REALS
!
!  IT CALLS:
!    SR.MOVE_ALLOC (F2003 INTRINSIC, IF B_F2003.EQ..TRUE.)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
      USE PARAM, ONLY: B_F2003
      USE UTILITY
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      INTEGER(SP) I1,I2,NA1,NA2,NT1,NT2
      INTEGER(SP) IERR,NAT1,NAT2
!
      integer(sp) iflag1,iflag2
!
      INTEGER( 2), ALLOCATABLE :: A(:,:)       !Intel/PGI must not split
      INTEGER( 2), ALLOCATABLE :: T(:,:)       !But o.k. to do so here
!
      NAT1=MIN(NA1,NT1)
      NAT2=MIN(NA2,NT2)
!
      IF(B_F2003)THEN         ! *** TEMP: NEED F2003 TO SPEC. BOUND KIND
!
        if(.not.allocated(a))then
          ierr=1
!3        elseif(i1.lt.lbound(a,1,sp))then
          ierr=-1
          iflag1=i1
!3          iflag2=lbound(a,1,sp)
!3        elseif(nat1.gt.ubound(a,1,sp))then
          ierr=-2
          iflag1=nat1
!3          iflag2=ubound(a,1,sp)
!3        elseif(i2.lt.lbound(a,2,sp))then
          ierr=-3
          iflag1=i2
!3          iflag2=lbound(a,2,sp)
!3        elseif(nat2.gt.ubound(a,2,sp))then
          ierr=-4
          iflag1=nat2
!3          iflag2=ubound(a,2,sp)
        else
          ierr=0
        endif
!
      ELSEIF(SP.LT.8)THEN                      !BOUND CANNOT REACH 2**31
!
        if(.not.allocated(a))then
          ierr=1
        elseif(i1.lt.lbound(a,1))then
          ierr=-1
          iflag1=i1
          iflag2=lbound(a,1)
        elseif(nat1.gt.ubound(a,1))then
          ierr=-2
          iflag1=nat1
          iflag2=ubound(a,1)
        elseif(i2.lt.lbound(a,2))then
          ierr=-3
          iflag1=i2
          iflag2=lbound(a,2)
        elseif(nat2.gt.ubound(a,2))then
          ierr=-4
          iflag1=nat2
          iflag2=ubound(a,2)
        else
          ierr=0
        endif
!
      ELSE
!
! NOT SAFE TO CHECK BOUNDS, ARRAY INDEX MAYBE .GT.2**31-1, CASE SP=8.
!
        if(.not.allocated(a))then
          ierr=1
        else
          ierr=0
        endif
!
      ENDIF
!
      if(ierr.gt.0)then
!        write(mw6,*)
!     &  'sr.re_alloc2: request to re-allocate a non-allocated array'
        write(mw0,*)                                                    &
     &      'sr.re_alloc2: request to re-allocate a non-allocated array'
        return
      elseif(ierr.lt.0)then
!        write(mw6,1000)ierr,iflag1,iflag2
! 1000   format('sr.re_alloc2: request to copy from outside allocated ',
!     &   'range of input array, ierr=',i2,' illegal range',i7,' : ',i7)
        write(mw0,*)                                                    &
     &      'sr.re_alloc2: request to copy from outside allocated range'&
     &      ,iflag1,iflag2
        return
      endif
!
      IF(B_F2003.and.i1*i2.eq.1)THEN           !.eq.1 for Oracle Studio
        ALLOCATE(T(I1:NT1,I2:NT2),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT1,I2:NAT2)=A(I1:NAT1,I2:NAT2)
        CALL MOVE_ALLOC(T,A)
      ELSE
        ALLOCATE(T(I1:NAT1,I2:NAT2),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT1,I2:NAT2)=A(I1:NAT1,I2:NAT2)
        DEALLOCATE(A)
        ALLOCATE(A(I1:NT1,I2:NT2),STAT=IERR)
        IF(IERR.NE.0)RETURN
        A(I1:NAT1,I2:NAT2)=T
        DEALLOCATE(T)
      ENDIF
!
      RETURN
!
      END SUBROUTINE RE_ALLOC2_I2
!
      SUBROUTINE RE_ALLOC2_I4(A,I1,NA1,I2,NA2,NT1,NT2,IERR)
!
!-----------------------------------------------------------------------
!
!  THE ARRAY A(I1:NA1,I2:NA2) IS RE-ALLOCATED AS A(I1:NT1,I2:NT2).
!  PRESERVING THE CONTENTS I1:NAT1=MIN(NA1,NT1), I2:NAT2=MIN(NA2,NT2)
!
!  INPUT ONLY REQUIRES I1.GE.LBOUND(A,1),  I2.GE.LBOUND(A,2)  AND
!                     NA1.LE.UBOUND(A,1), NA2.LE.UBOUND(A,2)  NOT .EQ.
!  AND SO NT=NA IS STILL RE-ALLOCATED.
!
!  OUTPUT HAS LBOUND(A,1).EQ.I1, LBOUND(A,2).EQ.I2  AND
!             UBOUND(A,1).EQ.NT1,UBOUND(A,2).EQ.NT2
!
! ***THIS VERSION HANDLES INTEGER( 4) ARRAYS - USE RE_ALLOC_R4 FOR REALS
!
!  IT CALLS:
!    SR.MOVE_ALLOC (F2003 INTRINSIC, IF B_F2003.EQ..TRUE.)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
      USE PARAM, ONLY: B_F2003
      USE UTILITY
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      INTEGER(SP) I1,I2,NA1,NA2,NT1,NT2
      INTEGER(SP) IERR,NAT1,NAT2
!
      integer(sp) iflag1,iflag2
!
      INTEGER( 4), ALLOCATABLE :: A(:,:)       !Intel/PGI must not split
      INTEGER( 4), ALLOCATABLE :: T(:,:)       !But o.k. to do so here
!
      NAT1=MIN(NA1,NT1)
      NAT2=MIN(NA2,NT2)
!
      IF(B_F2003)THEN         ! *** TEMP: NEED F2003 TO SPEC. BOUND KIND
!
        if(.not.allocated(a))then
          ierr=1
!3        elseif(i1.lt.lbound(a,1,sp))then
          ierr=-1
          iflag1=i1
!3          iflag2=lbound(a,1,sp)
!3        elseif(nat1.gt.ubound(a,1,sp))then
          ierr=-2
          iflag1=nat1
!3          iflag2=ubound(a,1,sp)
!3        elseif(i2.lt.lbound(a,2,sp))then
          ierr=-3
          iflag1=i2
!3          iflag2=lbound(a,2,sp)
!3        elseif(nat2.gt.ubound(a,2,sp))then
          ierr=-4
          iflag1=nat2
!3          iflag2=ubound(a,2,sp)
        else
          ierr=0
        endif
!
      ELSEIF(SP.LT.8)THEN                      !BOUND CANNOT REACH 2**31
!
        if(.not.allocated(a))then
          ierr=1
        elseif(i1.lt.lbound(a,1))then
          ierr=-1
          iflag1=i1
          iflag2=lbound(a,1)
        elseif(nat1.gt.ubound(a,1))then
          ierr=-2
          iflag1=nat1
          iflag2=ubound(a,1)
        elseif(i2.lt.lbound(a,2))then
          ierr=-3
          iflag1=i2
          iflag2=lbound(a,2)
        elseif(nat2.gt.ubound(a,2))then
          ierr=-4
          iflag1=nat2
          iflag2=ubound(a,2)
        else
          ierr=0
        endif
!
      ELSE
!
! NOT SAFE TO CHECK BOUNDS, ARRAY INDEX MAYBE .GT.2**31-1, CASE SP=8.
!
        if(.not.allocated(a))then
          ierr=1
        else
          ierr=0
        endif
!
      ENDIF
!
      if(ierr.gt.0)then
!        write(mw6,*)
!     &  'sr.re_alloc2: request to re-allocate a non-allocated array'
        write(mw0,*)                                                    &
     &      'sr.re_alloc2: request to re-allocate a non-allocated array'
        return
      elseif(ierr.lt.0)then
!        write(mw6,1000)ierr,iflag1,iflag2
! 1000   format('sr.re_alloc2: request to copy from outside allocated ',
!     &   'range of input array, ierr=',i2,' illegal range',i7,' : ',i7)
        write(mw0,*)                                                    &
     &      'sr.re_alloc2: request to copy from outside allocated range'&
     &      ,iflag1,iflag2
        return
      endif
!
      IF(B_F2003.and.i1*i2.eq.1)THEN           !.eq.1 for Oracle Studio
        ALLOCATE(T(I1:NT1,I2:NT2),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT1,I2:NAT2)=A(I1:NAT1,I2:NAT2)
        CALL MOVE_ALLOC(T,A)
      ELSE
        ALLOCATE(T(I1:NAT1,I2:NAT2),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT1,I2:NAT2)=A(I1:NAT1,I2:NAT2)
        DEALLOCATE(A)
        ALLOCATE(A(I1:NT1,I2:NT2),STAT=IERR)
        IF(IERR.NE.0)RETURN
        A(I1:NAT1,I2:NAT2)=T
        DEALLOCATE(T)
      ENDIF
!
      RETURN
!
      END SUBROUTINE RE_ALLOC2_I4
!
!-----------------------------------------------------------------------
!
      SUBROUTINE RE_ALLOC2_I8(A,I1,NA1,I2,NA2,NT1,NT2,IERR)
!
!-----------------------------------------------------------------------
!
!  THE ARRAY A(I1:NA1,I2:NA2) IS RE-ALLOCATED AS A(I1:NT1,I2:NT2).
!  PRESERVING THE CONTENTS I1:NAT1=MIN(NA1,NT1), I2:NAT2=MIN(NA2,NT2)
!
!  INPUT ONLY REQUIRES I1.GE.LBOUND(A,1),  I2.GE.LBOUND(A,2)  AND
!                     NA1.LE.UBOUND(A,1), NA2.LE.UBOUND(A,2)  NOT .EQ.
!  AND SO NT=NA IS STILL RE-ALLOCATED.
!
!  OUTPUT HAS LBOUND(A,1).EQ.I1, LBOUND(A,2).EQ.I2  AND
!             UBOUND(A,1).EQ.NT1,UBOUND(A,2).EQ.NT2
!
! ***THIS VERSION HANDLES INTEGER( 8) ARRAYS - USE RE_ALLOC_R8 FOR REALS
!
!  IT CALLS:
!    SR.MOVE_ALLOC (F2003 INTRINSIC, IF B_F2003.EQ..TRUE.)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
      USE PARAM, ONLY: B_F2003
      USE UTILITY
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      INTEGER(SP) I1,I2,NA1,NA2,NT1,NT2
      INTEGER(SP) IERR,NAT1,NAT2
!
      integer(sp) iflag1,iflag2
!
      INTEGER( 8), ALLOCATABLE :: A(:,:)       !Intel/PGI must not split
      INTEGER( 8), ALLOCATABLE :: T(:,:)       !But o.k. to do so here
!
      NAT1=MIN(NA1,NT1)
      NAT2=MIN(NA2,NT2)
!
      IF(B_F2003)THEN         ! *** TEMP: NEED F2003 TO SPEC. BOUND KIND
!
        if(.not.allocated(a))then
          ierr=1
!3        elseif(i1.lt.lbound(a,1,sp))then
          ierr=-1
          iflag1=i1
!3          iflag2=lbound(a,1,sp)
!3        elseif(nat1.gt.ubound(a,1,sp))then
          ierr=-2
          iflag1=nat1
!3          iflag2=ubound(a,1,sp)
!3        elseif(i2.lt.lbound(a,2,sp))then
          ierr=-3
          iflag1=i2
!3          iflag2=lbound(a,2,sp)
!3        elseif(nat2.gt.ubound(a,2,sp))then
          ierr=-4
          iflag1=nat2
!3          iflag2=ubound(a,2,sp)
        else
          ierr=0
        endif
!
      ELSEIF(SP.LT.8)THEN                      !BOUND CANNOT REACH 2**31
!
        if(.not.allocated(a))then
          ierr=1
        elseif(i1.lt.lbound(a,1))then
          ierr=-1
          iflag1=i1
          iflag2=lbound(a,1)
        elseif(nat1.gt.ubound(a,1))then
          ierr=-2
          iflag1=nat1
          iflag2=ubound(a,1)
        elseif(i2.lt.lbound(a,2))then
          ierr=-3
          iflag1=i2
          iflag2=lbound(a,2)
        elseif(nat2.gt.ubound(a,2))then
          ierr=-4
          iflag1=nat2
          iflag2=ubound(a,2)
        else
          ierr=0
        endif
!
      ELSE
!
! NOT SAFE TO CHECK BOUNDS, ARRAY INDEX MAYBE .GT.2**31-1, CASE SP=8.
!
        if(.not.allocated(a))then
          ierr=1
        else
          ierr=0
        endif
!
      ENDIF
!
      if(ierr.gt.0)then
!        write(mw6,*)
!     &  'sr.re_alloc2: request to re-allocate a non-allocated array'
        write(mw0,*)                                                    &
     &      'sr.re_alloc2: request to re-allocate a non-allocated array'
        return
      elseif(ierr.lt.0)then
!        write(mw6,1000)ierr,iflag1,iflag2
! 1000   format('sr.re_alloc2: request to copy from outside allocated ',
!     &   'range of input array, ierr=',i2,' illegal range',i7,' : ',i7)
        write(mw0,*)                                                    &
     &      'sr.re_alloc2: request to copy from outside allocated range'&
     &      ,iflag1,iflag2
        return
      endif
!
      IF(B_F2003.and.i1*i2.eq.1)THEN           !.eq.1 for Oracle Studio
        ALLOCATE(T(I1:NT1,I2:NT2),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT1,I2:NAT2)=A(I1:NAT1,I2:NAT2)
        CALL MOVE_ALLOC(T,A)
      ELSE
        ALLOCATE(T(I1:NAT1,I2:NAT2),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT1,I2:NAT2)=A(I1:NAT1,I2:NAT2)
        DEALLOCATE(A)
        ALLOCATE(A(I1:NT1,I2:NT2),STAT=IERR)
        IF(IERR.NE.0)RETURN
        A(I1:NAT1,I2:NAT2)=T
        DEALLOCATE(T)
      ENDIF
!
      RETURN
!
      END SUBROUTINE RE_ALLOC2_I8
!
!-----------------------------------------------------------------------
!
      SUBROUTINE RE_ALLOC2_R4(A,I1,NA1,I2,NA2,NT1,NT2,IERR)
!
!-----------------------------------------------------------------------
!
!  THE ARRAY A(I1:NA1,I2:NA2) IS RE-ALLOCATED AS A(I1:NT1,I2:NT2).
!  PRESERVING THE CONTENTS I1:NAT1=MIN(NA1,NT1), I2:NAT2=MIN(NA2,NT2)
!
!  INPUT ONLY REQUIRES I1.GE.LBOUND(A,1),  I2.GE.LBOUND(A,2)  AND
!                     NA1.LE.UBOUND(A,1), NA2.LE.UBOUND(A,2)  NOT .EQ.
!  AND SO NT=NA IS STILL RE-ALLOCATED.
!
!  OUTPUT HAS LBOUND(A,1).EQ.I1, LBOUND(A,2).EQ.I2  AND
!             UBOUND(A,1).EQ.NT1,UBOUND(A,2).EQ.NT2
!
! ***THIS VERSION HANDLES REAL( 4) ARRAYS - USE RE_ALLOC_I4 FOR INTEGERS
!
!  IT CALLS:
!    SR.MOVE_ALLOC (F2003 INTRINSIC, IF B_F2003.EQ..TRUE.)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
      USE PARAM, ONLY: B_F2003
      USE UTILITY
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      INTEGER(SP) I1,I2,NA1,NA2,NT1,NT2
      INTEGER(SP) IERR,NAT1,NAT2
!
      integer(sp) iflag1,iflag2
!
      REAL( 4), ALLOCATABLE :: A(:,:)          !Intel/PGI must not split
      REAL( 4), ALLOCATABLE :: T(:,:)          !But o.k. to do so here
!
      NAT1=MIN(NA1,NT1)
      NAT2=MIN(NA2,NT2)
!
      IF(B_F2003)THEN         ! *** TEMP: NEED F2003 TO SPEC. BOUND KIND
!
        if(.not.allocated(a))then
          ierr=1
!3        elseif(i1.lt.lbound(a,1,sp))then
          ierr=-1
          iflag1=i1
!3          iflag2=lbound(a,1,sp)
!3        elseif(nat1.gt.ubound(a,1,sp))then
          ierr=-2
          iflag1=nat1
!3          iflag2=ubound(a,1,sp)
!3        elseif(i2.lt.lbound(a,2,sp))then
          ierr=-3
          iflag1=i2
!3          iflag2=lbound(a,2,sp)
!3        elseif(nat2.gt.ubound(a,2,sp))then
          ierr=-4
          iflag1=nat2
!3          iflag2=ubound(a,2,sp)
        else
          ierr=0
        endif
!
      ELSEIF(SP.LT.8)THEN                      !BOUND CANNOT REACH 2**31
!
        if(.not.allocated(a))then
          ierr=1
        elseif(i1.lt.lbound(a,1))then
          ierr=-1
          iflag1=i1
          iflag2=lbound(a,1)
        elseif(nat1.gt.ubound(a,1))then
          ierr=-2
          iflag1=nat1
          iflag2=ubound(a,1)
        elseif(i2.lt.lbound(a,2))then
          ierr=-3
          iflag1=i2
          iflag2=lbound(a,2)
        elseif(nat2.gt.ubound(a,2))then
          ierr=-4
          iflag1=nat2
          iflag2=ubound(a,2)
        else
          ierr=0
        endif
!
      ELSE
!
! NOT SAFE TO CHECK BOUNDS, ARRAY INDEX MAYBE .GT.2**31-1, CASE SP=8.
!
        if(.not.allocated(a))then
          ierr=1
        else
          ierr=0
        endif
!
      ENDIF
!
      if(ierr.gt.0)then
!        write(mw6,*)
!     &  'sr.re_alloc2: request to re-allocate a non-allocated array'
        write(mw0,*)                                                    &
     &      'sr.re_alloc2: request to re-allocate a non-allocated array'
        return
      elseif(ierr.lt.0)then
!        write(mw6,1000)ierr,iflag1,iflag2
! 1000   format('sr.re_alloc2: request to copy from outside allocated ',
!     &   'range of input array, ierr=',i2,' illegal range',i7,' : ',i7)
        write(mw0,*)                                                    &
     &      'sr.re_alloc2: request to copy from outside allocated range'&
     &      ,iflag1,iflag2
        return
      endif
!
      IF(B_F2003.and.i1*i2.eq.1)THEN           !.eq.1 for Oracle Studio
        ALLOCATE(T(I1:NT1,I2:NT2),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT1,I2:NAT2)=A(I1:NAT1,I2:NAT2)
        CALL MOVE_ALLOC(T,A)
      ELSE
        ALLOCATE(T(I1:NAT1,I2:NAT2),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT1,I2:NAT2)=A(I1:NAT1,I2:NAT2)
        DEALLOCATE(A)
        ALLOCATE(A(I1:NT1,I2:NT2),STAT=IERR)
        IF(IERR.NE.0)RETURN
        A(I1:NAT1,I2:NAT2)=T
        DEALLOCATE(T)
      ENDIF
!
      RETURN
!
      END SUBROUTINE RE_ALLOC2_R4
!
!-----------------------------------------------------------------------
!
      SUBROUTINE RE_ALLOC2_R8(A,I1,NA1,I2,NA2,NT1,NT2,IERR)
!
!-----------------------------------------------------------------------
!
!  THE ARRAY A(I1:NA1,I2:NA2) IS RE-ALLOCATED AS A(I1:NT1,I2:NT2).
!  PRESERVING THE CONTENTS I1:NAT1=MIN(NA1,NT1), I2:NAT2=MIN(NA2,NT2)
!
!  INPUT ONLY REQUIRES I1.GE.LBOUND(A,1),  I2.GE.LBOUND(A,2)  AND
!                     NA1.LE.UBOUND(A,1), NA2.LE.UBOUND(A,2)  NOT .EQ.
!  AND SO NT=NA IS STILL RE-ALLOCATED.
!
!  OUTPUT HAS LBOUND(A,1).EQ.I1, LBOUND(A,2).EQ.I2  AND
!             UBOUND(A,1).EQ.NT1,UBOUND(A,2).EQ.NT2
!
! ***THIS VERSION HANDLES REAL( 8) ARRAYS - USE RE_ALLOC_I8 FOR INTEGERS
!
!  IT CALLS:
!    SR.MOVE_ALLOC (F2003 INTRINSIC, IF B_F2003.EQ..TRUE.)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
      USE PARAM, ONLY: B_F2003
      USE UTILITY
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      INTEGER(SP) I1,I2,NA1,NA2,NT1,NT2
      INTEGER(SP) IERR,NAT1,NAT2
!
      integer(sp) iflag1,iflag2
!
      REAL( 8), ALLOCATABLE :: A(:,:)          !Intel/PGI must not split
      REAL( 8), ALLOCATABLE :: T(:,:)          !But o.k. to do so here
!
      NAT1=MIN(NA1,NT1)
      NAT2=MIN(NA2,NT2)
!
      IF(B_F2003)THEN         ! *** TEMP: NEED F2003 TO SPEC. BOUND KIND
!
        if(.not.allocated(a))then
          ierr=1
!3        elseif(i1.lt.lbound(a,1,sp))then
          ierr=-1
          iflag1=i1
!3          iflag2=lbound(a,1,sp)
!3        elseif(nat1.gt.ubound(a,1,sp))then
          ierr=-2
          iflag1=nat1
!3          iflag2=ubound(a,1,sp)
!3        elseif(i2.lt.lbound(a,2,sp))then
          ierr=-3
          iflag1=i2
!3          iflag2=lbound(a,2,sp)
!3        elseif(nat2.gt.ubound(a,2,sp))then
          ierr=-4
          iflag1=nat2
!3          iflag2=ubound(a,2,sp)
        else
          ierr=0
        endif
!
      ELSEIF(SP.LT.8)THEN                      !BOUND CANNOT REACH 2**31
!
        if(.not.allocated(a))then
          ierr=1
        elseif(i1.lt.lbound(a,1))then
          ierr=-1
          iflag1=i1
          iflag2=lbound(a,1)
        elseif(nat1.gt.ubound(a,1))then
          ierr=-2
          iflag1=nat1
          iflag2=ubound(a,1)
        elseif(i2.lt.lbound(a,2))then
          ierr=-3
          iflag1=i2
          iflag2=lbound(a,2)
        elseif(nat2.gt.ubound(a,2))then
          ierr=-4
          iflag1=nat2
          iflag2=ubound(a,2)
        else
          ierr=0
        endif
!
      ELSE
!
! NOT SAFE TO CHECK BOUNDS, ARRAY INDEX MAYBE .GT.2**31-1, CASE SP=8.
!
        if(.not.allocated(a))then
          ierr=1
        else
          ierr=0
        endif
!
      ENDIF
!
      if(ierr.gt.0)then
!        write(mw6,*)
!     &  'sr.re_alloc2: request to re-allocate a non-allocated array'
        write(mw0,*)                                                    &
     &      'sr.re_alloc2: request to re-allocate a non-allocated array'
        return
      elseif(ierr.lt.0)then
!        write(mw6,1000)ierr,iflag1,iflag2
! 1000   format('sr.re_alloc2: request to copy from outside allocated ',
!     &   'range of input array, ierr=',i2,' illegal range',i7,' : ',i7)
        write(mw0,*)                                                    &
     &      'sr.re_alloc2: request to copy from outside allocated range'&
     &      ,iflag1,iflag2
        return
      endif
!
      IF(B_F2003.and.i1*i2.eq.1)THEN           !.eq.1 for Oracle Studio
        ALLOCATE(T(I1:NT1,I2:NT2),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT1,I2:NAT2)=A(I1:NAT1,I2:NAT2)
        CALL MOVE_ALLOC(T,A)
      ELSE
        ALLOCATE(T(I1:NAT1,I2:NAT2),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT1,I2:NAT2)=A(I1:NAT1,I2:NAT2)
        DEALLOCATE(A)
        ALLOCATE(A(I1:NT1,I2:NT2),STAT=IERR)
        IF(IERR.NE.0)RETURN
        A(I1:NAT1,I2:NAT2)=T
        DEALLOCATE(T)
      ENDIF
!
      RETURN
!
      END SUBROUTINE RE_ALLOC2_R8
!
!!----------------------------------------------------------------------
!!
!      SUBROUTINE RE_ALLOC2_R16(A,I1,NA1,I2,NA2,NT1,NT2,IERR)
!!
!!----------------------------------------------------------------------
!!
!!  THE ARRAY A(I1:NA1,I2:NA2) IS RE-ALLOCATED AS A(I1:NT1,I2:NT2).
!!  PRESERVING THE CONTENTS I1:NAT1=MIN(NA1,NT1), I2:NAT2=MIN(NA2,NT2)
!!
!!  INPUT ONLY REQUIRES I1.GE.LBOUND(A,1),  I2.GE.LBOUND(A,2)  AND
!!                     NA1.LE.UBOUND(A,1), NA2.LE.UBOUND(A,2)  NOT.EQ.
!!  AND SO NT=NA IS STILL RE-ALLOCATED.
!!
!!  OUTPUT HAS LBOUND(A,1).EQ.I1, LBOUND(A,2).EQ.I2  AND
!!             UBOUND(A,1).EQ.NT1,UBOUND(A,2).EQ.NT2
!!
!! ***THIS VERSION HANDLES REAL(16)ARRAYS - USE RE_ALLOC_I4 FOR INTEGERS
!!
!!  IT CALLS:
!!    SR.MOVE_ALLOC (F2003 INTRINSIC, IF B_F2003.EQ..TRUE.)
!!
!!----------------------------------------------------------------------
!!
!      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
!      USE PARAM, ONLY: B_F2003
!      USE UTILITY
!!
!!----------------------------------------------------------------------
!!
!      IMPLICIT NONE
!!
!      INTEGER(SP) I1,I2,NA1,NA2,NT1,NT2
!      INTEGER(SP) IERR,NAT1,NAT2
!!
!      integer(sp) iflag1,iflag2
!!
!      REAL(16), ALLOCATABLE :: A(:,:)         !Intel/PGI must not split
!      REAL(16), ALLOCATABLE :: T(:,:)          !But o.k. to do so here
!!
!      NAT1=MIN(NA1,NT1)
!      NAT2=MIN(NA2,NT2)
!!
!      if(.not.allocated(a))then
!        ierr=1
!      elseif(i1.lt.lbound(a,1))then
!        ierr=-1
!        iflag1=i1
!        iflag2=lbound(a,1)
!      elseif(nat1.gt.ubound(a,1))then
!        ierr=-2
!        iflag1=nat1
!        iflag2=ubound(a,1)
!      elseif(i2.lt.lbound(a,2))then
!        ierr=-3
!        iflag1=i2
!        iflag2=lbound(a,2)
!      elseif(nat2.gt.ubound(a,2))then
!        ierr=-4
!        iflag1=nat2
!        iflag2=ubound(a,2)
!      else
!        ierr=0
!      endif
!!
!      if(ierr.gt.0)then
!!        write(mw6,*)
!!     &  'sr.re_alloc2: request to re-allocate a non-allocated array'
!        write(mw0,*)
!     &  'sr.re_alloc2: request to re-allocate a non-allocated array'
!        return
!      elseif(ierr.lt.0)then
!!        write(mw6,1000)ierr,iflag1,iflag2
!! 1000  format('sr.re_alloc2: request to copy from outside allocated ',
!!     &  'range of input array, ierr=',i2,' illegal range',i7,' : ',i7)
!        write(mw0,*)
!     &   'sr.re_alloc2: request to copy from outside allocated range'
!     &   ,iflag1,iflag2
!        return
!      endif
!!
!      IF(B_F2003.and.i1*i2.eq.1)THEN           !.eq.1 for Oracle Studio
!        ALLOCATE(T(I1:NT1,I2:NT2),STAT=IERR)
!        IF(IERR.NE.0)RETURN
!        T(I1:NAT1,I2:NAT2)=A(I1:NAT1,I2:NAT2)
!        CALL MOVE_ALLOC(T,A)
!      ELSE
!        ALLOCATE(T(I1:NAT1,I2:NAT2),STAT=IERR)
!        IF(IERR.NE.0)RETURN
!        T(I1:NAT1,I2:NAT2)=A(I1:NAT1,I2:NAT2)
!        DEALLOCATE(A)
!        ALLOCATE(A(I1:NT1,I2:NT2),STAT=IERR)
!        IF(IERR.NE.0)RETURN
!        A(I1:NAT1,I2:NAT2)=T
!        DEALLOCATE(T)
!      ENDIF
!!
!      RETURN
!!
!      END SUBROUTINE RE_ALLOC2_R16
!!
!-----------------------------------------------------------------------
!
      SUBROUTINE RE_ALLOC2_BP(A,I1,NA1,I2,NA2,NT1,NT2,IERR)
!
!-----------------------------------------------------------------------
!
!  THE ARRAY A(I1:NA1,I2:NA2) IS RE-ALLOCATED AS A(I1:NT1,I2:NT2).
!  PRESERVING THE CONTENTS I1:NAT1=MIN(NA1,NT1), I2:NAT2=MIN(NA2,NT2)
!
!  INPUT ONLY REQUIRES I1.GE.LBOUND(A,1),  I2.GE.LBOUND(A,2)  AND
!                     NA1.LE.UBOUND(A,1), NA2.LE.UBOUND(A,2)  NOT .EQ.
!  AND SO NT=NA IS STILL RE-ALLOCATED.
!
!  OUTPUT HAS LBOUND(A,1).EQ.I1, LBOUND(A,2).EQ.I2  AND
!             UBOUND(A,1).EQ.NT1,UBOUND(A,2).EQ.NT2
!
! ***THIS VERSION HANDLES LOGICAL ARRAYS
!
!  IT CALLS:
!    SR.MOVE_ALLOC (F2003 INTRINSIC, IF B_F2003.EQ..TRUE.)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
      USE PARAM, ONLY: B_F2003
      USE UTILITY
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      INTEGER(SP) I1,I2,NA1,NA2,NT1,NT2
      INTEGER(SP) IERR,NAT1,NAT2
!
      integer(sp) iflag1,iflag2
!
      LOGICAL(BP), ALLOCATABLE :: A(:,:)       !Intel/PGI must not split
      LOGICAL(BP), ALLOCATABLE :: T(:,:)       !But o.k. to do so here
!
      NAT1=MIN(NA1,NT1)
      NAT2=MIN(NA2,NT2)
!
      IF(B_F2003)THEN         ! *** TEMP: NEED F2003 TO SPEC. BOUND KIND
!
        if(.not.allocated(a))then
          ierr=1
!3        elseif(i1.lt.lbound(a,1,sp))then
          ierr=-1
          iflag1=i1
!3          iflag2=lbound(a,1,sp)
!3        elseif(nat1.gt.ubound(a,1,sp))then
          ierr=-2
          iflag1=nat1
!3          iflag2=ubound(a,1,sp)
!3        elseif(i2.lt.lbound(a,2,sp))then
          ierr=-3
          iflag1=i2
!3          iflag2=lbound(a,2,sp)
!3        elseif(nat2.gt.ubound(a,2,sp))then
          ierr=-4
          iflag1=nat2
!3          iflag2=ubound(a,2,sp)
        else
          ierr=0
        endif
!
      ELSEIF(SP.LT.8)THEN                      !BOUND CANNOT REACH 2**31
!
        if(.not.allocated(a))then
          ierr=1
        elseif(i1.lt.lbound(a,1))then
          ierr=-1
          iflag1=i1
          iflag2=lbound(a,1)
        elseif(nat1.gt.ubound(a,1))then
          ierr=-2
          iflag1=nat1
          iflag2=ubound(a,1)
        elseif(i2.lt.lbound(a,2))then
          ierr=-3
          iflag1=i2
          iflag2=lbound(a,2)
        elseif(nat2.gt.ubound(a,2))then
          ierr=-4
          iflag1=nat2
          iflag2=ubound(a,2)
        else
          ierr=0
        endif
!
      ELSE
!
! NOT SAFE TO CHECK BOUNDS, ARRAY INDEX MAYBE .GT.2**31-1, CASE SP=8.
!
        if(.not.allocated(a))then
          ierr=1
        else
          ierr=0
        endif
!
      ENDIF
!
      if(ierr.gt.0)then
!        write(mw6,*)
!     &  'sr.re_alloc2: request to re-allocate a non-allocated array'
        write(mw0,*)                                                    &
     &      'sr.re_alloc2: request to re-allocate a non-allocated array'
        return
      elseif(ierr.lt.0)then
!        write(mw6,1000)ierr,iflag1,iflag2
! 1000   format('sr.re_alloc2: request to copy from outside allocated ',
!     &   'range of input array, ierr=',i2,' illegal range',i7,' : ',i7)
        write(mw0,*)                                                    &
     &      'sr.re_alloc2: request to copy from outside allocated range'&
     &      ,iflag1,iflag2
        return
      endif
!
      IF(B_F2003.and.i1*i2.eq.1)THEN           !.eq.1 for Oracle Studio
        ALLOCATE(T(I1:NT1,I2:NT2),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT1,I2:NAT2)=A(I1:NAT1,I2:NAT2)
        CALL MOVE_ALLOC(T,A)
      ELSE
        ALLOCATE(T(I1:NAT1,I2:NAT2),STAT=IERR)
        IF(IERR.NE.0)RETURN
        T(I1:NAT1,I2:NAT2)=A(I1:NAT1,I2:NAT2)
        DEALLOCATE(A)
        ALLOCATE(A(I1:NT1,I2:NT2),STAT=IERR)
        IF(IERR.NE.0)RETURN
        A(I1:NAT1,I2:NAT2)=T
        DEALLOCATE(T)
      ENDIF
!
      RETURN
!
      END SUBROUTINE RE_ALLOC2_BP
!
!-----------------------------------------------------------------------
!
      END MODULE REALLOCATE
!
!                             *******************
!
      subroutine move_alloc(adum,bdum)
!
! temporary dummy for non-f2003 compilers. for compilers that are f2003
! compliant, or at least support this routine, set B_F2003=.TRUE. in
! MODULE PARAM *and* comment-out this dummy.
!
      use utility_unit
!
      integer adum,bdum
      dimension adum(*),bdum(*)
!
      write(mw6,*)                                                      &
     &'Comment-out MOVE_ALLOC Dummy or set B_F2003=.FALSE. in mod param'
      stop 'Comment-out MOVE_ALLOC Dummy or set B_F2003=.FALSE.'
!
      end subroutine move_alloc
!
!                             *******************
!
      MODULE ADF00
!
!-----------------------------------------------------------------------
!
! MODULE TO HOLD ADAS ADF00 GROUND CONFIGURATIONS OF THE ELEMENTS (ALL
! IONIZATION STAGES) SEE THE ORIGINAL ADF00 FILES WITHIN ADAS FOR DATA
! COMPILER AND SOURCES.
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,WP
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      LOGICAL(BP) BADF00
!
      INTEGER(SP) J,K,MSC00,MXCONFH
!
      REAL(WP) EXCITE
!
! STANDARD ORDER STORAGE
!
      INTEGER(QP) QCFG0
      INTEGER(SP) JZ0,KLEN0,JKLEN0
!
      PARAMETER (JZ0=92)                        !MAX NUCLEAR CHARGE (U)
      PARAMETER (KLEN0=14)                      !MAX NO. OF ORBITALS(5f)
!      PARAMETER (JKLEN0=(KLEN0+1)*(JZ0+1))
!
      DIMENSION QCFG0(0:KLEN0,0:JZ0)
!
! ELEMENT SPECIFIC STORAGE
!
      INTEGER(QP) QCFGX
      INTEGER(SP) JHX,JZX,KLENX,JKLENX
!
      PARAMETER (JZX=103)                       !MAX NUCLEAR CHARGE (Lr)
      PARAMETER (JHX=25)                        !MAX NO. NON-S.O. STAGES
      PARAMETER (KLENX=23)                      !MAX NO. OF ORBITALS(7p)
!      PARAMETER (JKLENX=(KLENX+1)*(JHX+1)*JZX)
!
      DIMENSION QCFGX(0:KLENX,0:JHX,JZX)
!
!-----------------------------------------------------------------------
!
      DATA BADF00/.FALSE./,MSC00/80/
!
! INITIALIZE ALL TO S.O. (if not, take care not to access undefined)
!
!      DATA QCFG0/JKLEN0*0/                  !non-standard esp. gfortran
!      DATA QCFGX/JKLENX*0/                  !non-standard esp. gfortran
!
!
! BELOW:                                                                &
!  NZ& IS THE NUCLEAR CHARGE OF ELEMENT SYMBOL X                        &
!  NH& IS THE NUMBER OF STAGES OF ELEMENT X WITH NON-S.O. CONFIGS HELD  &
!  NL& IS THE NUMBER OF ORBITALS TO BE READ OF ELEMENT X
!             (CURRENTLY THE SAME FOR ALL STAGES OF A GIVEN ELEMENT X)
!
!
! STANDARD ORDER (X=0)
!
      INTEGER(SP),PARAMETER :: NH0=92,NL0=14
      DATA QCFG0(0,0)/NH0/
      DATA QCFG0(0,1:NH0)/NH0*NL0/
      DATA ((QCFG0(K,J),K=1,NL0),J=1,NH0)                               &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,14                                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,13                                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,12                                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,11                                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,10                                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,9                                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,8                                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,7                                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6                                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5                                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4                                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3                                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,2                                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1                                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0                                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,9,0                                   &
     &,2,2,6,2,6,10,2,6,10,14,2,6,8,0                                   &
     &,2,2,6,2,6,10,2,6,10,14,2,6,7,0                                   &
     &,2,2,6,2,6,10,2,6,10,14,2,6,6,0                                   &
     &,2,2,6,2,6,10,2,6,10,14,2,6,5,0                                   &
     &,2,2,6,2,6,10,2,6,10,14,2,6,4,0                                   &
     &,2,2,6,2,6,10,2,6,10,14,2,6,3,0                                   &
     &,2,2,6,2,6,10,2,6,10,14,2,6,2,0                                   &
     &,2,2,6,2,6,10,2,6,10,14,2,6,1,0                                   &
     &,2,2,6,2,6,10,2,6,10,14,2,6,0,0                                   &
     &,2,2,6,2,6,10,2,6,10,14,2,5,0,0                                   &
     &,2,2,6,2,6,10,2,6,10,14,2,4,0,0                                   &
     &,2,2,6,2,6,10,2,6,10,14,2,3,0,0                                   &
     &,2,2,6,2,6,10,2,6,10,14,2,2,0,0                                   &
     &,2,2,6,2,6,10,2,6,10,14,2,1,0,0                                   &
     &,2,2,6,2,6,10,2,6,10,14,2,0,0,0                                   &
     &,2,2,6,2,6,10,2,6,10,14,1,0,0,0                                   &
     &,2,2,6,2,6,10,2,6,10,14,0,0,0,0                                   &
     &,2,2,6,2,6,10,2,6,10,13,0,0,0,0                                   &
     &,2,2,6,2,6,10,2,6,10,12,0,0,0,0                                   &
     &,2,2,6,2,6,10,2,6,10,11,0,0,0,0                                   &
     &,2,2,6,2,6,10,2,6,10,10,0,0,0,0                                   &
     &,2,2,6,2,6,10,2,6,10,9,0,0,0,0                                    &
     &,2,2,6,2,6,10,2,6,10,8,0,0,0,0                                    &
     &,2,2,6,2,6,10,2,6,10,7,0,0,0,0                                    &
     &,2,2,6,2,6,10,2,6,10,6,0,0,0,0                                    &
     &,2,2,6,2,6,10,2,6,10,5,0,0,0,0                                    &
     &,2,2,6,2,6,10,2,6,10,4,0,0,0,0                                    &
     &,2,2,6,2,6,10,2,6,10,3,0,0,0,0                                    &
     &,2,2,6,2,6,10,2,6,10,2,0,0,0,0                                    &
     &,2,2,6,2,6,10,2,6,10,1,0,0,0,0                                    &
     &,2,2,6,2,6,10,2,6,10,0,0,0,0,0                                    &
     &,2,2,6,2,6,10,2,6,9,0,0,0,0,0                                     &
     &,2,2,6,2,6,10,2,6,8,0,0,0,0,0                                     &
     &,2,2,6,2,6,10,2,6,7,0,0,0,0,0                                     &
     &,2,2,6,2,6,10,2,6,6,0,0,0,0,0                                     &
     &,2,2,6,2,6,10,2,6,5,0,0,0,0,0                                     &
     &,2,2,6,2,6,10,2,6,4,0,0,0,0,0                                     &
     &,2,2,6,2,6,10,2,6,3,0,0,0,0,0                                     &
     &,2,2,6,2,6,10,2,6,2,0,0,0,0,0                                     &
     &,2,2,6,2,6,10,2,6,1,0,0,0,0,0                                     &
     &,2,2,6,2,6,10,2,6,0,0,0,0,0,0                                     &
     &,2,2,6,2,6,10,2,5,0,0,0,0,0,0                                     &
     &,2,2,6,2,6,10,2,4,0,0,0,0,0,0                                     &
     &,2,2,6,2,6,10,2,3,0,0,0,0,0,0                                     &
     &,2,2,6,2,6,10,2,2,0,0,0,0,0,0                                     &
     &,2,2,6,2,6,10,2,1,0,0,0,0,0,0                                     &
     &,2,2,6,2,6,10,2,0,0,0,0,0,0,0                                     &
     &,2,2,6,2,6,10,1,0,0,0,0,0,0,0                                     &
     &,2,2,6,2,6,10,0,0,0,0,0,0,0,0                                     &
     &,2,2,6,2,6,9,0,0,0,0,0,0,0,0                                      &
     &,2,2,6,2,6,8,0,0,0,0,0,0,0,0                                      &
     &,2,2,6,2,6,7,0,0,0,0,0,0,0,0                                      &
     &,2,2,6,2,6,6,0,0,0,0,0,0,0,0                                      &
     &,2,2,6,2,6,5,0,0,0,0,0,0,0,0                                      &
     &,2,2,6,2,6,4,0,0,0,0,0,0,0,0                                      &
     &,2,2,6,2,6,3,0,0,0,0,0,0,0,0                                      &
     &,2,2,6,2,6,2,0,0,0,0,0,0,0,0                                      &
     &,2,2,6,2,6,1,0,0,0,0,0,0,0,0                                      &
     &,2,2,6,2,6,0,0,0,0,0,0,0,0,0                                      &
     &,2,2,6,2,5,0,0,0,0,0,0,0,0,0                                      &
     &,2,2,6,2,4,0,0,0,0,0,0,0,0,0                                      &
     &,2,2,6,2,3,0,0,0,0,0,0,0,0,0                                      &
     &,2,2,6,2,2,0,0,0,0,0,0,0,0,0                                      &
     &,2,2,6,2,1,0,0,0,0,0,0,0,0,0                                      &
     &,2,2,6,2,0,0,0,0,0,0,0,0,0,0                                      &
     &,2,2,6,1,0,0,0,0,0,0,0,0,0,0                                      &
     &,2,2,6,0,0,0,0,0,0,0,0,0,0,0                                      &
     &,2,2,5,0,0,0,0,0,0,0,0,0,0,0                                      &
     &,2,2,4,0,0,0,0,0,0,0,0,0,0,0                                      &
     &,2,2,3,0,0,0,0,0,0,0,0,0,0,0                                      &
     &,2,2,2,0,0,0,0,0,0,0,0,0,0,0                                      &
     &,2,2,1,0,0,0,0,0,0,0,0,0,0,0                                      &
     &,2,2,0,0,0,0,0,0,0,0,0,0,0,0                                      &
     &,2,1,0,0,0,0,0,0,0,0,0,0,0,0                                      &
     &,2,0,0,0,0,0,0,0,0,0,0,0,0,0                                      &
     &,1,0,0,0,0,0,0,0,0,0,0,0,0,0                                      &
     &/
!
!
! ELEMENT SPECIFIC
!
! HYDROGEN (Z=1) THRU ARGON (Z=18) ALL STAGES ARE S.O.
!
      INTEGER(SP),PARAMETER :: JKLEN18=18
      DATA QCFGX(0,0,1:18)/JKLEN18*0/
!
!
! CARBON - TEST CASE
!      INTEGER(SP),PARAMETER :: NZC=6,NHC=6,NLC=3
!      DATA QCFGX(0,0,NZC)/NHC/
!      DATA QCFGX(0,1:NHC,NZC)/NHC*NLC/
!      DATA ((QCFGX(K,J,NZC),K=1,NLC),J=1,NHC)
!     &/2,2,2
!     &,2,2,1
!     &,2,2,0
!     &,2,1,0
!     &,2,0,0
!     &,1,0,0
!     &/
!
! POTASSIUM
      INTEGER(SP),PARAMETER :: NZK=19,NHK=1,NLK=7
      DATA QCFGX(0,0,NZK)/NHK/
      DATA QCFGX(0,1:NHK,NZK)/NHK*NLK/
      DATA ((QCFGX(K,J,NZK),K=1,NLK),J=1,NHK)                           &
     &/2,2,6,2,6,0,1                                                    &
     &/
!
! CALCIUM
      INTEGER(SP),PARAMETER :: NZCA=20,NHCA=2,NLCA=7
      DATA QCFGX(0,0,NZCA)/NHCA/
      DATA QCFGX(0,1:NHCA,NZCA)/NHCA*NLCA/
      DATA ((QCFGX(K,J,NZCA),K=1,NLCA),J=1,NHCA)                        &
     &/2,2,6,2,6,0,2                                                    &
     &,2,2,6,2,6,0,1                                                    &
     &/
!
! SCANDIUM
      INTEGER(SP),PARAMETER :: NZSC=21,NHSC=2,NLSC=7
      DATA QCFGX(0,0,NZSC)/NHSC/
      DATA QCFGX(0,1:NHSC,NZSC)/NHSC*NLSC/
      DATA ((QCFGX(K,J,NZSC),K=1,NLSC),J=1,NHSC)                        &
     &/2,2,6,2,6,1,2                                                    &
     &,2,2,6,2,6,1,1                                                    &
     &/
!
! TITANIUM
      INTEGER(SP),PARAMETER :: NZTI=22,NHTI=2,NLTI=7
      DATA QCFGX(0,0,NZTI)/NHTI/
      DATA QCFGX(0,1:NHTI,NZTI)/NHTI*NLTI/
      DATA ((QCFGX(K,J,NZTI),K=1,NLTI),J=1,NHTI)                        &
     &/2,2,6,2,6,2,2                                                    &
     &,2,2,6,2,6,2,1                                                    &
     &/
!
! VANADIUM
      INTEGER(SP),PARAMETER :: NZV=23,NHV=1,NLV=7
      DATA QCFGX(0,0,NZV)/NHV/
      DATA QCFGX(0,1:NHV,NZV)/NHV*NLV/
      DATA ((QCFGX(K,J,NZV),K=1,NLV),J=1,NHV)                           &
     &/2,2,6,2,6,3,2                                                    &
     &/
!
! CHROMIUM
      INTEGER(SP),PARAMETER :: NZCR=24,NHCR=1,NLCR=7
      DATA QCFGX(0,0,NZCR)/NHCR/
      DATA QCFGX(0,1:NHCR,NZCR)/NHCR*NLCR/
      DATA ((QCFGX(K,J,NZCR),K=1,NLCR),J=1,NHCR)                        &
     &/2,2,6,2,6,5,1                                                    &
     &/
!
! MANGANESE
      INTEGER(SP),PARAMETER :: NZMN=25,NHMN=2,NLMN=7
      DATA QCFGX(0,0,NZMN)/NHMN/
      DATA QCFGX(0,1:NHMN,NZMN)/NHMN*NLMN/
      DATA ((QCFGX(K,J,NZMN),K=1,NLMN),J=1,NHMN)                        &
     &/2,2,6,2,6,5,2                                                    &
     &,2,2,6,2,6,5,1                                                    &
     &/
!
! IRON
      INTEGER(SP),PARAMETER :: NZFE=26,NHFE=2,NLFE=7
      DATA QCFGX(0,0,NZFE)/NHFE/
      DATA QCFGX(0,1:NHFE,NZFE)/NHFE*NLFE/
      DATA ((QCFGX(K,J,NZFE),K=1,NLFE),J=1,NHFE)                        &
     &/2,2,6,2,6,6,2                                                    &
     &,2,2,6,2,6,6,1                                                    &
     &/
!
! COBOLT
      INTEGER(SP),PARAMETER :: NZCO=27,NHCO=1,NLCO=7
      DATA QCFGX(0,0,NZCO)/NHCO/
      DATA QCFGX(0,1:NHCO,NZCO)/NHCO*NLCO/
      DATA ((QCFGX(K,J,NZCO),K=1,NLCO),J=1,NHCO)                        &
     &/2,2,6,2,6,7,2                                                    &
     &/
!
! NICKEL
      INTEGER(SP),PARAMETER :: NZNI=28,NHNI=1,NLNI=7
      DATA QCFGX(0,0,NZNI)/NHNI/
      DATA QCFGX(0,1:NHNI,NZNI)/NHNI*NLNI/
      DATA ((QCFGX(K,J,NZNI),K=1,NLNI),J=1,NHNI)                        &
     &/2,2,6,2,6,8,2                                                    &
     &/
!
!
! COPPER (Z=29) THRU KRYPTON (Z=36) ALL STAGES ARE S.O.
!
      INTEGER(SP),PARAMETER :: JKLEN36=8
      DATA QCFGX(0,0,29:36)/JKLEN36*0/
!
!
! RUBIDIUM
      INTEGER(SP),PARAMETER :: NZRB=37,NHRB=1,NLRB=11
      DATA QCFGX(0,0,NZRB)/NHRB/
      DATA QCFGX(0,1:NHRB,NZRB)/NHRB*NLRB/
      DATA ((QCFGX(K,J,NZRB),K=1,NLRB),J=1,NHRB)                        &
     &/2,2,6,2,6,10,2,6,0,0,1                                           &
     &/
!
! STRONTIUM
      INTEGER(SP),PARAMETER :: NZSR=38,NHSR=2,NLSR=11
      DATA QCFGX(0,0,NZSR)/NHSR/
      DATA QCFGX(0,1:NHSR,NZSR)/NHSR*NLSR/
      DATA ((QCFGX(K,J,NZSR),K=1,NLSR),J=1,NHSR)                        &
     &/2,2,6,2,6,10,2,6,0,0,2                                           &
     &,2,2,6,2,6,10,2,6,0,0,1                                           &
     &/
!
! YTTRIUM
      INTEGER(SP),PARAMETER :: NZY=39,NHY=2,NLY=11
      DATA QCFGX(0,0,NZY)/NHY/
      DATA QCFGX(0,1:NHY,NZY)/NHY*NLY/
      DATA ((QCFGX(K,J,NZY),K=1,NLY),J=1,NHY)                           &
     &/2,2,6,2,6,10,2,6,1,0,2                                           &
     &,2,2,6,2,6,10,2,6,0,0,2                                           &
     &/
!     &,2,2,6,2,6,10,2,6,0,0,1
!
! ZIRCONIUM
      INTEGER(SP),PARAMETER :: NZZR=40,NHZR=2,NLZR=11
      DATA QCFGX(0,0,NZZR)/NHZR/
      DATA QCFGX(0,1:NHZR,NZZR)/NHZR*NLZR/
      DATA ((QCFGX(K,J,NZZR),K=1,NLZR),J=1,NHZR)                        &
     &/2,2,6,2,6,10,2,6,2,0,2                                           &
     &,2,2,6,2,6,10,2,6,2,0,1                                           &
     &/
!
! NIOBIUM
      INTEGER(SP),PARAMETER :: NZNB=41,NHNB=1,NLNB=11
      DATA QCFGX(0,0,NZNB)/NHNB/
      DATA QCFGX(0,1:NHNB,NZNB)/NHNB*NLNB/
      DATA ((QCFGX(K,J,NZNB),K=1,NLNB),J=1,NHNB)                        &
     &/2,2,6,2,6,10,2,6,4,0,1                                           &
     &/
!
! MOLYBDENUM
      INTEGER(SP),PARAMETER :: NZMO=42,NHMO=1,NLMO=11
      DATA QCFGX(0,0,NZMO)/NHMO/
      DATA QCFGX(0,1:NHMO,NZMO)/NHMO*NLMO/
      DATA ((QCFGX(K,J,NZMO),K=1,NLMO),J=1,NHMO)                        &
     &/2,2,6,2,6,10,2,6,5,0,1                                           &
     &/
!
! TECHNETIUM
      INTEGER(SP),PARAMETER :: NZTC=43,NHTC=2,NLTC=11
      DATA QCFGX(0,0,NZTC)/NHTC/
      DATA QCFGX(0,1:NHTC,NZTC)/NHTC*NLTC/
      DATA ((QCFGX(K,J,NZTC),K=1,NLTC),J=1,NHTC)                        &
     &/2,2,6,2,6,10,2,6,5,0,2                                           &
     &,2,2,6,2,6,10,2,6,5,0,1                                           &
     &/
!
! RUTHENIUM
      INTEGER(SP),PARAMETER :: NZRU=44,NHRU=1,NLRU=11
      DATA QCFGX(0,0,NZRU)/NHRU/
      DATA QCFGX(0,1:NHRU,NZRU)/NHRU*NLRU/
      DATA ((QCFGX(K,J,NZRU),K=1,NLRU),J=1,NHRU)                        &
     &/2,2,6,2,6,10,2,6,7,0,1                                           &
     &/
!
! RHODIUM
      INTEGER(SP),PARAMETER :: NZRH=45,NHRH=1,NLRH=11
      DATA QCFGX(0,0,NZRH)/NHRH/
      DATA QCFGX(0,1:NHRH,NZRH)/NHRH*NLRH/
      DATA ((QCFGX(K,J,NZRH),K=1,NLRH),J=1,NHRH)                        &
     &/2,2,6,2,6,10,2,6,8,0,1                                           &
     &/
!
! PALLADIUM (S.O.)
      INTEGER(SP),PARAMETER :: NZPD=46,NHPD=1,NLPD=11
      DATA QCFGX(0,0,NZPD)/NHPD/
      DATA QCFGX(0,1:NHPD,NZPD)/NHPD*NLPD/
      DATA ((QCFGX(K,J,NZPD),K=1,NLPD),J=1,NHPD)                        &
     &/2,2,6,2,6,10,2,6,10,0,0                                          &
     &/
!
! SILVER
      INTEGER(SP),PARAMETER :: NZAG=47,NHAG=1,NLAG=11
      DATA QCFGX(0,0,NZAG)/NHAG/
      DATA QCFGX(0,1:NHAG,NZAG)/NHAG*NLAG/
      DATA ((QCFGX(K,J,NZAG),K=1,NLAG),J=1,NHAG)                        &
     &/2,2,6,2,6,10,2,6,10,0,1                                          &
     &/
!     &/2,2,6,2,6,10,2,6,9,0,2
!
! CADMIUM
      INTEGER(SP),PARAMETER :: NZCD=48,NHCD=2,NLCD=11
      DATA QCFGX(0,0,NZCD)/NHCD/
      DATA QCFGX(0,1:NHCD,NZCD)/NHCD*NLCD/
      DATA ((QCFGX(K,J,NZCD),K=1,NLCD),J=1,NHCD)                        &
     &/2,2,6,2,6,10,2,6,10,0,2                                          &
     &,2,2,6,2,6,10,2,6,10,0,1                                          &
     &/
!
! INDIUM
      INTEGER(SP),PARAMETER :: NZIN=49,NHIN=3,NLIN=12
      DATA QCFGX(0,0,NZIN)/NHIN/
      DATA QCFGX(0,1:NHIN,NZIN)/NHIN*NLIN/
      DATA ((QCFGX(K,J,NZIN),K=1,NLIN),J=1,NHIN)                        &
     &/2,2,6,2,6,10,2,6,10,0,2,1                                        &
     &,2,2,6,2,6,10,2,6,10,0,2,0                                        &
     &,2,2,6,2,6,10,2,6,10,0,1,0                                        &
     &/
!
! TIN
      INTEGER(SP),PARAMETER :: NZSN=50,NHSN=4,NLSN=12
      DATA QCFGX(0,0,NZSN)/NHSN/
      DATA QCFGX(0,1:NHSN,NZSN)/NHSN*NLSN/
      DATA ((QCFGX(K,J,NZSN),K=1,NLSN),J=1,NHSN)                        &
     &/2,2,6,2,6,10,2,6,10,0,2,2                                        &
     &,2,2,6,2,6,10,2,6,10,0,2,1                                        &
     &,2,2,6,2,6,10,2,6,10,0,2,0                                        &
     &,2,2,6,2,6,10,2,6,10,0,1,0                                        &
     &/
!
! ANTIMONY
      INTEGER(SP),PARAMETER :: NZSB=51,NHSB=5,NLSB=12
      DATA QCFGX(0,0,NZSB)/NHSB/
      DATA QCFGX(0,1:NHSB,NZSB)/NHSB*NLSB/
      DATA ((QCFGX(K,J,NZSB),K=1,NLSB),J=1,NHSB)                        &
     &/2,2,6,2,6,10,2,6,10,0,2,3                                        &
     &,2,2,6,2,6,10,2,6,10,0,2,2                                        &
     &,2,2,6,2,6,10,2,6,10,0,2,1                                        &
     &,2,2,6,2,6,10,2,6,10,0,2,0                                        &
     &,2,2,6,2,6,10,2,6,10,0,1,0                                        &
     &/
!
! TELLURIUM
      INTEGER(SP),PARAMETER :: NZTE=52,NHTE=6,NLTE=12
      DATA QCFGX(0,0,NZTE)/NHTE/
      DATA QCFGX(0,1:NHTE,NZTE)/NHTE*NLTE/
      DATA ((QCFGX(K,J,NZTE),K=1,NLTE),J=1,NHTE)                        &
     &/2,2,6,2,6,10,2,6,10,0,2,4                                        &
     &,2,2,6,2,6,10,2,6,10,0,2,3                                        &
     &,2,2,6,2,6,10,2,6,10,0,2,2                                        &
     &,2,2,6,2,6,10,2,6,10,0,2,1                                        &
     &,2,2,6,2,6,10,2,6,10,0,2,0                                        &
     &,2,2,6,2,6,10,2,6,10,0,1,0                                        &
     &/
!
! IODINE
      INTEGER(SP),PARAMETER :: NZI=53,NHI=7,NLI=12
      DATA QCFGX(0,0,NZI)/NHI/
      DATA QCFGX(0,1:NHI,NZI)/NHI*NLI/
      DATA ((QCFGX(K,J,NZI),K=1,NLI),J=1,NHI)                           &
     &/2,2,6,2,6,10,2,6,10,0,2,5                                        &
     &,2,2,6,2,6,10,2,6,10,0,2,4                                        &
     &,2,2,6,2,6,10,2,6,10,0,2,3                                        &
     &,2,2,6,2,6,10,2,6,10,0,2,2                                        &
     &,2,2,6,2,6,10,2,6,10,0,2,1                                        &
     &,2,2,6,2,6,10,2,6,10,0,2,0                                        &
     &,2,2,6,2,6,10,2,6,10,0,1,0                                        &
     &/
!
! XENON
      INTEGER(SP),PARAMETER :: NZXE=54,NHXE=8,NLXE=12
      DATA QCFGX(0,0,NZXE)/NHXE/
      DATA QCFGX(0,1:NHXE,NZXE)/NHXE*NLXE/
      DATA ((QCFGX(K,J,NZXE),K=1,NLXE),J=1,NHXE)                        &
     &/2,2,6,2,6,10,2,6,10,0,2,6                                        &
     &,2,2,6,2,6,10,2,6,10,0,2,5                                        &
     &,2,2,6,2,6,10,2,6,10,0,2,4                                        &
     &,2,2,6,2,6,10,2,6,10,0,2,3                                        &
     &,2,2,6,2,6,10,2,6,10,0,2,2                                        &
     &,2,2,6,2,6,10,2,6,10,0,2,1                                        &
     &,2,2,6,2,6,10,2,6,10,0,2,0                                        &
     &,2,2,6,2,6,10,2,6,10,0,1,0                                        &
     &/
!
! CESIUM
      INTEGER(SP),PARAMETER :: NZCS=55,NHCS=9,NLCS=16
      DATA QCFGX(0,0,NZCS)/NHCS/
      DATA QCFGX(0,1:NHCS,NZCS)/NHCS*NLCS/
      DATA ((QCFGX(K,J,NZCS),K=1,NLCS),J=1,NHCS)                        &
     &/2,2,6,2,6,10,2,6,10,0,2,6,0,0,0,1                                &
     &,2,2,6,2,6,10,2,6,10,0,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,5,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,4,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,3,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,2,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,1,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,1,0,0,0,0,0                                &
     &/
!
! BARIUM
      INTEGER(SP),PARAMETER :: NZBA=56,NHBA=10,NLBA=16
      DATA QCFGX(0,0,NZBA)/NHBA/
      DATA QCFGX(0,1:NHBA,NZBA)/NHBA*NLBA/
      DATA ((QCFGX(K,J,NZBA),K=1,NLBA),J=1,NHBA)                        &
     &/2,2,6,2,6,10,2,6,10,0,2,6,0,0,0,2                                &
     &,2,2,6,2,6,10,2,6,10,0,2,6,0,0,0,1                                &
     &,2,2,6,2,6,10,2,6,10,0,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,5,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,4,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,3,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,2,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,1,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,1,0,0,0,0,0                                &
     &/
!
! LANTHANUM
      INTEGER(SP),PARAMETER :: NZLA=57,NHLA=11,NLLA=16
      DATA QCFGX(0,0,NZLA)/NHLA/
      DATA QCFGX(0,1:NHLA,NZLA)/NHLA*NLLA/
      DATA ((QCFGX(K,J,NZLA),K=1,NLLA),J=1,NHLA)                        &
     &/2,2,6,2,6,10,2,6,10,0,2,6,1,0,0,2                                &
     &,2,2,6,2,6,10,2,6,10,0,2,6,2,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,6,1,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,5,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,4,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,3,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,2,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,1,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,1,0,0,0,0,0                                &
     &/
!
! CERIUM
      INTEGER(SP),PARAMETER :: NZCE=58,NHCE=12,NLCE=16
      DATA QCFGX(0,0,NZCE)/NHCE/
      DATA QCFGX(0,1:NHCE,NZCE)/NHCE*NLCE/
      DATA ((QCFGX(K,J,NZCE),K=1,NLCE),J=1,NHCE)                        &
     &/2,2,6,2,6,10,2,6,10,1,2,6,1,0,0,2                                &
     &,2,2,6,2,6,10,2,6,10,1,2,6,2,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,2,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,1,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,5,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,4,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,3,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,2,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,1,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,1,0,0,0,0,0                                &
     &/
!
! PRASEODYMIUM
      INTEGER(SP),PARAMETER :: NZPR=59,NHPR=13,NLPR=16
      DATA QCFGX(0,0,NZPR)/NHPR/
      DATA QCFGX(0,1:NHPR,NZPR)/NHPR*NLPR/
      DATA ((QCFGX(K,J,NZPR),K=1,NLPR),J=1,NHPR)                        &
     &/2,2,6,2,6,10,2,6,10,3,2,6,0,0,0,2                                &
     &,2,2,6,2,6,10,2,6,10,3,2,6,0,0,0,1                                &
     &,2,2,6,2,6,10,2,6,10,3,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,2,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,1,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,1,2,4,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,1,2,3,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,1,2,2,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,2,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,1,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,1,0,0,0,0,0                                &
     &/
!
! NEODYMIUM
      INTEGER(SP),PARAMETER :: NZND=60,NHND=14,NLND=16
      DATA QCFGX(0,0,NZND)/NHND/
      DATA QCFGX(0,1:NHND,NZND)/NHND*NLND/
      DATA ((QCFGX(K,J,NZND),K=1,NLND),J=1,NHND)                        &
     &/2,2,6,2,6,10,2,6,10,4,2,6,0,0,0,2                                &
     &,2,2,6,2,6,10,2,6,10,4,2,6,0,0,0,1                                &
     &,2,2,6,2,6,10,2,6,10,4,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,3,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,2,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,2,2,5,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,2,2,4,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,2,2,3,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,2,2,2,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,2,2,1,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,2,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,1,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,1,0,0,0,0,0                                &
     &/
!
! PROMETHIUM
      INTEGER(SP),PARAMETER :: NZPM=61,NHPM=15,NLPM=16
      DATA QCFGX(0,0,NZPM)/NHPM/
      DATA QCFGX(0,1:NHPM,NZPM)/NHPM*NLPM/
      DATA ((QCFGX(K,J,NZPM),K=1,NLPM),J=1,NHPM)                        &
     &/2,2,6,2,6,10,2,6,10,5,2,6,0,0,0,2                                &
     &,2,2,6,2,6,10,2,6,10,5,2,6,0,0,0,1                                &
     &,2,2,6,2,6,10,2,6,10,5,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,4,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,3,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,3,2,5,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,3,2,4,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,3,2,3,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,3,2,2,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,3,2,1,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,3,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,2,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,1,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,0,1,0,0,0,0,0                                &
     &/
!
! SAMARIUM
      INTEGER(SP),PARAMETER :: NZSM=62,NHSM=15,NLSM=16
      DATA QCFGX(0,0,NZSM)/NHSM/
      DATA QCFGX(0,1:NHSM,NZSM)/NHSM*NLSM/
      DATA ((QCFGX(K,J,NZSM),K=1,NLSM),J=1,NHSM)                        &
     &/2,2,6,2,6,10,2,6,10,6,2,6,0,0,0,2                                &
     &,2,2,6,2,6,10,2,6,10,6,2,6,0,0,0,1                                &
     &,2,2,6,2,6,10,2,6,10,6,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,5,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,4,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,3,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,4,2,4,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,4,2,3,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,4,2,2,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,4,2,1,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,4,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,3,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,2,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,1,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,1,1,0,0,0,0,0                                &
     &/
!
! EUROPIUM
      INTEGER(SP),PARAMETER :: NZEU=63,NHEU=15,NLEU=16
      DATA QCFGX(0,0,NZEU)/NHEU/
      DATA QCFGX(0,1:NHEU,NZEU)/NHEU*NLEU/
      DATA ((QCFGX(K,J,NZEU),K=1,NLEU),J=1,NHEU)                        &
     &/2,2,6,2,6,10,2,6,10,7,2,6,0,0,0,2                                &
     &,2,2,6,2,6,10,2,6,10,7,2,6,0,0,0,1                                &
     &,2,2,6,2,6,10,2,6,10,7,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,6,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,5,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,5,2,5,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,5,2,4,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,5,2,3,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,5,2,2,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,5,2,1,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,5,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,4,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,3,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,2,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,2,1,0,0,0,0,0                                &
     &/
!
! GADOLINIUM
      INTEGER(SP),PARAMETER :: NZGD=64,NHGD=15,NLGD=16
      DATA QCFGX(0,0,NZGD)/NHGD/
      DATA QCFGX(0,1:NHGD,NZGD)/NHGD*NLGD/
      DATA ((QCFGX(K,J,NZGD),K=1,NLGD),J=1,NHGD)                        &
     &/2,2,6,2,6,10,2,6,10,7,2,6,1,0,0,2                                &
     &,2,2,6,2,6,10,2,6,10,7,2,6,1,0,0,1                                &
     &,2,2,6,2,6,10,2,6,10,7,2,6,1,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,7,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,6,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,6,2,5,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,6,2,4,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,6,2,3,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,6,2,2,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,5,2,2,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,5,2,1,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,5,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,4,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,5,0,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,2,2,0,0,0,0,0                                &
     &/
!
! TERBIUM
      INTEGER(SP),PARAMETER :: NZTB=65,NHTB=14,NLTB=16
      DATA QCFGX(0,0,NZTB)/NHTB/
      DATA QCFGX(0,1:NHTB,NZTB)/NHTB*NLTB/
      DATA ((QCFGX(K,J,NZTB),K=1,NLTB),J=1,NHTB)                        &
     &/2,2,6,2,6,10,2,6,10,9,2,6,0,0,0,2                                &
     &,2,2,6,2,6,10,2,6,10,9,2,6,0,0,0,1                                &
     &,2,2,6,2,6,10,2,6,10,9,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,8,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,7,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,7,2,5,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,8,2,3,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,7,2,3,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,7,2,2,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,6,2,2,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,6,2,1,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,6,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,5,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,4,2,0,0,0,0,0                                &
     &/
!
! DYSPROSIUM
      INTEGER(SP),PARAMETER :: NZDY=66,NHDY=15,NLDY=16
      DATA QCFGX(0,0,NZDY)/NHDY/
      DATA QCFGX(0,1:NHDY,NZDY)/NHDY*NLDY/
      DATA ((QCFGX(K,J,NZDY),K=1,NLDY),J=1,NHDY)                        &
     &/2,2,6,2,6,10,2,6,10,10,2,6,0,0,0,2                               &
     &,2,2,6,2,6,10,2,6,10,10,2,6,0,0,0,1                               &
     &,2,2,6,2,6,10,2,6,10,10,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,9,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,8,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,8,2,5,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,8,2,4,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,9,2,2,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,8,2,2,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,8,2,1,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,8,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,7,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,6,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,6,1,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,4,2,0,0,0,0,0                                &
     &/
!
! HOLMIUM
      INTEGER(SP),PARAMETER :: NZHO=67,NHHO=16,NLHO=16
      DATA QCFGX(0,0,NZHO)/NHHO/
      DATA QCFGX(0,1:NHHO,NZHO)/NHHO*NLHO/
      DATA ((QCFGX(K,J,NZHO),K=1,NLHO),J=1,NHHO)                        &
     &/2,2,6,2,6,10,2,6,10,11,2,6,0,0,0,2                               &
     &,2,2,6,2,6,10,2,6,10,11,2,6,0,0,0,1                               &
     &,2,2,6,2,6,10,2,6,10,11,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,10,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,9,2,6,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,9,2,5,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,9,2,4,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,9,2,3,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,10,2,1,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,9,2,1,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,9,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,8,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,7,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,6,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,6,1,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,4,2,0,0,0,0,0                                &
     &/
!
! ERBIUM
      INTEGER(SP),PARAMETER :: NZER=68,NHER=15,NLER=16
      DATA QCFGX(0,0,NZER)/NHER/
      DATA QCFGX(0,1:NHER,NZER)/NHER*NLER/
      DATA ((QCFGX(K,J,NZER),K=1,NLER),J=1,NHER)                        &
     &/2,2,6,2,6,10,2,6,10,12,2,6,0,0,0,2                               &
     &,2,2,6,2,6,10,2,6,10,12,2,6,0,0,0,1                               &
     &,2,2,6,2,6,10,2,6,10,12,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,11,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,10,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,10,2,5,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,10,2,4,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,10,2,3,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,10,2,2,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,10,2,1,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,10,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,9,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,8,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,7,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,7,1,0,0,0,0,0                                &
     &/
!
! THULIUM
      INTEGER(SP),PARAMETER :: NZTM=69,NHTM=14,NLTM=16
      DATA QCFGX(0,0,NZTM)/NHTM/
      DATA QCFGX(0,1:NHTM,NZTM)/NHTM*NLTM/
      DATA ((QCFGX(K,J,NZTM),K=1,NLTM),J=1,NHTM)                        &
     &/2,2,6,2,6,10,2,6,10,13,2,6,0,0,0,2                               &
     &,2,2,6,2,6,10,2,6,10,13,2,6,0,0,0,1                               &
     &,2,2,6,2,6,10,2,6,10,13,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,11,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,11,2,5,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,11,2,4,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,11,2,3,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,11,2,2,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,11,2,1,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,11,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,10,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,9,2,0,0,0,0,0                                &
     &,2,2,6,2,6,10,2,6,10,9,1,0,0,0,0,0                                &
     &/
!
! YTTERBIUM
      INTEGER(SP),PARAMETER :: NZYB=70,NHYB=14,NLYB=16
      DATA QCFGX(0,0,NZYB)/NHYB/
      DATA QCFGX(0,1:NHYB,NZYB)/NHYB*NLYB/
      DATA ((QCFGX(K,J,NZYB),K=1,NLYB),J=1,NHYB)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,0,0,0,2                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,0,0,0,1                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,2,5,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,2,4,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,2,3,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,2,2,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,2,1,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,11,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,10,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,10,1,0,0,0,0,0                               &
     &/
!
! LUTETIUM
      INTEGER(SP),PARAMETER :: NZLU=71,NHLU=15,NLLU=16
      DATA QCFGX(0,0,NZLU)/NHLU/
      DATA QCFGX(0,1:NHLU,NZLU)/NHLU*NLLU/
      DATA ((QCFGX(K,J,NZLU),K=1,NLLU),J=1,NHLU)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,1,0,0,2                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,0,0,0,2                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,0,0,0,1                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,4,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,3,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,2,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,2,2,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,2,1,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,11,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,10,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,10,1,0,0,0,0,0                               &
     &/
!
! HAFNIUM
      INTEGER(SP),PARAMETER :: NZHF=72,NHHF=15,NLHF=16
      DATA QCFGX(0,0,NZHF)/NHHF/
      DATA QCFGX(0,1:NHHF,NZHF)/NHHF*NLHF/
      DATA ((QCFGX(K,J,NZHF),K=1,NLHF),J=1,NHHF)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,2,0,0,2                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,1,0,0,2                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,2,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,1,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,5,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,4,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,3,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,2,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,2,2,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,2,1,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,11,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,11,1,0,0,0,0,0                               &
     &/
!     &,2,2,6,2,6,10,2,6,10,14,2,6,2,0,0,1
!
! TANTALUM
      INTEGER(SP),PARAMETER :: NZTA=73,NHTA=16,NLTA=16
      DATA QCFGX(0,0,NZTA)/NHTA/
      DATA QCFGX(0,1:NHTA,NZTA)/NHTA*NLTA/
      DATA ((QCFGX(K,J,NZTA),K=1,NLTA),J=1,NHTA)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,3,0,0,2                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,3,0,0,1                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,3,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,2,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,1,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,5,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,4,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,3,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,2,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,1,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,11,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,11,1,0,0,0,0,0                               &
     &/
!
! TUNGSTEN
      INTEGER(SP),PARAMETER :: NZW=74,NHW=17,NLW=16
      DATA QCFGX(0,0,NZW)/NHW/
      DATA QCFGX(0,1:NHW,NZW)/NHW*NLW/
      DATA ((QCFGX(K,J,NZW),K=1,NLW),J=1,NHW)                           &
     &/2,2,6,2,6,10,2,6,10,14,2,6,4,0,0,2                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,4,0,0,1                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,4,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,3,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,2,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,1,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,4,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,3,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,2,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,2,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,11,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,11,1,0,0,0,0,0                               &
     &/
!
! RHENIUM
      INTEGER(SP),PARAMETER :: NZRE=75,NHRE=17,NLRE=16
      DATA QCFGX(0,0,NZRE)/NHRE/
      DATA QCFGX(0,1:NHRE,NZRE)/NHRE*NLRE/
      DATA ((QCFGX(K,J,NZRE),K=1,NLRE),J=1,NHRE)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,5,0,0,2                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,5,0,0,1                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,5,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,4,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,3,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,2,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,1,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,5,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,4,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,3,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,2,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,2,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,11,2,0,0,0,0,0                               &
     &/
!     &,2,2,6,2,6,10,2,6,10,13,2,3,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,13,2,2,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,13,2,1,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,13,2,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,12,2,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,12,1,0,0,0,0,0
!
! OSMIUM
      INTEGER(SP),PARAMETER :: NZOS=76,NHOS=18,NLOS=16
      DATA QCFGX(0,0,NZOS)/NHOS/
      DATA QCFGX(0,1:NHOS,NZOS)/NHOS*NLOS/
      DATA ((QCFGX(K,J,NZOS),K=1,NLOS),J=1,NHOS)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,6,0,0,2                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,6,0,0,1                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,6,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,5,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,4,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,3,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,2,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,1,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,5,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,4,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,3,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,2,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,2,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,1,0,0,0,0,0                               &
     &/
!     &,2,2,6,2,6,10,2,6,10,13,2,1,0,0,0,0
!
! IRIDIUM
      INTEGER(SP),PARAMETER :: NZIR=77,NHIR=19,NLIR=16
      DATA QCFGX(0,0,NZIR)/NHIR/
      DATA QCFGX(0,1:NHIR,NZIR)/NHIR*NLIR/
      DATA ((QCFGX(K,J,NZIR),K=1,NLIR),J=1,NHIR)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,7,0,0,2                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,7,0,0,1                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,7,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,6,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,5,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,4,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,3,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,2,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,1,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,5,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,4,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,3,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,2,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,1,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,1,0,0,0,0,0                               &
     &/
!
! PLATINUM
      INTEGER(SP),PARAMETER :: NZPT=78,NHPT=20,NLPT=16
      DATA QCFGX(0,0,NZPT)/NHPT/
      DATA QCFGX(0,1:NHPT,NZPT)/NHPT*NLPT/
      DATA ((QCFGX(K,J,NZPT),K=1,NLPT),J=1,NHPT)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,9,0,0,1                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,9,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,8,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,7,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,6,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,5,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,4,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,3,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,2,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,1,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,5,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,4,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,3,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,2,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,1,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,12,1,0,0,0,0,0                               &
     &/
!
! GOLD
      INTEGER(SP),PARAMETER :: NZAU=79,NHAU=1,NLAU=16
      DATA QCFGX(0,0,NZAU)/NHAU/
      DATA QCFGX(0,1:NHAU,NZAU)/NHAU*NLAU/
      DATA ((QCFGX(K,J,NZAU),K=1,NLAU),J=1,NHAU)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1                              &
     &/
!
! MERCURY
      INTEGER(SP),PARAMETER :: NZHG=80,NHHG=21,NLHG=16
      DATA QCFGX(0,0,NZHG)/NHHG/
      DATA QCFGX(0,1:NHHG,NZHG)/NHHG*NLHG/
      DATA ((QCFGX(K,J,NZHG),K=1,NLHG),J=1,NHHG)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2                              &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1                              &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,0                              &
     &,2,2,6,2,6,10,2,6,10,14,2,6,9,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,8,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,7,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,6,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,5,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,4,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,3,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,2,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,1,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,5,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,4,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,3,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,2,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,1,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,14,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,2,0,0,0,0,0                               &
     &,2,2,6,2,6,10,2,6,10,13,1,0,0,0,0,0                               &
     &/
!
! THALLIUM
      INTEGER(SP),PARAMETER :: NZTL=81,NHTL=22,NLTL=17
      DATA QCFGX(0,0,NZTL)/NHTL/
      DATA QCFGX(0,1:NHTL,NZTL)/NHTL*NLTL/
      DATA ((QCFGX(K,J,NZTL),K=1,NLTL),J=1,NHTL)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,1                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,0,0                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,9,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,8,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,7,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,6,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,5,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,4,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,3,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,2,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,1,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,5,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,4,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,3,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,2,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,1,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,0,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,13,2,0,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,13,1,0,0,0,0,0,0                             &
     &/
!
! LEAD
      INTEGER(SP),PARAMETER :: NZPB=82,NHPB=23,NLPB=17
      DATA QCFGX(0,0,NZPB)/NHPB/
      DATA QCFGX(0,1:NHPB,NZPB)/NHPB*NLPB/
      DATA ((QCFGX(K,J,NZPB),K=1,NLPB),J=1,NHPB)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,2                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,1                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,0,0                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,9,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,8,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,7,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,6,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,5,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,4,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,3,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,2,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,1,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,5,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,4,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,3,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,2,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,1,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,0,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,13,2,0,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,13,1,0,0,0,0,0,0                             &
     &/
!
! BISMUTH
      INTEGER(SP),PARAMETER :: NZBI=83,NHBI=24,NLBI=17
      DATA QCFGX(0,0,NZBI)/NHBI/
      DATA QCFGX(0,1:NHBI,NZBI)/NHBI*NLBI/
      DATA ((QCFGX(K,J,NZBI),K=1,NLBI),J=1,NHBI)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,3                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,2                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,1                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,0,0                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,9,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,8,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,7,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,6,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,5,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,4,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,3,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,2,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,1,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,6,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,5,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,4,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,3,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,2,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,1,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,14,2,0,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,13,2,0,0,0,0,0,0                             &
     &,2,2,6,2,6,10,2,6,10,13,1,0,0,0,0,0,0                             &
     &/
!
! POLONIUM
      INTEGER(SP),PARAMETER :: NZPO=84,NHPO=6,NLPO=17
      DATA QCFGX(0,0,NZPO)/NHPO/
      DATA QCFGX(0,1:NHPO,NZPO)/NHPO*NLPO/
      DATA ((QCFGX(K,J,NZPO),K=1,NLPO),J=1,NHPO)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,4                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,3                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,2                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,1                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0                            &
     &/
!
! ASTATINE
      INTEGER(SP),PARAMETER :: NZAT=85,NHAT=7,NLAT=17
      DATA QCFGX(0,0,NZAT)/NHAT/
      DATA QCFGX(0,1:NHAT,NZAT)/NHAT*NLAT/
      DATA ((QCFGX(K,J,NZAT),K=1,NLAT),J=1,NHAT)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,5                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,4                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,3                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,2                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,1                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0                            &
     &/
!
! RADON
      INTEGER(SP),PARAMETER :: NZRN=86,NHRN=8,NLRN=17
      DATA QCFGX(0,0,NZRN)/NHRN/
      DATA QCFGX(0,1:NHRN,NZRN)/NHRN*NLRN/
      DATA ((QCFGX(K,J,NZRN),K=1,NLRN),J=1,NHRN)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,6                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,5                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,4                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,3                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,2                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,1                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0                            &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0                            &
     &/
!
! FRANCIUM
      INTEGER(SP),PARAMETER :: NZFR=87,NHFR=9,NLFR=22
      DATA QCFGX(0,0,NZFR)/NHFR/
      DATA QCFGX(0,1:NHFR,NZFR)/NHFR*NLFR/
      DATA ((QCFGX(K,J,NZFR),K=1,NLFR),J=1,NHFR)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,6,0,0,0,0,1                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,5,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,4,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,3,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,1,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0,0,0,0,0,0                  &
     &/
!
! RADIUM
      INTEGER(SP),PARAMETER :: NZRA=88,NHRA=10,NLRA=22
      DATA QCFGX(0,0,NZRA)/NHRA/
      DATA QCFGX(0,1:NHRA,NZRA)/NHRA*NLRA/
      DATA ((QCFGX(K,J,NZRA),K=1,NLRA),J=1,NHRA)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,6,0,0,0,0,2                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,6,0,0,0,0,1                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,5,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,4,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,3,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,1,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0,0,0,0,0,0                  &
     &/
!
! ACTINIUM
      INTEGER(SP),PARAMETER :: NZAC=89,NHAC=11,NLAC=22
      DATA QCFGX(0,0,NZAC)/NHAC/
      DATA QCFGX(0,1:NHAC,NZAC)/NHAC*NLAC/
      DATA ((QCFGX(K,J,NZAC),K=1,NLAC),J=1,NHAC)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,6,1,0,0,0,2                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,6,0,0,0,0,2                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,6,0,0,0,0,1                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,5,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,4,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,3,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,1,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0,0,0,0,0,0                  &
     &/
!
! THORIUM
      INTEGER(SP),PARAMETER :: NZTH=90,NHTH=12,NLTH=22
      DATA QCFGX(0,0,NZTH)/NHTH/
      DATA QCFGX(0,1:NHTH,NZTH)/NHTH*NLTH/
      DATA ((QCFGX(K,J,NZTH),K=1,NLTH),J=1,NHTH)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,6,2,0,0,0,2                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,6,1,0,0,0,2                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,2,6,1,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,5,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,4,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,3,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,1,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0,0,0,0,0,0                  &
     &/
!
! PROTACTINIUM
      INTEGER(SP),PARAMETER :: NZPA=91,NHPA=13,NLPA=22
      DATA QCFGX(0,0,NZPA)/NHPA/
      DATA QCFGX(0,1:NHPA,NZPA)/NHPA*NLPA/
      DATA ((QCFGX(K,J,NZPA),K=1,NLPA),J=1,NHPA)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,2,0,2,6,1,0,0,0,2                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,2,0,2,6,0,0,0,0,2                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,2,0,2,6,1,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,2,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,5,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,4,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,3,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,1,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0,0,0,0,0,0                  &
     &/
!
! URANIUM
      INTEGER(SP),PARAMETER :: NZU=92,NHU=14,NLU=22        !NHU=92 !TEST
      DATA QCFGX(0,0,NZU)/NHU/
      DATA QCFGX(0,1:NHU,NZU)/NHU*NLU/
      DATA ((QCFGX(K,J,NZU),K=1,NLU),J=1,NHU)                           &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,6,1,0,0,0,2                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,6,0,0,0,0,2                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,2,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,5,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,4,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,3,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,1,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0,0,0,0,0,0                  &
     &/
!test
!     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,14,2,6,9,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,14,2,6,8,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,14,2,6,7,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,14,2,6,6,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,14,2,6,5,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,14,2,6,4,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,14,2,6,3,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,14,2,6,2,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,14,2,6,1,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,14,2,6,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,14,2,5,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,14,2,4,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,14,2,3,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,14,2,2,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,14,2,1,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,14,2,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,14,1,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,14,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,13,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,12,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,11,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,10,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,9,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,8,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,7,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,6,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,5,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,4,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,3,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,2,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,1,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,10,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,9,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,8,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,7,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,6,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,5,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,4,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,3,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,2,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,1,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,6,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,5,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,3,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,10,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,9,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,8,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,7,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,6,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,5,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,3,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,6,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,5,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,3,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,6,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,5,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,3,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
!     &/
!
! NEPTUNIUM
      INTEGER(SP),PARAMETER :: NZNP=93,NHNP=15,NLNP=22
      DATA QCFGX(0,0,NZNP)/NHNP/
      DATA QCFGX(0,1:NHNP,NZNP)/NHNP*NLNP/
      DATA ((QCFGX(K,J,NZNP),K=1,NLNP),J=1,NHNP)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,6,1,0,0,0,2                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,6,1,0,0,0,1                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,2,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,2,5,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,2,4,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,2,3,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,1,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0,0,0,0,0,0                  &
     &/
!
! PLUTONIUM
      INTEGER(SP),PARAMETER :: NZPU=94,NHPU=16,NLPU=22
      DATA QCFGX(0,0,NZPU)/NHPU/
      DATA QCFGX(0,1:NHPU,NZPU)/NHPU*NLPU/
      DATA ((QCFGX(K,J,NZPU),K=1,NLPU),J=1,NHPU)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,6,0,0,0,0,2                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,6,0,0,0,0,1                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,5,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,4,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,3,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,2,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,1,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0,0,0,0,0,0                  &
     &/
!
! AMERICIUM
      INTEGER(SP),PARAMETER :: NZAM=95,NHAM=17,NLAM=22
      DATA QCFGX(0,0,NZAM)/NHAM/
      DATA QCFGX(0,1:NHAM,NZAM)/NHAM*NLAM/
      DATA ((QCFGX(K,J,NZAM),K=1,NLAM),J=1,NHAM)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,7,0,2,6,0,0,0,0,2                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,7,0,2,6,0,0,0,0,1                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,7,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,5,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,4,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,3,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,2,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,1,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0,0,0,0,0,0                  &
     &/
!
! CURIUM
      INTEGER(SP),PARAMETER :: NZCM=96,NHCM=18,NLCM=22
      DATA QCFGX(0,0,NZCM)/NHCM/
      DATA QCFGX(0,1:NHCM,NZCM)/NHCM*NLCM/
      DATA ((QCFGX(K,J,NZCM),K=1,NLCM),J=1,NHCM)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,7,0,2,6,1,0,0,0,2                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,7,0,2,6,0,0,0,0,2                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,8,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,7,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,4,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,3,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,2,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,2,1,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0,0,0,0,0,0                  &
     &/
!
! BERKELIUM
      INTEGER(SP),PARAMETER :: NZBK=97,NHBK=19,NLBK=22
      DATA QCFGX(0,0,NZBK)/NHBK/
      DATA QCFGX(0,1:NHBK,NZBK)/NHBK*NLBK/
      DATA ((QCFGX(K,J,NZBK),K=1,NLBK),J=1,NHBK)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,9,0,2,6,0,0,0,0,2                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,9,0,2,6,0,0,0,0,1                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,9,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,8,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,7,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,3,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,2,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,2,0,2,1,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,2,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0,0,0,0,0,0                  &
     &/
!
! CALIFORNIUM
      INTEGER(SP),PARAMETER :: NZCF=98,NHCF=20,NLCF=22
      DATA QCFGX(0,0,NZCF)/NHCF/
      DATA QCFGX(0,1:NHCF,NZCF)/NHCF*NLCF/
      DATA ((QCFGX(K,J,NZCF),K=1,NLCF),J=1,NHCF)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,10,0,2,6,0,0,0,0,2                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,10,0,2,6,0,0,0,0,1                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,10,0,2,6,0,0,0,0,0                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,9,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,8,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,7,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,7,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,1,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,2,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0,0,0,0,0,0                  &
     &/
!
! EINSTEINIUM
      INTEGER(SP),PARAMETER :: NZES=99,NHES=21,NLES=22
      DATA QCFGX(0,0,NZES)/NHES/
      DATA QCFGX(0,1:NHES,NZES)/NHES*NLES/
      DATA ((QCFGX(K,J,NZES),K=1,NLES),J=1,NHES)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,11,0,2,6,0,0,0,0,2                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,11,0,2,6,0,0,0,0,1                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,11,0,2,6,0,0,0,0,0                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,10,0,2,6,0,0,0,0,0                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,9,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,8,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,7,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,7,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,1,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,2,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0,0,0,0,0,0                  &
     &/
!
! FERMIUM
      INTEGER(SP),PARAMETER :: NZFM=100,NHFM=22,NLFM=22
      DATA QCFGX(0,0,NZFM)/NHFM/
      DATA QCFGX(0,1:NHFM,NZFM)/NHFM*NLFM/
      DATA ((QCFGX(K,J,NZFM),K=1,NLFM),J=1,NHFM)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,12,0,2,6,0,0,0,0,2                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,12,0,2,6,0,0,0,0,1                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,12,0,2,6,0,0,0,0,0                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,11,0,2,6,0,0,0,0,0                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,10,0,2,6,0,0,0,0,0                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,9,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,8,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,7,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,7,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,1,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,2,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0,0,0,0,0,0                  &
     &/
!
! MENDELEVIUM
      INTEGER(SP),PARAMETER :: NZMD=101,NHMD=23,NLMD=22
      DATA QCFGX(0,0,NZMD)/NHMD/
      DATA QCFGX(0,1:NHMD,NZMD)/NHMD*NLMD/
      DATA ((QCFGX(K,J,NZMD),K=1,NLMD),J=1,NHMD)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,13,0,2,6,0,0,0,0,2                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,13,0,2,6,0,0,0,0,1                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,13,0,2,6,0,0,0,0,0                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,12,0,2,6,0,0,0,0,0                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,11,0,2,6,0,0,0,0,0                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,10,0,2,6,0,0,0,0,0                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,9,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,8,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,7,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,7,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,1,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,2,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0,0,0,0,0,0                  &
     &/
!
! NOBELIUM
      INTEGER(SP),PARAMETER :: NZNO=102,NHNO=24,NLNO=22
      DATA QCFGX(0,0,NZNO)/NHNO/
      DATA QCFGX(0,1:NHNO,NZNO)/NHNO*NLNO/
      DATA ((QCFGX(K,J,NZNO),K=1,NLNO),J=1,NHNO)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,14,0,2,6,0,0,0,0,2                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,14,0,2,6,0,0,0,0,1                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,14,0,2,6,0,0,0,0,0                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,13,0,2,6,0,0,0,0,0                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,12,0,2,6,0,0,0,0,0                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,11,0,2,6,0,0,0,0,0                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,10,0,2,6,0,0,0,0,0                 &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,9,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,8,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,7,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,6,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,7,0,2,2,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,7,0,2,1,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,7,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,2,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,2,0,0,0,0,0,0                  &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,0,0,1,0,0,0,0,0,0                  &
     &/
!
! LAWRENCIUM
      INTEGER(SP),PARAMETER :: NZLR=103,NHLR=24,NLLR=23
      DATA QCFGX(0,0,NZLR)/NHLR/
      DATA QCFGX(0,1:NHLR,NZLR)/NHLR*NLLR/
      DATA ((QCFGX(K,J,NZLR),K=1,NLLR),J=1,NHLR)                        &
     &/2,2,6,2,6,10,2,6,10,14,2,6,10,14,0,2,6,0,0,0,0,2,1               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,14,0,2,6,0,0,0,0,2,0               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,14,0,2,6,0,0,0,0,1,0               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,14,0,2,6,0,0,0,0,0,0               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,13,0,2,6,0,0,0,0,0,0               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,12,0,2,6,0,0,0,0,0,0               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,11,0,2,6,0,0,0,0,0,0               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,10,0,2,6,0,0,0,0,0,0               &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,9,0,2,6,0,0,0,0,0,0                &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,8,0,2,6,0,0,0,0,0,0                &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,7,0,2,6,0,0,0,0,0,0                &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,6,0,0,0,0,0,0                &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,6,0,0,0,0,0,0                &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,6,0,0,0,0,0,0                &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,8,0,2,1,0,0,0,0,0,0                &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,8,0,2,0,0,0,0,0,0,0                &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,7,0,2,0,0,0,0,0,0,0                &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,6,0,2,0,0,0,0,0,0,0                &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,5,0,2,0,0,0,0,0,0,0                &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,4,0,2,0,0,0,0,0,0,0                &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,3,0,2,0,0,0,0,0,0,0                &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,2,0,2,0,0,0,0,0,0,0                &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,2,0,0,0,0,0,0,0                &
     &,2,2,6,2,6,10,2,6,10,14,2,6,10,1,0,1,0,0,0,0,0,0,0                &
     &/
!
!-----------------------------------------------------------------------
!
      END MODULE ADF00
!
!                             *******************
!
      MODULE CONSTANTS_INTEGER
!
!-----------------------------------------------------------------------
!
! SET INTEGER CONSTANTS
!   CURRENTLY, ONLY USED IN SUBPROGRAM ARGUMENTS AND REAL EXPRESIONS
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: QP,SP
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      INTEGER(QP), PARAMETER :: QZERO=   0_QP
      INTEGER(QP), PARAMETER :: QONE=    1_QP
      INTEGER(QP), PARAMETER :: QTWO=    2_QP
      INTEGER(QP), PARAMETER :: QTHREE=  3_QP
      INTEGER(QP), PARAMETER :: QFOUR=   4_QP
      INTEGER(QP), PARAMETER :: QFIVE=   5_QP
      INTEGER(QP), PARAMETER :: Q50=    50_QP
      INTEGER(QP), PARAMETER :: Q60=    60_QP
      INTEGER(QP), PARAMETER :: Q70=    70_QP
      INTEGER(QP), PARAMETER :: Q80=    80_QP
      INTEGER(QP), PARAMETER :: Q90=    90_QP
      INTEGER(QP), PARAMETER :: Q99=    99_QP
!
      INTEGER(SP), PARAMETER :: IZERO=   0_SP
      INTEGER(SP), PARAMETER :: IONE=    1_SP
      INTEGER(SP), PARAMETER :: ITWO=    2_SP
      INTEGER(SP), PARAMETER :: ITHREE=  3_SP
      INTEGER(SP), PARAMETER :: IFOUR=   4_SP
      INTEGER(SP), PARAMETER :: IFIVE=   5_SP
      INTEGER(SP), PARAMETER :: ISIX=    6_SP
      INTEGER(SP), PARAMETER :: ISEVEN=  7_SP
      INTEGER(SP), PARAMETER :: IEIGHT=  8_SP
      INTEGER(SP), PARAMETER :: ININE=   9_SP
      INTEGER(SP), PARAMETER :: ITEN=   10_SP
      INTEGER(SP), PARAMETER :: IELEVN= 11_SP
      INTEGER(SP), PARAMETER :: ITWELV= 12_SP
      INTEGER(SP), PARAMETER :: I3TEEN= 13_SP
      INTEGER(SP), PARAMETER :: I4TEEN= 14_SP
      INTEGER(SP), PARAMETER :: I5TEEN= 15_SP
      INTEGER(SP), PARAMETER :: I6TEEN= 16_SP
      INTEGER(SP), PARAMETER :: I7TEEN= 17_SP
      INTEGER(SP), PARAMETER :: I8TEEN= 18_SP
      INTEGER(SP), PARAMETER :: I9TEEN= 19_SP
      INTEGER(SP), PARAMETER :: I20=    20_SP
      INTEGER(SP), PARAMETER :: I30=    30_SP
      INTEGER(SP), PARAMETER :: I32=    32_SP
      INTEGER(SP), PARAMETER :: I40=    40_SP
      INTEGER(SP), PARAMETER :: I50=    50_SP
      INTEGER(SP), PARAMETER :: I60=    60_SP
      INTEGER(SP), PARAMETER :: I64=    64_SP
      INTEGER(SP), PARAMETER :: I70=    70_SP
      INTEGER(SP), PARAMETER :: I80=    80_SP
      INTEGER(SP), PARAMETER :: I90=    90_SP
      INTEGER(SP), PARAMETER :: I99=    99_SP
      INTEGER(SP), PARAMETER :: I100=  100_SP
      INTEGER(SP), PARAMETER :: I128=  128_SP
      INTEGER(SP), PARAMETER :: I200=  200_SP
      INTEGER(SP), PARAMETER :: I256=  256_SP
      INTEGER(SP), PARAMETER :: I300=  300_SP
      INTEGER(SP), PARAMETER :: I512=  512_SP
      INTEGER(SP), PARAMETER :: I999=  999_SP
      INTEGER(SP), PARAMETER :: I1024=1024_SP
      INTEGER(SP), PARAMETER :: I1000=1000_SP
      INTEGER(SP), PARAMETER :: I10000=10000_SP
      INTEGER(SP), PARAMETER :: I100000=100000_SP
      INTEGER(SP), PARAMETER :: I1000000=1000000_SP
!
      END MODULE CONSTANTS_INTEGER
!
!                             *******************
!
      MODULE CONSTANTS_REAL
!
!-----------------------------------------------------------------------
!
! SET REAL CONSTANTS
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: WP,XP
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      REAL(XP), PARAMETER :: XZERO=   0.0E0_XP
      REAL(XP), PARAMETER :: XONE=    1.0E0_XP
      REAL(XP), PARAMETER :: XTWO=    2.0E0_XP
      REAL(XP), PARAMETER :: XTHREE=  3.0E0_XP
      REAL(XP), PARAMETER :: XFOUR=   4.0E0_XP
!      REAL(XP), PARAMETER :: XFIVE=   5.0E0_XP
!      REAL(XP), PARAMETER :: XSIX=    6.0E0_XP
!      REAL(XP), PARAMETER :: XSEVEN=  7.0E0_XP
      REAL(XP), PARAMETER :: XEIGHT=  8.0E0_XP
!      REAL(XP), PARAMETER :: XNINE=   9.0E0_XP
!      REAL(XP), PARAMETER :: XTEN=   10.0E0_XP
!      REAL(XP), PARAMETER :: XELEVN= 11.0E0_XP
!      REAL(XP), PARAMETER :: XTWELV= 12.0E0_XP
!
      REAL(XP), PARAMETER :: X64=    64.0E0_XP
      REAL(XP), PARAMETER :: X300=  300.0E0_XP
      REAL(XP), PARAMETER :: X1M40= 1.0E-40_XP
      REAL(XP), PARAMETER :: X1P24= 1.0E+24_XP
      REAL(XP), PARAMETER :: X1PT5=   1.5E0_XP
      REAL(XP), PARAMETER :: X0PT2=   0.2E0_XP
!
      REAL(XP), PARAMETER :: XHALF=  XONE/XTWO
!      REAL(XP), PARAMETER :: X3HALF= XTHREE/XTWO
      REAL(XP), PARAMETER :: XQUART= XONE/XFOUR
!      REAL(XP), PARAMETER :: X3QRT=  XTHREE/XFOUR
!      REAL(XP), PARAMETER :: X8TH=   XONE/XEIGHT
!
!      REAL(XP), PARAMETER :: X1THRD= XONE/XTHREE
      REAL(XP), PARAMETER :: X2THRD= XTWO/XTHREE
      REAL(XP), PARAMETER :: X4THRD= XFOUR/XTHREE
!      REAL(XP), PARAMETER :: X5THRD= XFIVE/XTHREE
!
!      REAL(XP), PARAMETER :: XFIFTH= XONE/XFIVE
!      REAL(XP), PARAMETER :: XSIXTH= XONE/XSIX
!      REAL(XP), PARAMETER :: XTWELF= XONE/XTWELV
!
      REAL(XP), PARAMETER :: X1M1= 1.0E-1_XP
      REAL(XP), PARAMETER :: X1P6= 1.0E+6_XP
!
      REAL(XP), PARAMETER :: X0PT3=0.3E0_XP
!
!
      REAL(WP), PARAMETER :: DZERO=   0.0E0_WP
      REAL(WP), PARAMETER :: DONE=    1.0E0_WP
      REAL(WP), PARAMETER :: DTWO=    2.0E0_WP
      REAL(WP), PARAMETER :: DTHREE=  3.0E0_WP
      REAL(WP), PARAMETER :: DFOUR=   4.0E0_WP
      REAL(WP), PARAMETER :: DFIVE=   5.0E0_WP
      REAL(WP), PARAMETER :: DSIX=    6.0E0_WP
      REAL(WP), PARAMETER :: DSEVEN=  7.0E0_WP
      REAL(WP), PARAMETER :: DEIGHT=  8.0E0_WP
      REAL(WP), PARAMETER :: DNINE=   9.0E0_WP
      REAL(WP), PARAMETER :: DTEN=   10.0E0_WP
      REAL(WP), PARAMETER :: DELEVN= 11.0E0_WP
      REAL(WP), PARAMETER :: DTWELV= 12.0E0_WP
      REAL(WP), PARAMETER :: D3TEEN= 13.0E0_WP
      REAL(WP), PARAMETER :: D4TEEN= 14.0E0_WP
      REAL(WP), PARAMETER :: D5TEEN= 15.0E0_WP
      REAL(WP), PARAMETER :: D6TEEN= 16.0E0_WP
      REAL(WP), PARAMETER :: D7TEEN= 17.0E0_WP
      REAL(WP), PARAMETER :: D8TEEN= 18.0E0_WP
      REAL(WP), PARAMETER :: D9TEEN= 19.0E0_WP
      REAL(WP), PARAMETER :: D20=    20.0E0_WP
      REAL(WP), PARAMETER :: D30=    30.0E0_WP
      REAL(WP), PARAMETER :: D32=    32.0E0_WP
      REAL(WP), PARAMETER :: D40=    40.0E0_WP
      REAL(WP), PARAMETER :: D50=    50.0E0_WP
      REAL(WP), PARAMETER :: D60=    60.0E0_WP
      REAL(WP), PARAMETER :: D64=    64.0E0_WP
      REAL(WP), PARAMETER :: D70=    70.0E0_WP
      REAL(WP), PARAMETER :: D80=    80.0E0_WP
      REAL(WP), PARAMETER :: D90=    90.0E0_WP
      REAL(WP), PARAMETER :: D99=    99.0E0_WP
      REAL(WP), PARAMETER :: D100=  100.0E0_WP
      REAL(WP), PARAMETER :: D128=  128.0E0_WP
      REAL(WP), PARAMETER :: D200=  200.0E0_WP
      REAL(WP), PARAMETER :: D256=  256.0E0_WP
      REAL(WP), PARAMETER :: D300=  300.0E0_WP
      REAL(WP), PARAMETER :: D512=  512.0E0_WP
      REAL(WP), PARAMETER :: D999=  999.0E0_WP
      REAL(WP), PARAMETER :: D1024=1024.0E0_WP
!
      REAL(WP), PARAMETER :: DHALF=  DONE/DTWO
      REAL(WP), PARAMETER :: D3HALF= DTHREE/DTWO
      REAL(WP), PARAMETER :: DQUART= DONE/DFOUR
      REAL(WP), PARAMETER :: D3QRT=  DTHREE/DFOUR
      REAL(WP), PARAMETER :: D8TH=   DONE/DEIGHT
!
      REAL(WP), PARAMETER :: D1THRD= DONE/DTHREE
      REAL(WP), PARAMETER :: D2THRD= DTWO/DTHREE
      REAL(WP), PARAMETER :: D4THRD= DFOUR/DTHREE
      REAL(WP), PARAMETER :: D5THRD= DFIVE/DTHREE
!
      REAL(WP), PARAMETER :: DFIFTH= DONE/DFIVE
      REAL(WP), PARAMETER :: DSIXTH= DONE/DSIX
      REAL(WP), PARAMETER :: DTWELF= DONE/DTWELV
!
      REAL(WP), PARAMETER :: D1M1= 1.0E-1_WP
      REAL(WP), PARAMETER :: D1M2= 1.0E-2_WP
      REAL(WP), PARAMETER :: D1M3= 1.0E-3_WP
      REAL(WP), PARAMETER :: D1M4= 1.0E-4_WP
      REAL(WP), PARAMETER :: D1M5= 1.0E-5_WP
      REAL(WP), PARAMETER :: D1M6= 1.0E-6_WP
      REAL(WP), PARAMETER :: D1M7= 1.0E-7_WP
      REAL(WP), PARAMETER :: D1M8= 1.0E-8_WP
      REAL(WP), PARAMETER :: D1M9= 1.0E-9_WP
      REAL(WP), PARAMETER :: D1M10=1.0E-10_WP
      REAL(WP), PARAMETER :: D1M11=1.0E-11_WP
      REAL(WP), PARAMETER :: D1M12=1.0E-12_WP
      REAL(WP), PARAMETER :: D1M14=1.0E-14_WP
      REAL(WP), PARAMETER :: D1M15=1.0E-15_WP
      REAL(WP), PARAMETER :: D1M18=1.0E-18_WP
      REAL(WP), PARAMETER :: D1M20=1.0E-20_WP
      REAL(WP), PARAMETER :: D1M24=1.0E-24_WP
      REAL(WP), PARAMETER :: D1M30=1.0E-30_WP
      REAL(WP), PARAMETER :: D1M40=1.0E-40_WP
      REAL(WP), PARAMETER :: D1M50=1.0E-50_WP
      REAL(WP), PARAMETER :: D1M60=1.0E-60_WP
      REAL(WP), PARAMETER :: D1M70=1.0E-70_WP
      REAL(WP), PARAMETER :: D1M75=1.0E-75_WP
      REAL(WP), PARAMETER :: D1M99=1.0E-99_WP
      REAL(WP), PARAMETER :: D1M140=1.0E-140_WP
      REAL(WP), PARAMETER :: D1M300=1.0E-300_WP
!
      REAL(WP), PARAMETER :: D1P1= 1.0E+1_WP
      REAL(WP), PARAMETER :: D1P2= 1.0E+2_WP
      REAL(WP), PARAMETER :: D1P3= 1.0E+3_WP
      REAL(WP), PARAMETER :: D1P4= 1.0E+4_WP
      REAL(WP), PARAMETER :: D1P5= 1.0E+5_WP
      REAL(WP), PARAMETER :: D1P6= 1.0E+6_WP
      REAL(WP), PARAMETER :: D1P7= 1.0E+7_WP
      REAL(WP), PARAMETER :: D1P8= 1.0E+8_WP
      REAL(WP), PARAMETER :: D1P9= 1.0E+9_WP
      REAL(WP), PARAMETER :: D1P10=1.0E+10_WP
      REAL(WP), PARAMETER :: D1P12=1.0E+12_WP
      REAL(WP), PARAMETER :: D1P14=1.0E+14_WP
      REAL(WP), PARAMETER :: D1P15=1.0E+15_WP
      REAL(WP), PARAMETER :: D1P18=1.0E+18_WP
      REAL(WP), PARAMETER :: D1P20=1.0E+20_WP
      REAL(WP), PARAMETER :: D1P24=1.0E+24_WP
      REAL(WP), PARAMETER :: D1P30=1.0E+30_WP
      REAL(WP), PARAMETER :: D1P40=1.0E+40_WP
      REAL(WP), PARAMETER :: D1P50=1.0E+50_WP
      REAL(WP), PARAMETER :: D1P60=1.0E+60_WP
      REAL(WP), PARAMETER :: D1P70=1.0E+70_WP
      REAL(WP), PARAMETER :: D1P75=1.0E+75_WP
      REAL(WP), PARAMETER :: D1P99=1.0E+99_WP
      REAL(WP), PARAMETER :: D1P300=1.0E+300_WP
!
! MISC
!
      REAL(WP), PARAMETER :: D0PT03=0.03E0_WP
      REAL(WP), PARAMETER :: D0PT05=0.05E0_WP
      REAL(WP), PARAMETER :: D0PT1=0.1E0_WP          !=D1M1 OF COURSE...
      REAL(WP), PARAMETER :: D0PT2=0.2E0_WP
      REAL(WP), PARAMETER :: D0PT3=0.3E0_WP
      REAL(WP), PARAMETER :: D0PT35=0.35E0_WP
      REAL(WP), PARAMETER :: D0PT4=0.4E0_WP
      REAL(WP), PARAMETER :: D0PT7=0.7E0_WP
      REAL(WP), PARAMETER :: D0PT8=0.8E0_WP
      REAL(WP), PARAMETER :: D0PT85=0.85E0_WP
      REAL(WP), PARAMETER :: D0PT9=0.9E0_WP
      REAL(WP), PARAMETER :: D0PT95=0.95E0_WP
      REAL(WP), PARAMETER :: D0PT99=0.99E0_WP
      REAL(WP), PARAMETER :: D0PT999=0.999E0_WP
!
      REAL(WP), PARAMETER :: D1PT05=1.05E0_WP
      REAL(WP), PARAMETER :: D1PT1=1.1E0_WP
      REAL(WP), PARAMETER :: D1PT2=1.2E0_WP
      REAL(WP), PARAMETER :: D1PT3=1.3E0_WP
      REAL(WP), PARAMETER :: D1PT4=1.4E0_WP
      REAL(WP), PARAMETER :: D1PT5=1.5E0_WP
!
      REAL(WP), PARAMETER :: D2PT42=2.42E0_WP
      REAL(WP), PARAMETER :: D2PT5=2.5E0_WP
!
      REAL(WP), PARAMETER :: D88=88.0E0_WP
      REAL(WP), PARAMETER :: D180=180.0E0_WP
      REAL(WP), PARAMETER :: D840=840.0E0_WP
      REAL(WP), PARAMETER :: D3999=3999.0E0_WP
      REAL(WP), PARAMETER :: D5999=5999.0E0_WP
      REAL(WP), PARAMETER :: D6999=6999.0E0_WP
      REAL(WP), PARAMETER :: D7999=7999.0E0_WP
      REAL(WP), PARAMETER :: D9999=9999.0E0_WP
!
      END MODULE CONSTANTS_REAL
!
!                             *******************
!
      MODULE CONSTANTS_MATHS
!
!-----------------------------------------------------------------------
!
! SET MATHEMATICAL CONSTANTS
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,XP
      USE UTILITY
!      USE CONSTANTS_REAL
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE          !REAL(WP) (A,C-H,O-P,R-Z)
!
      REAL(WP), PARAMETER :: EULER=0.57721566490153_WP
      REAL(WP), PARAMETER :: XPI=3.141592653589793_WP !USED IN PARAMETER
!
! HISTORIC VALUE, USED VIA AN EXECUTABLE STATEMENT IN EACH SUBPROGRAM
!      REAL(WP), PARAMETER :: PI=ACOS(-DONE)   !AS THIS FORM NEEDS F2003
!      REAL(WP), PARAMETER :: PIH=PI/DTWO
!      REAL(WP), PARAMETER :: XPI=ACOS(-XONE)  !AS THIS FORM NEEDS F2003
!
! SPEC FOR SR.DFACT  FACTORIAL ARRAY (DFS) CONTAINED WITHIN.
!
      INTEGER(SP) LDFS,IXDFS3,IXDFS6
      REAL(XP) DFS
      ALLOCATABLE :: DFS(:)                      !FACTORIAL ARRAY
!
      SAVE
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
!
!                             *******************
!
      SUBROUTINE DFACT
!
!-----------------------------------------------------------------------
!
!  SR.DFACT:
!
!  SETS-UP A REAL(XP) DFS(I) ARRAY OF SCALED INTEGER FACTORIALS >= 0:
!  DFS(I)=(I-1)!/LDFS**(I-1) FOR I=1,IXDFS.
!
!  IXDFS IS CHOSEN TO GIVE THE APPROX LARGEST VALUE FOR DFS ALLOWABLE
!  FOR THE WORD LENGTH XP WHEN USED BY FN.VCC & FN.SJS, I.E. TAKING
!  ACCOUNT OF CANCELLATION ERROR IN THE ALGORITHMS THERE-IN.
!
!-----------------------------------------------------------------------
!
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,XP
      USE PARAM
      USE CONSTANTS_INTEGER
      USE CONSTANTS_REAL
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      INTEGER(SP) I,IERR                                  !LOCAL
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
      IF(XP.EQ.IEIGHT)THEN
        LDFS=32
        IXDFS3=200
        IXDFS6=325
      ELSEIF(XP.EQ.I6TEEN)THEN
        LDFS=64
        IXDFS3=500
        IXDFS6=800
      ELSE
        WRITE(MW6,*)'SR.DFACT:: ILLEGAL XP WORD LENGTH:',XP
      ENDIF
!
      IXDFS=MAX(IXDFS3,IXDFS6)
!
      ALLOCATE(DFS(IXDFS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.DFACT: ALLOCATION FAILS FOR DFS'
        IXDFS=0
        RETURN
      ENDIF
!
      DFS(1)=1                    !ZERO FACTORIAL
      DO I=2,IXDFS
        DFS(I)=(I-1)*DFS(I-1)/LDFS
!       write(mw0,*)i,dfs(i)
      ENDDO
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE DFACT
!
!-----------------------------------------------------------------------
!
      END MODULE CONSTANTS_MATHS
!
!                             *******************
!
      MODULE CONSTANTS_PHYSICS
!
!-----------------------------------------------------------------------
!
! SET PHYSICAL CONSTANTS
!
!(TBD: some subprograms use explicit values for products of below,
! rather than forming them from here: e.g. sr.carate, sr.diagon,
! sr.diagfs, sr.minim, sr.minim0...)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: WP
      USE CONSTANTS_REAL
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      REAL(WP), PARAMETER :: A0_BOHR=5.291771E-09_WP      !CM
      REAL(WP), PARAMETER :: CLIGHT=137.03599976_WP
!      REAL(WP), PARAMETER :: DFSC=DONE/CLIGHT
      REAL(WP), PARAMETER :: DFSC=7.2973525333E-03_WP     !HISTORIC
      REAL(WP), PARAMETER :: DALF=DFSC*DFSC               !not ideal...
      REAL(WP), PARAMETER :: DALF4=DALF/DFOUR
      REAL(WP), PARAMETER :: DKCM=109737.31_WP            !CM^-1
      REAL(WP), PARAMETER :: HBAR=4.8377687E-17_WP        !RYD.SEC
      REAL(WP), PARAMETER :: T_BOLTZ=6.333583E-6_WP       !k (Ryd/K)
!
      END MODULE CONSTANTS_PHYSICS
!
!                             *******************
!
      MODULE CONSTANTS
!
!-----------------------------------------------------------------------
!
! SET CONSTANTS
!
!-----------------------------------------------------------------------
!
      USE CONSTANTS_INTEGER
      USE CONSTANTS_REAL
      USE CONSTANTS_MATHS
      USE CONSTANTS_PHYSICS
!
!-----------------------------------------------------------------------
!
      IMPLICIT NONE
!
      END MODULE CONSTANTS
!
!                             *******************
!
      MODULE COMMON_ALGEB
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!
!     COMMON /OUTP1/MPRINT
!     COMMON /SSWRK/IWRK1(MXD08),IWRK2(MXD08)
!     COMMON /NRBDSK/MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD,KFBUFF
!     COMMON /NRBDUM/MXDC0,MXGR0  !NOT USED ANYWHERE. BUT FOR A RESTARTX
!     COMMON /NRBFAN/BFANO
!     COMMON /NRBFOT/BFOT
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) MXD07,MXD08,MXD10
      INTEGER(SP) IXD08
!
      PARAMETER (MXD07=100)       !S.S. NO. OF UNIT5 CONFIG INPUT LINES
      PARAMETER (MXD08=MXD07*21)  !S.S. MXD07*NO. OF CHARS/LINE *FIXED*
      PARAMETER (MXD10=MXD07*5)   !S.S. MXD10*NO. CFGS PER LINE (APPROX)
!
      INTEGER(SP) MPRINT
      INTEGER(SP) IWRK1,IWRK2
      INTEGER(SP) MDCBUF,KUTDSK,MTGD1,IUD,KFBUFF
!
      INTEGER(EP) MDCF8,MDCFT8
!
      LOGICAL(BP) BFANO
      LOGICAL(BP) BFOT
!
      ALLOCATABLE :: IWRK1(:),IWRK2(:)
!
      SAVE
!
      DATA IXD08/0/
!
      END MODULE COMMON_ALGEB
!
!                             *******************
!
      MODULE COMMON_BASIC
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /BASIC/NF,MGAP(11)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) NF                                  !USE KG=>IBSK2 ETC
      INTEGER(SP) IBSK2,IBSK3,IBSK4,IBSK5,IBSK6,IBSK7                   &
     &           ,IBSK8,IBSK9,IBSK10,IBSK11,IBSK12         !COULD EXTEND
!
! NOT RECOMMENDED, BUT...
!
!      LOGICAL(BP)                              !COULD EXTEND TO LOGICAL
!
!      REAL(WP)                                    !COULD EXTEND TO REAL
!
      SAVE
!
      END MODULE COMMON_BASIC
!
!                             *******************
!
      MODULE COMMON_CACC
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /CACC/ACC(MAXGR,MAXGR)
!
! SHOULD BE MERGED WITH MODULE COMMON_INTS
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      REAL(WP) ACC
!
      ALLOCATABLE :: ACC(:)
!
      SAVE
!
      END MODULE COMMON_CACC
!
!                             *******************
!
      MODULE COMMON_CADJ
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /CADJ/DAJNEW(MXVAR),DF0,IEQUAL(MXVAR),ICOUNT
!     COMMON /CALAN/DALAN(MXVAR),BALAN
!     SR.MINIM DIMENSION DEXTRE(MXVAR),DACCUR(MXVAR)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      LOGICAL(BP) BALAN
!
      INTEGER(SP) IEQUAL,ICOUNT,ICOUNT0
!
      ALLOCATABLE :: IEQUAL(:)
!
      REAL(WP) DF0,DAJNEW,DALAN,DEXTRE,DACCUR
!
      ALLOCATABLE :: DAJNEW(:),DALAN(:),DEXTRE(:),DACCUR(:)
!
      SAVE
!
      END MODULE COMMON_CADJ
!
!                             *******************
!
      MODULE COMMON_CCLSH
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /CCLSH/NW,NNL(MAXCL,3)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) NW,NNL
!
      ALLOCATABLE :: NNL(:,:)
!
      SAVE
!
      END MODULE COMMON_CCLSH
!
!                             *******************
!
      MODULE COMMON_CFCT
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     PARAMETER (MXD31=MAXLL+1)
!     PARAMETER (MXD32=MXD31*MXD31)
!     COMMON /CFCT/VCA(MXD32,MXD32,MXD31),VCB(MXD32,MXD32,MXD31)        &
!    &            ,MXLL,BVC,BDLBD
! N.B.
! NOW MAXLL IS THE MAX L *PLUS* 1 VCC TABLE STORED.
! ONLY USED FOR TESTING. USER JOE SHOULD NOT NEED TO SET.
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      LOGICAL(BP) BVC,BDLBD
!
      INTEGER(SP)MXLL,MAXLL0,MAXLL1
!
      REAL (WP) VCA,VCB
!
      PARAMETER (MAXLL0=07)    !HISTORIC "DEFAULT"
      PARAMETER (MAXLL1=36)    !DON'T ALLOW USER TO INFLATE, AS MAXLL**5
!
      ALLOCATABLE :: VCA(:,:,:),VCB(:,:,:)
!
      SAVE
!
      END MODULE COMMON_CFCT
!
!                             *******************
!
      MODULE COMMON_CMESH
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /CMESH/DHNS(MJH),MNH(MJH),MJH,MAXRS
!     COMMON /NRBBOX/TINORB,RZERO,MXBOX
!     COMMON /NRBHF/MHF,MRAD,MSTEP,IXTRA,xmax
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) MNH,MJH,MAXRS
      INTEGER(SP) MHF,MRAD,MSTEP,IXTRA
      INTEGER(SP) MXBOX
      INTEGER(SP) IFLAGV
!
      REAL(WP) DHNS
      REAL(WP) xmax
      REAL(WP) TINORB,RZERO
!
! SET UP THE INTERVALS (STEP IS CONSTANT WITHIN AN INTERVAL)
!
! NOTE: ANY VALUE MNH0(J).LT.9 STEPS PER INTERVAL J WILL CAUSE TROUBLE;
!   SO WILL A NUMBER MJH0.LT.2 OF INTERVALS; MJH0.LE.DIM(MNH0,MNH,DHNS)
!   SR.TFDAPO REQUIRES LAST INTERVAL TO HAVE AT LEAST TWICE AS MANY
!   POINTS AS THE PENULTIMATE.
!
      INTEGER(SP) MNH0,MJH00,MJH0,IXTRA0,MXTRA
!
      PARAMETER (MJH0=10)
      PARAMETER (IXTRA0=10)                       !LIMITS ANY USER IXTRA
!
      PARAMETER (MJH00=MJH0+IXTRA0)
!
      DIMENSION MNH0(MJH0)
      DIMENSION MNH(MJH00),DHNS(MJH00)
!
      SAVE
!
! MJH0=10
!      DATA
!     &   MNH0(1),MNH0(2),MNH0(3),MNH0(4),MNH0(5) /32,32,64,64,64/,
!     &   MNH0(6),MNH0(7),MNH0(8),MNH0(9),MNH0(10)/64,64,64,256,9296/
! MJH0=10
      DATA                                                              &
     &    MNH0(1),MNH0(2),MNH0(3),MNH0(4),MNH0(5) /32,32,32,32,32/,     &
     &    MNH0(6),MNH0(7),MNH0(8),MNH0(9),MNH0(10)/32,32,32,512,9232/
! MJH0=11
!      DATA
!     &    MNH0(1),MNH0(2),MNH0(3),MNH0(4),MNH0(5)/16,16,32,32,32/,
!     &    MNH0(6),MNH0(7),MNH0(8),MNH0(9),MNH0(10)/32,32,32,64,128/,
!     &    MNH0(11)/9616/
!
      DATA MXTRA/32/              !EXTRA POINTS FOR IXTRA USER INTERVALS
!
      END MODULE COMMON_CMESH
!
!                             *******************
!
      MODULE COMMON_COEFF
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /COEFF/DRKP(MXSOC),NRKP(MXSOC),QRLP(4,MXSOI),IRLP          &
!    &             ,NADP(0:MXADJ)
!     COMMON /NXRLP/IRKP,IRKP0
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(QP) QRLP
      INTEGER(SP) IRLP,NADP,IWORD1    !LEAVE THIS AS SP(=4)
      INTEGER(SP) MXSOC0,MXSOI0
      INTEGER(SP) IRKP,IRKP0
!
      REAL(WP) DRKP
!
      PARAMETER (IWORD1=SP)           !USE EP (=8) HERE IF REQUESTED
      INTEGER(IWORD1) NRKP,N81,IPLANT_SOI
!
      PARAMETER (MXSOC0= 10000)       !MINIMUM STARTING VALUES FOR
      PARAMETER (MXSOI0=   500)       !RE-ALLOCATION, SUBVERT SMALL USER
!
      ALLOCATABLE :: DRKP(:),QRLP(:,:),NRKP(:),NADP(:)
!
      SAVE
!
      END MODULE COMMON_COEFF
!
!                             *******************
!
      MODULE COMMON_COEFFS
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /COEFFS/DRKPS(MXS1C),QRLPS(4,MXS1I),NRKPS(MXS1C)
!     COMMON /NSSADR/IRKPS,IRKPS0,IRLPS,IRLPS0
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE COMMON_COEFF, ONLY: MXSOC0,MXSOI0
!
      IMPLICIT NONE
!
      INTEGER(QP) QRLPS
      INTEGER(SP) NRKPS
      INTEGER(SP) MXS1C0,MXS1I0
      INTEGER(SP) IRKPS,IRKPS0,IRLPS,IRLPS0
!
      REAL(WP) DRKPS
!
      PARAMETER (MXS1C0=MXSOC0)       !MINIMUM STARTING VALUES FOR
      PARAMETER (MXS1I0=MXSOI0)       !RE-ALLOCATION, SUBVERT SMALL USER
!
      ALLOCATABLE :: DRKPS(:),NRKPS(:),QRLPS(:,:)
!
      SAVE
!
      END MODULE COMMON_COEFFS
!
!                             *******************
!
      MODULE COMMON_DBD2
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR)
! PLUS QCGS(MXEL0) FROM /NRBVCX/
! PLUS QCP(MAXCF) FROM /QTG/
! PLUS DEY(MAXGR) FROM /CHARY/ - SHOULD SEPARATE ITS TWO FUNCTIONS
!                    1/ ORBITAL EXISTENCE & 2/ ONE-ELECTRON ENERGY
! 1/ IS RELEVANT FOR COMMON_DBD2
! 2/ IS RELEVANT FOR COMMON_RADF, WHERE DUY RESIDES.
! CURRENT SET-UP MAKES FOR MESSY MEMORY MANAGEMENT, ESP FOR DW.
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(QP) QCP,QCG,QL,QN,QCGS
!
      REAL(WP) DEY
!
      ALLOCATABLE :: QCP(:),QCG(:,:),QL(:),QN(:),QCGS(:)
      ALLOCATABLE :: DEY(:)
!
      SAVE
!
      END MODULE COMMON_DBD2
!
!                             *******************
!
      MODULE COMMON_DC
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR,
!     DIMENSION DC(0:MAXDC),IDC(MAXDC)
!                        WHICH WAS PASSED THROUGH ARGUMENTS
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
!
      IMPLICIT NONE
!
      LOGICAL(BP) BFAST
!
      INTEGER(SP) LREC,IREC,IXIDC
!
      INTEGER(SP), ALLOCATABLE :: IDC(:)
      DATA IREC/SP/                     !SET TO BYTE LENGTH OF IDC ARRAY
!
      REAL(WP), ALLOCATABLE :: DC(:)                 !*4 NOT RECOMMENDED
      DATA LREC/WP/                     !SET TO BYTE LENGTH OF  DC ARRAY
!
      DATA IXIDC/1/                     !HISTORICALLY NOT IND. OF IAXDC
!
      INTEGER(SP) MAXDC0,MXST00
!
      PARAMETER (MAXDC0=1000000)      !MINIMUM STARTING VALUES FOR
      PARAMETER (MXST00=   5050)      !RE-ALLOCATION, SUBVERT SMALL USER
!
      SAVE
!
      END MODULE COMMON_DC
!
!                             *******************
!
      MODULE COMMON_DMQSS3
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /DMQSS3/DSS(MXRSS),MSS(MXRSS),QSS(5,MAXMI)                 &
!    &              ,NADR(0:MXAJS)
!     COMMON /NXRLS/IRS,IRS0
!     COMMON /NXRNL/NL,NL000
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(QP) QSS
      INTEGER(SP) NADR,IWORD2         !LEAVE THIS AS SP (=4)
      INTEGER(SP) MAXMI0,MXRSS0
      INTEGER(SP) IRS,IRS0
      INTEGER(SP) NL,NL000
!
      REAL(WP) DSS
!
      PARAMETER (IWORD2=SP)           !USE EP (=8) HERE IF REQUESTED
      INTEGER(IWORD2) MSS,N82,IPLANT_MI
!
      PARAMETER (MAXMI0=  1000)       !MINIMUM STARTING VALUES FOR
      PARAMETER (MXRSS0= 25000)       !RE-ALLOCATION, SUBVERT SMALL USER
!
      ALLOCATABLE :: DSS(:),MSS(:),QSS(:,:),NADR(:)
!
      SAVE
!
      END MODULE COMMON_DMQSS3
!
!                             *******************
!
      MODULE COMMON_DMQSSS
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /DMQSSS/DSSS(MXS2C),MSSS(MXS2C),QSSS(5,MXS2I)
!     COMMON /NSSADR/IRSS,IRSS0,NLS,NLS00
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE COMMON_DMQSS3, ONLY: MAXMI0,MXRSS0
!
      IMPLICIT NONE
!
      REAL(WP) DSSS
!
      INTEGER(QP) QSSS
      INTEGER(SP) MSSS
      INTEGER(SP) MXS2I0,MXS2C0
      INTEGER(SP) IRSS,IRSS0,NLS,NLS00
!
      PARAMETER (MXS2I0=MAXMI0)       !MINIMUM STARTING VALUES FOR
      PARAMETER (MXS2C0=MXRSS0)       !RE-ALLOCATION, SUBVERT SMALL USER
!
      ALLOCATABLE :: DSSS(:),MSSS(:),QSSS(:,:)
!
      SAVE
!
      END MODULE COMMON_DMQSSS
!
!                             *******************
!
      MODULE COMMON_DXRL
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /DXRL/DRK(MAXRK),QRL(5,MAXRL),NRK(MAXRK),IRL               &
!    &            ,NAD(0:MAXAD)
!     COMMON /NXRL/IRK,IRK0,IOS,IOS0
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      REAL(WP) DRK
!
      INTEGER(EP) N8               !KEEP AS EP (=8) AS TEST FOR OVERFLOW
!
      INTEGER(QP) QRL
      INTEGER(SP) IRL,NAD,IWORD,IRLAST
      INTEGER(SP) MAXRK0,MAXRL0
      INTEGER(SP) IRK,IRK0,IOS,IOS0
!
      INTEGER(EP) NRK,IPLANT_RL           !USE EP (=8) HERE IF REQUESTED
      PARAMETER (IWORD=EP)                !MATCH NRK INTEGER DECLARATION
!
      PARAMETER (MAXRK0=100000)       !MINIMUM STARTING VALUES FOR
      PARAMETER (MAXRL0=  2500)       !RE-ALLOCATION, SUBVERT SMALL USER
!
      ALLOCATABLE :: DRK(:),QRL(:,:),NRK(:),NAD(:),IRLAST(:)
!
      SAVE
!
      END MODULE COMMON_DXRL
!
!                             *******************
!
      MODULE COMMON_DXRLS
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /DXRLS/DRKS(MXRKS),DEKS(MXROS),QRLS(5,MXRLS)               &
!    &             ,NRKS(MXRKS),BFALLS(MXROS),IRKS,IRLS
!     COMMON /XSSADR/IRKS0,IRLS0
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE COMMON_DXRL, ONLY: MAXRK0,MAXRL0
!
      IMPLICIT NONE
!
      LOGICAL(BP) BFALLS
!
      INTEGER(QP) QRLS
      INTEGER(SP) NRKS,IRLS,IRKS
      INTEGER(SP) MXRKS0,MXRLS0
      INTEGER(SP) IRKS0,IRLS0
!
      REAL(WP) DRKS,DEKS
!
      PARAMETER (MXRKS0=MAXRK0)       !MINIMUM STARTING VALUES FOR
      PARAMETER (MXRLS0=MAXRL0)       !RE-ALLOCATION, SUBVERT SMALL USER
!
      ALLOCATABLE :: DRKS(:),DEKS(:),QRLS(:,:),NRKS(:),BFALLS(:)
!
      SAVE
!
      END MODULE COMMON_DXRLS
!
!                             *******************
!
      MODULE COMMON_GENINF
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /GENINF/DADJUS(MXVAR),SCREEN(MAXGR),MION,NZION,NPARAM      &
!    &              ,ITOL,INCLUD,JPRINT
! PLUS JEND(MAXGR) FROM /CRAD/ AKA /CMESH/ AND SCALER FROM /NRBCOW/
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) MION,NZION,NPARAM,ITOL,INCLUD,JPRINT,JEND
!
      ALLOCATABLE :: JEND(:)
!
      REAL(WP) DADJUS,SCREEN
      REAL(WP) SCALER
!
      ALLOCATABLE :: DADJUS(:),SCREEN(:)
!
      SAVE
!
      END MODULE COMMON_GENINF
!
!                             *******************
!
      MODULE COMMON_INTS
!
!-----------------------------------------------------------------------
!
! MODULE (PARTIAL - SEE ALSO COMMON_TFU) REPLACEMENT FOR
!     PARAMETER (MXD09=MXBLM+2)                            !+2 CASE BREL
!     COMMON /TRANS/DRL(MAXRL),DOSC(0:MXD09,MAXGR,MAXGR),TFU(MAXUC)
!
! MODULES COMMON_ACC AND COMMON_REL SHOULD BE MERGED HERE SINCE THEIR
! ARRAYS ALL USE IXD28.
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) IXD09,IXD28,IXD29
!
      INTEGER(SP) IGAUGE
!
      REAL(WP) DRL,DOSC
!
      ALLOCATABLE :: DRL(:),DOSC(:,:)
!
      SAVE
!
      END MODULE COMMON_INTS
!
!                             *******************
!
      MODULE COMMON_JSPOR
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR (REVISED - NTJ,NFJ EX /NRBAL3/)
!     COMMON /JSPOR/NJO,NRR(MAXLV),NT(MAXJG),JN(MAXLV),NGR(MAXLV)       &
!    &             ,NTJ(MAXCF),NFJ(MAXLV)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) NJO,NRR,NLEV,NT,JN,NGR,NTJ,NFJ
      INTEGER(SP) JAXLV
!
      ALLOCATABLE :: NRR(:),NT(:),JN(:),NGR(:)
      ALLOCATABLE :: NTJ(:),NFJ(:)
!
      SAVE
!
      DATA JAXLV/1000000/
!
      END MODULE COMMON_JSPOR
!
!                             *******************
!
      MODULE COMMON_MINIM
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /OUTP2/MPNCH,KUTCAS,XXXX,BPRINT
!     COMMON /NRBCOR/ECOR1,ECOR2,ECORR,ECORRJ,ESKPL,ESKPH,BECOR
!     COMMON /NRBMIX/CMXLSA,CMXLSR,CMXICA,CMXICR,STOLB,XMIX,bnobv
!     COMMON /NRBTCC/TOLTCC,KTCC,MTCC,NTCC,NENERG
!     COMMON /NRBWGT/EIONPOT,EIMXLS,EIMXIC,WLG1,WLG2,IWGHT,IOPTIM,NRSLMX&
!    &              ,JUPMX,JUPMN,JLOWMX,JLOWMN,LUPMX,LUPMN,LLOWMX,LLOWMN&
!    &              ,NMETAR,NMETARJ,NMETAP,NMETAPJ
! N.B. NENERG (USAGE) HERE IS FOR TERMS
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      LOGICAL(BP) BPRINT,BECOR,bnobv
!
      INTEGER(SP) MPNCH,KUTCAS
      INTEGER(SP) KTCC,MTCC,NTCC,NENERG
      INTEGER(SP) IWGHT,IWGHT0,IOPTIM,NRSLMX                            &
     &           ,JUPMX,JUPMN,JLOWMX,JLOWMN,LUPMX,LUPMN,LLOWMX,LLOWMN   &
     &           ,NMETAR,NMETARJ,NMETAP,NMETAPJ
!
      REAL(WP) ECOR1,ECOR2,ECORR,ECORRJ,ESKPL,ESKPH
      REAL(WP) CMXLSA,CMXLSR,CMXICA,CMXICR,STOLB,XMIX
      REAL(WP) TOLTCC
      REAL(WP) EIONPOT,EIMXLS,EIMXIC,WLG1,WLG2
!
      SAVE
!
      END MODULE COMMON_MINIM
!
!                             *******************
!
      MODULE COMMON_MISC
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!
!     COMMON /NRBDIJ/IDIAG
!     COMMON /NRBNAM/NF0,BNAME
!
!     common /hps/badas
!     common /nrbone/ione1,ione0
!     common /nrbtim/iw,iwp,btime,btimex
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
!
      IMPLICIT NONE
!
      LOGICAL(BP) BEIVEC
      LOGICAL(BP) BNAME
      LOGICAL(BP) badas
      LOGICAL(BP) btime,btimex
!
      INTEGER(SP) NF0
      INTEGER(SP) IDIAG,LDIAG
      INTEGER(SP) ione1,ione0
      INTEGER(SP) iw,iwp
!
      SAVE
!
      DATA BEIVEC/.TRUE./
!
      END MODULE COMMON_MISC
!
!                             *******************
!
      MODULE COMMON_MQVC
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /MQVC/MODD,KCUT,QCL0,QCS0,NEL(MAXGR,MAXCF)
! PLUS KMAX FROM /TERMS/ AND /NRBAL1/ TO REMOVE CONFLICT.
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(QP) QCL0,QCS0
      INTEGER(SP) MODD,KCUT,KMAX,NEL,NPLUS1
!
      ALLOCATABLE :: NEL(:,:)
!
      SAVE
!
      END MODULE COMMON_MQVC
!
!                             *******************
!
      MODULE COMMON_NSTS
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     PARAMETER (MXD27=MAXCF*MAXCF)
!     COMMON /NSTS/NADS(-1:MXD27),NSTJ(MXRKS),NSTJD(MXRKS)              &
!    &            ,IORIG(MXRLS),JORIG(MXRLS),JPLANT(MXRLS)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT
!
      ALLOCATABLE :: NADS(:),NSTJ(:),NSTJD(:),IORIG(:),JORIG(:)         &
     &              ,JPLANT(:)
!
      SAVE
!
      END MODULE COMMON_NSTS
!
!                             *******************
!
      MODULE COMMON_NSTS1
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     PARAMETER (MXD27=MAXCF*MAXCF)
!     COMMON /NSTS1/NADS1(0:MXD27),NSTJ1(MXS1C),NSTJ1D(MXS1C)           &
!    &             ,IORIG1(MXS1I),JORIG1(MXS1I)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) NADS1,NSTJ1,NSTJ1D,IORIG1,JORIG1
!
      ALLOCATABLE :: NADS1(:),NSTJ1(:),NSTJ1D(:),IORIG1(:),JORIG1(:)
!
      SAVE
!
      END MODULE COMMON_NSTS1
!
!                             *******************
!
      MODULE COMMON_NSTS2
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     PARAMETER (MXD27=MAXCF*MAXCF)
!     COMMON /NSTS2/NADS2(0:MXD27),NSTJ2(MXS2C),NSTJ2D(MXS2C)           &
!    &             ,IORIG2(MXS2I),JORIG2(MXS2I)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2
!
      ALLOCATABLE :: NADS2(:),NSTJ2(:),NSTJ2D(:),IORIG2(:),JORIG2(:)
!
      SAVE
!
      END MODULE COMMON_NSTS2
!
!                             *******************
!
      MODULE COMMON_QTG
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR (REVISED - NFI,NFK,NFQ EX /TERMS/))
!     COMMON /QTG/MTGD,NXLL,NTT,NTG(0:MAXCF),JTGD(0:MAXCT)              &
!    &           ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT)                      &
!    &                      ,QTGS(MAXCT),QTGL(MAXCT),QTGD(MAXCT)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(QP) QTGS,QTGL,QTGD
      INTEGER(SP) MTGD,NXLL,NTT,NTG,JTGD,NFI,NFK,NFQ,JAXTM
      INTEGER(SP) MAXCT0
!
      PARAMETER (MAXCT0=  10000)    !MINIMUM STARTING VALUE FOR RE-ALLOC
!
      ALLOCATABLE :: NTG(:),JTGD(:),NFI(:),NFK(:),NFQ(:)                &
     &              ,QTGS(:),QTGL(:),QTGD(:)
!
      SAVE
!
      DATA JAXTM/10000000/
!
      END MODULE COMMON_QTG
!
!                             *******************
!
      MODULE COMMON_RADF
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1)         &
!    &            ,DORIG(MAXGR)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) MXPIN
!
      REAL(WP) DPNL,DUY,DX,DORIG
!
      ALLOCATABLE :: DPNL(:,:),DUY(:),DX(:),DORIG(:)
!
      SAVE
!
      END MODULE COMMON_RADF
!
!                             *******************
!
      MODULE COMMON_REL
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /REL/DMASS(MAXGR,MAXGR),DCD(MAXGR,MAXGR),D2LL(MAXGR,MAXGR)
!
! SHOULD BE MERGED WITH MODULE COMMON_INTS
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      REAL(WP) DMASS,DCD,D2LL
!
      ALLOCATABLE :: DMASS(:),DCD(:),D2LL(:)
!
      SAVE
!
      END MODULE COMMON_REL
!
!                             *******************
!
      MODULE COMMON_RELINT
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /EX/DRLP1(MXSOI),DNL(MAXMI)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      REAL(WP) DRLP1,DNL
!
      ALLOCATABLE :: DRLP1(:),DNL(:)
!
      SAVE
!
      END MODULE COMMON_RELINT
!
!                             *******************
!
      MODULE COMMON_TERMS
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR (REVISED)
!     COMMON /TERMS/NSL0,NSL(MAXSL)                                     &
!    &             ,QSI(MAXSL),QLI(MAXSL),QPI(MAXSL)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(QP) QSI,QLI,QPI
      INTEGER(SP) NSL0,NSL
!
      ALLOCATABLE :: NSL(:),QSI(:),QLI(:),QPI(:)
!
      SAVE
!
      END MODULE COMMON_TERMS
!
!                             *******************
!
      MODULE COMMON_TFU
!
!-----------------------------------------------------------------------
!
! MODULE (PARTIAL - SEE ALSO MODULE COMMON_INTS) REPLACEMENT FOR
!     COMMON /TRANS/DRL(:),DOSC(:,:,:),TFU(MAXUC)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      REAL(WP) TFU                      !DEFAULT=WP, BESPOKE=RP
!
      ALLOCATABLE :: TFU(:)
!
      SAVE
!
      END MODULE COMMON_TFU
!
!                             *******************
!
      MODULE COMMON_TRANLS
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!
!     COMMON /TRANLS/NADRU(MAXTM),NAI(MAXTM),NC0,IEORD(MAXTM)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) NADRU,NAI,IEORD                      !,NC0
!
      ALLOCATABLE :: NADRU(:),NAI(:),IEORD(:)
!
      SAVE
!
      END MODULE COMMON_TRANLS
!
!                             *******************
!
      MODULE COMMON_WEIGHT
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!
!     COMMON /WEIGHT/WGHT(MAXTM),INDEXW(MAXTM)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) INDEXW
!
      REAL(WP) WGHT
!
      ALLOCATABLE :: WGHT(:),INDEXW(:)
!
      SAVE
!
      END MODULE COMMON_WEIGHT
!
!                             *******************
!
      MODULE COMMON_NRB
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRB/ACE,MAUTO,MODE,MORT,MGRP,JRAD
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) MAUTO,MODE,MORT,MGRP,JRAD,KORT
!
      REAL(WP) ACE
!
      SAVE
!
      END MODULE COMMON_NRB
!
!                             *******************
!
      MODULE COMMON_NRBAL0
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBAL0/IRET0,LORIG,LMIN,MPRNT0,MOD0,MSTRT0,BPASS,MLIT(2)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) IRET0,LORIG,LMIN,MPRNT0,MOD0,MSTRT0
!
      LOGICAL(BP) BPASS
!
      CHARACTER(LEN=4) MLIT(2)
!
      SAVE
!
      END MODULE COMMON_NRBAL0
!
!                             *******************
!
      MODULE COMMON_NRBAL1
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBAL1/MSTAT(MAXCF),MXORB,NPRINT,MR,MA,MB,KSUBCF  !M*0
!     COMMON /NRBVCX/NFS,KF,NB,JAS,JBS,KSI,KSF,NTGA,NTGB VCU/VCE/VCG
!     COMMON /NRBCOW/XXX,ISCALR
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) MSTAT,MXORB,NPRINT,MR,MA,MB,KSUBCF
      INTEGER(SP) NFS,KF,NB,JAS,JBS,KSI,KSF,NTGA,NTGB
      INTEGER(SP) ISCALR
!
      ALLOCATABLE :: MSTAT(:)
!
      SAVE
!
      DATA MR/-999/                 !was /10/ should no longer be needed
!
      END MODULE COMMON_NRBAL1
!
!                             *******************
!
      MODULE COMMON_NRBAL2
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBAL2/MDEL,MXORBR,MPOL00,MPOL0,MPOLE,MPOLX,CODE
!     COMMON /NRBLAM/MAXLAM,NMULTE,KUTLS
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) MDEL,MXORBR,MPOL00,MPOL0,MPOLE,MPOLX
      INTEGER(SP) MAXLAM0,MAXLAM,NMULTE,KUTLS
!
      PARAMETER (MAXLAM0=20)                       !MAX SLATER MULTIPOLE
!
      CHARACTER(LEN=4) CODE
!
      SAVE
!
      END MODULE COMMON_NRBAL2
!
!                             *******************
!
      MODULE COMMON_NRBAL3
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBAL3/MCFSS,KCFSS(MAXCF),KUTSS,KUTSO,QQCUT
!     COMMON /COMRES/DVC12,ICLRS,ICLRR,BLX        !WATCH NRBAL4 CONFLICT
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      LOGICAL(BP) BLX
!
      INTEGER(QP) QQCUT
!
      INTEGER(SP) MCFSS,KCFSS,KUTSS,KUTSO
      INTEGER(SP) ICLRS,ICLRR
!
      REAL(WP) DVC12
!
      SAVE
!
      ALLOCATABLE :: KCFSS(:)
!
      END MODULE COMMON_NRBAL3
!
!                             *******************
!
      MODULE COMMON_NRBAL4
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBAL4/MBP1MX,MBP2MX,MEKVMX,KUTM1,MPOLM,QCUT
!     COMMON /CMKALG1/DVC12,NC0X,MJS1,MJL1,MJS2,MJL2,MJJL,MJJR          &
!    &       ,NC,ND,ICLR,QLIT(10),BLX1,BLX2,BMSKIP,BOSKIP,BM1BODY
!     COMMON /CMKALG2/DVC,MJ1,MJ2,MLAM,BE1CASE
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      LOGICAL(BP) BLX1,BLX2,BMSKIP,BOSKIP,BM1BODY
      LOGICAL(BP) BE1CASE
!
      INTEGER(QP) QCUT
      INTEGER(QP) QLIT(10)
!
      INTEGER(SP) MBP1MX,MBP2MX,MEKVMX,KUTM1,MPOLM
      INTEGER(SP) NC0X,MJS1,MJL1,MJS2,MJL2,MJJL,MJJR,NC,ND,ICLR
      INTEGER(SP) MJ1,MJ2,MLAM
!
      REAL(WP) DVC12                              !WATCH NRBAL3 CONFLICT
      REAL(WP) DVC
!
      SAVE
!
      END MODULE COMMON_NRBAL4
!
!                             *******************
!
      MODULE COMMON_NRBBBB
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBBBB/BXIST0(MAXCF,MAXCF),BXIST1(MAXCF)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
      LOGICAL(BP) BXIST0,BXIST1
!
      ALLOCATABLE :: BXIST0(:,:),BXIST1(:)
!
      SAVE
!
      END MODULE COMMON_NRBBBB
!
!                             *******************
!
      MODULE COMMON_NRBCAS
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBCAS/AP(MXNOR),MADD(MXNOR)
!     COMMON /NRBTRN/NENERG,JORIG(MAXLV)
! N.B. NENERG (USAGE) HERE IS FOR LEVELS
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      LOGICAL(BP) BCASC
!
      INTEGER(SP) MADD,NENERG,JORIG
!
      REAL(WP) AP
!
      ALLOCATABLE :: AP(:),MADD(:),JORIG(:)
!
      SAVE
!
      END MODULE COMMON_NRBCAS
!
!                             *******************
!
      MODULE COMMON_NRBCAV
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBCAV/ECAVX(MAXCF),ECAV(MAXCF),AJUSTX,ICAV
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) ICAV
!
      REAL(WP) ECAVX,ECAV,AJUSTX
!
      ALLOCATABLE :: ECAVX(:),ECAV(:)
!
      SAVE
!
      END MODULE COMMON_NRBCAV
!
!                             *******************
!
      MODULE COMMON_NRBDEL
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!
!     COMMON /NRBDEL/DELELS(MAXTM,2),DELEIC(MAXLV,2),DELECF(MAXCF,2)    &
!    &              ,EFLG0,EFLGJ0,TOLB,TOLE,ISHFTLS,ISHFTIC             &
!    &              ,NOBS,NOBSJ,MDELE,MULTS
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      LOGICAL(BP) BDELE
!
      INTEGER(SP) ISHFTLS,ISHFTIC,NOBS,NOBSJ,MDELE,MULTS
!
      REAL(WP) DELELS,DELEIC,DELECF,EFLG0,EFLGJ0,TOLB,TOLE
!
      ALLOCATABLE :: DELELS(:,:),DELEIC(:,:),DELECF(:,:)
!
      SAVE
!
      END MODULE COMMON_NRBDEL
!
!                             *******************
!
      MODULE COMMON_NRBDEN
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBDEN/MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY,VSC(MAXB1) &
!    &              ,XC1,XC2,NPITER
!     COMMON /NRBPLS/DENSI(MXD15),DENS(MXD15),TKAYS(MXD15),NDEN
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) MDEN,MP0,NPITER
      INTEGER(SP) NDEN
!
      REAL(WP) DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY,XBEE,VSC,XC1,XC2
      REAL(WP) DENSI,DENS,TKAYS
!
      ALLOCATABLE :: VSC(:)
      ALLOCATABLE :: DENSI(:),DENS(:),TKAYS(:)
!
      SAVE
!
      END MODULE COMMON_NRBDEN
!
!                             *******************
!
      MODULE COMMON_NRBDQE
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBDQE/DQNL(MAXB2,MAXGR)
!     COMMON /NRBEXT/BHFF
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      LOGICAL(BP) BHFF
!
      INTEGER(SP) MXQIN
!
      REAL(WP) DQNL
!
      ALLOCATABLE :: DQNL(:,:)
!
      SAVE
!
      END MODULE COMMON_NRBDQE
!
!                             *******************
!
      MODULE COMMON_NRBDR
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBDR/IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR(MXD12)
!     COMMON /NRBLOO/LNEW,LCON,LSUM,LMAX,lcmin,BLOOP
!     COMMON /NRBNV/MAXNV
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) IXNDR
!
      INTEGER(SP) IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR,NBOUND
      INTEGER(SP) LNEW,LCON,LSUM,LMAX,lcmin
      INTEGER(SP) MAXNV
!
      LOGICAL(BP) BLOOP
!
      ALLOCATABLE :: NDR(:)
!
      SAVE
!
      DATA IXNDR/0/
!
      END MODULE COMMON_NRBDR
!
!                             *******************
!
      MODULE COMMON_NRBDW
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBDW/IDW                                                 &
!    &             ,NASTB,MINSTB,MAXSTB,MINLTB,MAXLTB,LSPIB(MAXSL)      &
!    &             ,NASTJB,MINJTB,MAXJTB,JPIB(MAXJG),MAXLX,MAXJFS       &
!    &             ,LFACT,JFACT,KUTSSX,KUTOOX,MAXLOO                    &
!    &             ,LRGLAM,btop
!     COMMON /NRBOO/XXXXX,KUTOOX,MAXLOO
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      LOGICAL(BP) btop
!
      INTEGER(SP) IDW                                                   &
     &           ,NASTB,MINSTB,MAXSTB,MINLTB,MAXLTB,LSPIB               &
     &           ,NASTJB,MINJTB,MAXJTB,JPIB,LFACT,JFACT                 &
     &           ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO              &
     &           ,NMULTX,MXLAMX,LRGLAM
!
      ALLOCATABLE :: LSPIB(:),JPIB(:)
!
      SAVE
!
      END MODULE COMMON_NRBDW
!
!                             *******************
!
      MODULE COMMON_NRBDW1
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBDW1/MXORB,MR,ma0,mb0
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) MXORB,MR0,ma0,mb0,MSTAT
!
      ALLOCATABLE :: MSTAT(:)
!
      SAVE
!
      DATA MR0/-999/                !was /10/ should no longer be needed
!
      END MODULE COMMON_NRBDW1
!
!                             *******************
!
      MODULE COMMON_NRBDW2
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!                          ,       MGP2(5)       ,
!     COMMON /NRBDW2/LCONDW,MTS,MTSP,MTL,MTLP,MTP,LCONDWJ,MTJ           &
!    &              ,LVMIN,LVMAX
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
!     INTEGER(SP)               MGP2(5)
      INTEGER(SP) LCONDW,MTS,MTSP,MTL,MTLP,MTP,LCONDWJ,MTJ,LVMIN,LVMAX
!
      SAVE
!
      END MODULE COMMON_NRBDW2
!
!                             *******************
!
      MODULE COMMON_NRBDW3
!
!----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBDW3/KACT(MAXCF,MAXCF),KTMP(MAXCF) - NOW LOCAL ALLOCATE
!     COMMON /CMDVC/DVC12,ICLRR,BLX,BEQUALM
!
!----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
!      INTEGER(SP) KACT,KTMP
!!
!      ALLOCATABLE :: KACT(:,:),KTMP(:)
!
      LOGICAL(BP) BLX,BEQUALM
!
      INTEGER(SP) ICLRR
!
      REAL(WP) DVC12
!
      SAVE
!
      END MODULE COMMON_NRBDW3
!
!                             *******************
!
      MODULE COMMON_NRBDW4
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBDW4/DSPECE(MAXTM),INDEX(MAXTM),JNDEX(MAXTM),NSPECE     &
!    &              ,NENERG
! N.B. NENERG (USAGE) HERE IS FOR TERMS, IN THE "DW" BRANCH (EIE/I)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) INDEX,JNDEX,NSPECE,NENERG
!
      REAL(WP) DSPECE
!
      ALLOCATABLE :: DSPECE(:),INDEX(:),JNDEX(:)
!
      SAVE
!
      END MODULE COMMON_NRBDW4
!
!                             *******************
!
      MODULE COMMON_NRBDW5
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBDW5/DYY(MXENG),MENG,NLAG
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) MENG,NLAG
!
      REAL(WP) DYY
!
      ALLOCATABLE :: DYY(:)
!
      SAVE
!
      END MODULE COMMON_NRBDW5
!
!                             *******************
!
      MODULE COMMON_NRBDW6
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBDW6/QPOS(MAXGR),QPOS0(MAXGR)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(QP) QPOS,QPOS0
!
      ALLOCATABLE :: QPOS(:),QPOS0(:)
!
      SAVE
!
      END MODULE COMMON_NRBDW6
!
!                             *******************
!
      MODULE COMMON_NRBDW7
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     PARAMETER MXD06=MXENG*MXENG
!     COMMON /NRBDW7/MNDEX(MXD06,2),MRNDX(MXD06),MTRAN,mlim(mxeng,2)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) MNDEX,MRNDX,MTRAN,mlim
!
      ALLOCATABLE :: MNDEX(:,:),MRNDX(:),mlim(:,:)
!
      SAVE
!
      END MODULE COMMON_NRBDW7
!
!                             *******************
!
      MODULE COMMON_NRBDW8
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBDW8/DYY0(MXENG),IYY0(MXENG),MENG0
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) IYY0,MENG0
!
      REAL(WP) DYY0
!
      ALLOCATABLE :: DYY0(:),IYY0(:)
!
      SAVE
!
      END MODULE COMMON_NRBDW8
!
!                             *******************
!
      MODULE COMMON_NRBDW9
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!
!     COMMON /NRBDW9/DSPECJ(MAXLV),INDXJ(MAXLV),JNDXJ(MAXLV),NSPECJ     &
!    &              ,NENERJ
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) INDXJ,JNDXJ,NSPECJ,NENERJ
!
      REAL(WP) DSPECJ
!
      ALLOCATABLE :: DSPECJ(:),INDXJ(:),JNDXJ(:)
!
      SAVE
!
      END MODULE COMMON_NRBDW9
!
!                             *******************
!
      MODULE COMMON_NRBDWJ
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBDWJ/JSYMM(MXSYJ,MAXJG),NCHGJ(MAXJG),NADGJ(MAXJG)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) JSYMM,NCHGJ,NADGJ,NCHMXJ,NCHSJ
!
      ALLOCATABLE :: JSYMM(:,:),NCHGJ(:),NADGJ(:)
!
      SAVE
!
      END MODULE COMMON_NRBDWJ
!
!                             *******************
!
      MODULE COMMON_NRBDWM
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBDWM/NMETA,NMETAJ,NMETAG(0:MAXSL),NMETGJ(MAXJG)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) NMETA,NMETAJ,NMETAG0,NMETAG,NMETGJ
!
      ALLOCATABLE :: NMETAG(:),NMETGJ(:)
!
      SAVE
!
      END MODULE COMMON_NRBDWM
!
!                             *******************
!
      MODULE COMMON_NRBDWP
!
!-----------------------------------------------------------------------
!
! MODULE FOR CONTINUUM DW POTENTIAL SPECS
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) JENDX,MCFSTOX,NOCCX
!
      REAL(WP) DLAMX
      REAL(WP) DLAMDX,DLAMQX
      REAL(WP) SCALERX
!
      SAVE
!
      END MODULE COMMON_NRBDWP
!
!                             *******************
!
      MODULE COMMON_NRBDWX
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBDWX/LLCH(2,MXCHG,MAXSL),ITARG(MXCHG,MAXSL),NCHG(MAXSL)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) LLCH,ITARG,NCHG,INASTX,NCHMX,MAXLX0
!
      ALLOCATABLE :: LLCH(:,:,:),ITARG(:,:),NCHG(:)
!
      SAVE
!
      END MODULE COMMON_NRBDWX
!
!                             *******************
!
      MODULE COMMON_NRBEKP
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBEKP/NED(2,MAXSL,MAXTM)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) NED
!
      ALLOCATABLE :: NED(:,:,:)
!
      SAVE
!
      END MODULE COMMON_NRBEKP
!
!                             *******************
!
      MODULE COMMON_NRBFL0
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     PARAMETER (MXD02=14)               !MAX TARGET L (NOT X2)
!     PARAMETER (MXD03=MXD02+1)
!     PARAMETER (MXD19=(MAXCF*(MAXCF+1))/2)
!     COMMON /NRBFL0/KINTI(MXSTX),KINTF(MXSTX),KEN2(MXSTX)              &
!    &              ,KPTCFM(-MXD02:MXD03,-MXD02:MXD03,0:MXD19)          &
!    &              ,MPOINT(-MXD02:MXD03,MAXCF),KINT
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) KINTI,KINTF,KEN2,KPTCFM,MPOINT,KINT
      INTEGER(SP) MXSTX0
!
      PARAMETER (MXSTX0=  5000)    !MINIMUM STARTING VALUES FOR RE-ALLOC
!
      ALLOCATABLE :: KINTI(:),KINTF(:),KEN2(:),KPTCFM(:,:,:)            &
     &              ,MPOINT(:,:)
!
      SAVE
!
      END MODULE COMMON_NRBFL0
!
!                             *******************
!
      MODULE COMMON_NRBFSI
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBFSI/DNLI(MXENG,MXFSS),NLI(MAXMI)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      LOGICAL(BP) BNRBFSI
!
      INTEGER(SP) NLI
!
      REAL(WP) DNLI
!
      ALLOCATABLE :: DNLI(:,:),NLI(:)
!
      SAVE
!
      END MODULE COMMON_NRBFSI
!
!                             *******************
!
      MODULE COMMON_NRBGCF
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBGCF/KGSL(MAXCF,MAXSL),KGCF(0:MAXCF),NKSL(MAXSL,MAXCF)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
      INTEGER(SP) KGSL,KGCF,NKSL,KSLX
!
      ALLOCATABLE :: KGSL(:,:),KGCF(:),NKSL(:,:)
!
      SAVE
!
      DATA KSLX/0/
!
      END MODULE COMMON_NRBGCF
!
!                             *******************
!
      MODULE COMMON_NRBGRJ
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBGRJ/NSLJ(MAXSL,MAXJG),NGSLJ(MAXJG)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) NSLJ,NGSLJ
!
      ALLOCATABLE :: NSLJ(:,:),NGSLJ(:)
!
      SAVE
!
      END MODULE COMMON_NRBGRJ
!
!                             *******************
!
      MODULE COMMON_NRBGRP
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBGRP/NGRPI(MAXSL),NADG(MAXSL)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) NGRPI,NADG
!
      ALLOCATABLE :: NGRPI(:),NADG(:)
!
      SAVE
!
      END MODULE COMMON_NRBGRP
!
!                             *******************
!
      MODULE COMMON_NRBIAD
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBIAD/IADD,IADJ,IADJT
! NOTE: IADJT IS DEFINED IN SR.SYMLSJ BUT IS NOT CURRENTLY IN USE
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) IADD,IADJ,IADJT
      INTEGER(EP) IADJ8,NP8
!
      SAVE
!
      END MODULE COMMON_NRBIAD
!
!                             *******************
!
      MODULE COMMON_NRBINT
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBINT/DRLI(MXENG,MXFSL),DYY(MXENG),IYY(MAXGR)            &
!    &              ,NRLI(MAXRL),MENG,NREL,BLAG,BBC2,NLAG,NLAGP
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      LOGICAL(BP) BLAG,BBC2
!
      INTEGER(SP) IYY,NRLI,MENG,NREL,NLAG,NLAGP
!
      REAL(WP) DRLI,DYY
!
      ALLOCATABLE :: DRLI(:,:),DYY(:),IYY(:),NRLI(:)
!
      SAVE
!
      END MODULE COMMON_NRBINT
!
!                             *******************
!
      MODULE COMMON_NRBJ
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBJ/JPI(MAXJG),NJPI(MAXJG),NASTJ,MINJT,MAXJT,NEIGENJ
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) JPI,NJPI,NASTJ,MINJT,MAXJT,NEIGENJ
! NASTJ IN TARGET BECOMES INASTJ IN DW BRANCH: USE INASTJ=>NASTJ
!
      ALLOCATABLE :: JPI(:),NJPI(:)
!
      SAVE
!
      END MODULE COMMON_NRBJ
!
!                             *******************
!
      MODULE COMMON_NRBKUT
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBKUT/KCUTX,LSKUT(MAXSL),NASTK            !KCUT IN /MQVC/
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) KCUTX,LSKUT,NASTK
!
      ALLOCATABLE :: LSKUT(:)
!
      SAVE
!
      END MODULE COMMON_NRBKUT
!
!                             *******************
!
      MODULE COMMON_NRBKUTP
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBKUTP/KCUTP,LSKUTP(MAXSL),NASTKP
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) KCUTP0,KCUTP,LSKUTP,NASTKP
!
      ALLOCATABLE :: LSKUTP(:)
!
      SAVE
!
      END MODULE COMMON_NRBKUTP
!
!                             *******************
!
      MODULE COMMON_NRBLIM
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBLIM/ECNTRB,ITANAL,BANAL(MAXCF)               !ALGEBRAIC
!     COMMON /PJSLIM/ECNTRB,ITANAL                            !ANALYTIC
!
! ECNTRB,ITANAL ARE USED MUTUALLY EXCLUSIVELY IN BOTH BRANCHES. HENCE WE
! USE THE SAME NAMES AND OVERWRITE ANY ALGEB0 VALUE WITH THE MINIM0 READ
! IF BOTH REQUIRED AT SOME POINT THEN "RE-LABEL" ONE AND POINT AS NECESS
! (BANAL IS USED IN BOTH BRANCHES.)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) ITANAL
!
      LOGICAL(BP) BANAL
!
      REAL(WP) ECNTRB
!
      ALLOCATABLE :: BANAL(:)
!
      SAVE
!
      END MODULE COMMON_NRBLIM
!
!                             *******************
!
      MODULE COMMON_NRBLS
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBLS/LSPI(MAXSL),NLSPI(MAXSL),NAST,MINSP,MAXSP           &
!    &             ,MINLT,MAXLT,IPAR,NEIGEN
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) LSPI,NLSPI,NAST,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
! NAST IN TARGET BECOMES INAST IN DW BRANCH: USE INAST=>NAST
!
      ALLOCATABLE :: LSPI(:),NLSPI(:)
!
      SAVE
!
      END MODULE COMMON_NRBLS
!
!                             *******************
!
      MODULE COMMON_NRBLSP
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBLSP/LSPIP(MAXSL,MAXCF),NLSPIP(MAXCF),NASTP             &
!    &              ,MINSTP,MAXSTP,MINLTP,MAXLTP
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) LSPIP,NLSPIP,NASTP,MINSTP,MAXSTP,MINLTP,MAXLTP
!
      ALLOCATABLE :: LSPIP(:,:),NLSPIP(:)
!
      SAVE
!
      END MODULE COMMON_NRBLSP
!
!                             *******************
!
      MODULE COMMON_NRBLSS
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBLSS/NESSH(MAXSL),NASTS,MINSTS,MAXSTS,MINLTS,MAXLTS
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) NESSH,NASTS,MINSTS,MAXSTS,MINLTS,MAXLTS
!
      ALLOCATABLE :: NESSH(:)
!
      SAVE
!
      END MODULE COMMON_NRBLSS
!
!                             *******************
!
      MODULE COMMON_NRBMKP
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBMKP/NMD1(2,MAXJG,MAXLV),NMD2(2,MAXJG,MAXLV)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) NMD1,NMD2
!
      ALLOCATABLE :: NMD1(:,:,:),NMD2(:,:,:)
!
      SAVE
!
      END MODULE COMMON_NRBMKP
!
!                             *******************
!
      MODULE COMMON_NRBNF1
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBNF1/DEK(MXRKO),BFALL(MXRKO)
!     COMMON /NRBOO/KUTOO
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      LOGICAL(BP) BFALL
!
      INTEGER(SP) KUTOO
!
      REAL(WP) DEK
!
      ALLOCATABLE :: DEK(:),BFALL(:)
!
      SAVE
!
      END MODULE COMMON_NRBNF1
!
!                             *******************
!
      MODULE COMMON_NRBNF2
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBNF2/DETA(MXRLO),DXSI(MAXGR,MAXGR),DZL(MXRLO)           &
!    &       ,DXTWO(MXRLO)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      REAL(WP) DETA,DXSI,DZL,DXTWO
!
      ALLOCATABLE :: DETA(:),DXSI(:),DZL(:),DXTWO(:)
!
      SAVE
!
      END MODULE COMMON_NRBNF2
!
!                             *******************
!
      MODULE COMMON_NRBNFI
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBNFI/DZLI(MXENG,MXFOO),DXTWOI(MXENG,MXFOO)              &
!    &              ,DETAI(MXENG,MXFOO),FRI(MAXB1),GRI(MAXB1)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      REAL(WP) DZLI,DXTWOI,DETAI,FRI,GRI
!
      ALLOCATABLE :: DZLI(:,:),DXTWOI(:,:),DETAI(:,:),FRI(:),GRI(:)
!
      SAVE
!
      END MODULE COMMON_NRBNFI
!
!                             *******************
!
      MODULE COMMON_NRBOLP
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     PARAMETER (MXD25=(MAXGR*(MAXGR-1))/2)
!     PARAMETER (MXD26=(MAXCF*(MAXCF-1))/2)
!     COMMON /NRBOLP/OVLPGR(MXD25),OVLPCF(MXD26),IPAIR(MXD26)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) IPAIR
!
      REAL(WP) OVLPGR,OVLPCF
!
      ALLOCATABLE :: OVLPGR(:),OVLPCF(:),IPAIR(:)
!
      SAVE
!
      END MODULE COMMON_NRBOLP
!
!                             *******************
!
      MODULE COMMON_NRBORB
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),ICFGP(MAXCF),IRLX
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) IEQ,IGRCF,ICFGP,IRLX
      INTEGER(SP) MXBORB,MXVORB,MXFORB,NGRP
!
      ALLOCATABLE :: ICFGP(:)   ,IEQ(:),IGRCF(:)
!
      SAVE
!
      END MODULE COMMON_NRBORB
!
!                             *******************
!
      MODULE COMMON_NRBORN
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     PARAMETER (MXD33=(MXGRB*(MXGRB+1))/2)
!     PARAMETER (MXD34=((MXD33+1)*MXD33)/2)
!     PARAMETER (MXD37=MXBLM/2)
!     PARAMETER (MXD39=MXGRB/MAXGR) !=0 (FINITE E) OR 1 (INF. E ONLY)
!                                   !BORN MOM. TRANSFER (K) INFO
!     PARAMETER (NPDEC=4)           !NO. OF K-STEPS PER DECADE
!     PARAMETER (IVV0=3)            !STARTING AT 10**-IVV0
!     PARAMETER (NDEC=IVV0+2)       !NO. OF DECADES (ALLOW K-SHELL)
!     PARAMETER (MXNXV=NDEC*NPDEC+3)     !NO. OF K_MAX (INC ZERO & INF)
!     PARAMETER (MXD21=IVV0*NPDEC-NPDEC/4+3)   !NO. OF K_MIN: UP TO 1.0
!     PARAMETER (MXD38=(1-MXD39)*((MXNXV*(MXNXV-1))/2                   &
!    &                -((MXNXV-MXD21)*(MXNXV-1-MXD21))/2)+MXD39)
!     COMMON /NRBORN/BL(MXD38,MXD34,0:MXD37),OBO(MXD38),TM2(MXD34)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      REAL(WP) BL,OBO,TM2
!
      ALLOCATABLE :: BL(:,:,:),OBO(:),TM2(:)
!
      SAVE
!
      END MODULE COMMON_NRBORN
!
!                             *******************
!
      module common_nrbpar
!
!---------------------------------------------------------------
!
! module replacement for
!     common /nrbpar/niam,liam,jiam,lproc,nprocperl,mapiam
!
!---------------------------------------------------------------
!
      use precsn, only: bp,qp,sp,ep,wp
!
      implicit none
!
      integer(sp) niam,liam,jiam,lproc,nprocperl,mapiam
!
      character(len=1) :: num(0:9)
!
      save
!
      data num/'0','1','2','3','4','5','6','7','8','9'/
!
      end module common_nrbpar
!
!                             *******************
!
      MODULE COMMON_NRBPNT
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBPNT/NTGP(MAXCT),NTGS(MAXCT),NTP1,NTP2
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) NTGP,NTGS,NTP1,NTP2
!
      ALLOCATABLE :: NTGP(:),NTGS(:)
!
      SAVE
!
      END MODULE COMMON_NRBPNT
!
!                             *******************
!
      MODULE COMMON_NRBPOT
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /COM1/DPOT(MAXB1),TOL,MEND
!     COMMON /COM7/ZS0(0:10),ZS(0:10),JZNM
!     COMMON /NRBFOT/DERV(MAXB1),BFOT   (EX-BFOT)
!     COMMON /NRBHAM/POTHAM(MAXB1),MPSEUD
!     COMMON /NRBPOL/ALFD(0:3),RCUT(0:3),ALAV,RCAV,IPOLFN
!     COMMON /NRBPOT/POT(MAXB1,MXPOT),JPOT1
!     COMMON /NRBSPL/DERV1(MAXB1),DERV2(MAXB1)
!     COMMON /NRBZSP/ZESP(MXPOT),IZESP,NWRM
!     COMMON /PARPOT/CPOT(6),XPOT(6),IPOT(6),NPOT
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) MEND
      INTEGER(SP) JZNM
      INTEGER(SP) MPSEUD
      INTEGER(SP) IPOLFN
      INTEGER(SP) JPOT1
      INTEGER(SP) IZESP,NWRM
      INTEGER(SP) IPOT(6),NPOT
!
      REAL(WP) DPOT,TOL
      REAL(WP) ZS0(0:10),ZS(0:10)
      REAL(WP) DERV
      REAL(WP) POTHAM
      REAL(WP) ALFD(0:3),RCUT(0:3),ALAV,RCAV
      REAL(WP) POT
      REAL(WP) DERV1,DERV2
      REAL(WP) ZESP
      REAL(WP) CPOT(6),XPOT(6)
!
      ALLOCATABLE :: DPOT(:)
      ALLOCATABLE :: DERV(:)
      ALLOCATABLE :: POTHAM(:)
      ALLOCATABLE :: POT(:,:)
      ALLOCATABLE :: DERV1(:),DERV2(:)
      ALLOCATABLE :: ZESP(:)
!
      SAVE
!
      END MODULE COMMON_NRBPOT
!
!                             *******************
!
      MODULE COMMON_NRBQED
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBQED/VPINT(MAXGR),SLFINT(MAXGR),QED
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(QP) QED
!
      REAL(WP) VPINT,SLFINT
!
      ALLOCATABLE :: VPINT(:),SLFINT(:)
!
      SAVE
!
      END MODULE COMMON_NRBQED
!
!                             *******************
!
      MODULE COMMON_NRBREL
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /COM7/DNUK0(MXNUK),DNUK1(MXNUK),DNUK2(MXNUK),DNUK(MXNUK)
!     COMMON /NRBNUK/RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0
!     COMMON /NRBREL/IREL,KAPPA,IGAGR,irtard,ibreit,BREL,BJUMPR,BMVD
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) IXNUK
!
      INTEGER(SP) INUKE,INUK,INUK0
      INTEGER(SP) IREL,KAPPA,IGAGR,irtard,ibreit
!
      LOGICAL(BP) BREL,BJUMPR,BMVD,BMVD0
!
      REAL(WP) RNUK,SKIN,ATM,TK0
!
      REAL(WP) DNUK0,DNUK1,DNUK2,DNUK
!
      ALLOCATABLE :: DNUK0(:),DNUK1(:),DNUK2(:),DNUK(:)
!
      SAVE
!
      DATA IXNUK/150/
!
      END MODULE COMMON_NRBREL
!
!                             *******************
!
      MODULE COMMON_NRBRN1
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     PARAMETER (MXD28=(MAXGR*(MAXGR+1))/2)
!     PARAMETER (MXD33=(MXGRB*(MXGRB+1))/2)
!     PARAMETER (MXD34=((MXD33+1)*MXD33)/2)
!     COMMON /NRBRN1/SBL(MXD33),DBL(MXD33,MXBIF)                        &
!    &              ,MB3(0:MXD33),MB4(0:MXD33),INDX(MXD28)              &
!    &              ,INDK(MXD34),INDL(MXD34)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) MB3,MB4,INDX,INDL,INDK,IXD33
!
      REAL(WP) SBL,DBL
!
      ALLOCATABLE :: SBL(:),DBL(:,:),MB3(:),MB4(:)                      &
     &              ,INDX(:),INDK(:),INDL(:)
!
      SAVE
!
      END MODULE COMMON_NRBRN1
!
!                             *******************
!
      MODULE COMMON_NRBRN2
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     PARAMETER (MXD28=(MAXGR*(MAXGR+1))/2)
!     PARAMETER (MXD37=MXBLM/2)
!     COMMON /NRBRN2/BINDB(MXD28,0:MXD37),MENGB
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      LOGICAL(BP) BINDB
!
      INTEGER(SP) MENGB
!
      ALLOCATABLE :: BINDB(:,:)
!
      SAVE
!
      END MODULE COMMON_NRBRN2
!
!                             *******************
!
      MODULE COMMON_NRBRN3
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBRN3/V0(MXNXV),V1(MXNXV),XB(MXNXB),XS(0:MXNXB1)         &
!    &              ,DB0(MXNXV),DB1(MXNXV),OMEGAB(0:MXNXB1)             &
!    &              ,MV0,MV1,XMANT(0:MXNXB1),IEXP(0:MXNXB1),MINFB
!
! ITS PURPOSE IS TO ENSURE A SINGLE SOURCE DEFINITION OF PWB SET-UP
! ACROSS SR.CARATE, SR.DIAGFS AND SR.DIAGON (AND SR.RKINT)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) MV0,MV1,MINFB,MXNXV,MXD21,MXNXB,MXNXB1
      INTEGER(SP) NLAGB,NPDEC,IVV0,NDEC
!
      REAL(WP) V0,V1,XB,XS,DB0,DB1,OMEGAB
!
      CHARACTER(LEN=3) IEXP
      CHARACTER(LEN=5) XMANT
!                               !BORN MOM. TRANSFER (K) INFO
      PARAMETER (NLAGB=4)       !PT LAG, EVEN, CORRELATE WITH NPDEC
      PARAMETER (NPDEC=4)       !NO. OF K-STEPS PER DECADE
      PARAMETER (IVV0=3)        !STARTING AT 10**-IVV0
      PARAMETER (NDEC=IVV0+2)   !NO. OF DECADES (ALLOW K-SHELL)
!
      PARAMETER (MXNXV=NDEC*NPDEC+3)  !NO. OF K_MAX (INC ZERO & INF)
      PARAMETER (MXD21=IVV0*NPDEC-NPDEC/4+3)!NO. OF K_MIN: UP TO 1.0
!
      PARAMETER (MXNXB=10)      !NO. OF PWB X-VALUES (THRESH. UNITS)
      PARAMETER (MXNXB1=MXNXB+1)
!
      DIMENSION V0(MXNXV),V1(MXNXV),XB(MXNXB),XS(0:MXNXB1)              &
     &         ,DB0(MXNXV),DB1(MXNXV),OMEGAB(0:MXNXB1)                  &
     &         ,XMANT(0:MXNXB1),IEXP(0:MXNXB1)
!
      SAVE
!
!      DATA XB(1:MXNXB)/1.001E0_WP,1.1E0_WP,1.2E0_WP,1.3E0_WP,1.55E0_WP
!     &                ,2.E0_WP,3.E0_WP,5.5E0_WP,1.E1_WP,2.E1_WP,3.E1_WP
!     &                ,5.5E1_WP,1.E2_WP,2.E2_WP,3.E2_WP,5.5E2_WP,1.E3/
!                                                               !17-vals
      DATA XB(1:MXNXB)/1.1E0_WP,1.2E0_WP,1.55E0_WP,2.E0_WP,3.E0_WP      &
     &                ,5.5E0_WP,1.E1_WP,2.E1_WP,5.5E1_WP,1.E2_WP/
!                                                               !10-vals
      END MODULE COMMON_NRBRN3
!
!                             *******************
!
      MODULE COMMON_NRBSHF
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBSHF/DSHIFT(MAXGR),MSHIFT,KSHIFT,MKMAX,MXEP
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) MSHIFT,KSHIFT,MKMAX,MXEP
!
      REAL(WP) DSHIFT
!
      ALLOCATABLE :: DSHIFT(:)
!
      SAVE
!
      END MODULE COMMON_NRBSHF
!
!                             *******************
!
      MODULE COMMON_NRBSTO
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBSTO/ALF(MAXGR),TEL(MAXGR),MCFSTO(MAXGR),MC(MAXGR)
!     &                ,MSHELL,MCFMX,MEXPOT,NOCC,NLSTOE,BFIX(MAXGR),BSTO
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      LOGICAL(BP) BFIX,BSTO
!
      ALLOCATABLE :: BFIX(:)
!
      INTEGER(SP) MCFSTO,MC,MSHELL,MCFMX,MEXPOT,NOCC,IOCC,NLSTOE,MXSHLL &
     &           ,NGAPSTO,MEXPOT0,ISTATIC,ifacy
!
      ALLOCATABLE :: MCFSTO(:),MC(:)
!
      REAL(WP) ALF,TEL,faca,facsp,fac_csi,faclam,potx
!
      ALLOCATABLE :: ALF(:),TEL(:),potx(:)
!
      SAVE
!
      DATA MXSHLL/10/                                        !STOPOT DEF
      DATA IOCC/0/
!
      END MODULE COMMON_NRBSTO
!
!                             *******************
!
      MODULE COMMON_NRBTAR
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!
!     COMMON /NRBTAR/ETAR(MAXTM),ISTAR(MAXTM),LTAR(MAXTM),JTAR(MAXTM)   &
!    &              ,NTAR,IGAPE
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) ISTAR,LTAR,JTAR,NTAR,IGAPE
!
      REAL(WP) ETAR
!
      ALLOCATABLE :: ETAR(:),ISTAR(:),LTAR(:),JTAR(:)
!
      SAVE
!
      END MODULE COMMON_NRBTAR
!
!                             *******************
!
      MODULE COMMON_NRBTS1
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR (PLUS DFOTm - could merge M_K with E_K IN DFOT)
!     PARAMETER (MXD24=MXBLM*MAXGR)
!     PARAMETER (MXD37=MXBLM/2)
!     COMMON /NRBTS1/DFOT(MXENG),DFOSS(MXD24,MXENG,2),PMIN              &
!    &              ,NFOSS(0:MXD37,MAXGR,MAXGR),IPIG,IGAG(0:MXENG)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      INTEGER(SP) NFOSS,IPIG,IGAG,IXD24
!
      REAL(WP) DFOT,DFOTm,DFOSS,PMIN
!
      ALLOCATABLE :: DFOT(:),DFOTm(:),DFOSS(:,:,:),NFOSS(:,:,:),IGAG(:)
!
      SAVE
!
      END MODULE COMMON_NRBTS1
!
!                             *******************
!
      MODULE COMMON_NRBVAL
!
!-----------------------------------------------------------------------
!
! MODULE REPLACEMENT FOR
!     COMMON /NRBVAL/FACT(MAXGR),IVAL(MAXGR),NNEW,NNOLD                 &
!    &              ,BJUMP,BJUMP2,BRAD
!     COMMON /NRBRAD/IRAD(MAXGR)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!
      IMPLICIT NONE
!
      LOGICAL(BP) BJUMP,BJUMP2,BRAD,BAUGER
!
      INTEGER(SP) IVAL,NNEW,NNOLD,IRAD
!
      ALLOCATABLE :: IVAL(:),IRAD(:)
!
      REAL(WP) FACT
!
      ALLOCATABLE :: FACT(:)
!
      SAVE
!
      END MODULE COMMON_NRBVAL
!
!                             *******************
!
      module common_nrbtmp
!
!-----------------------------------------------------------------------
!
! module replacement for
!     common /nrbtmp/rnorm(maxgr),ncc0(maxgr),iorb(0:maxgr)
! ncc0 and iorb are purely local now.
!
!-----------------------------------------------------------------------
!
      use precsn, only: bp,qp,sp,ep,wp
!
      implicit none
!
      real(wp) rnorm
!
      allocatable :: rnorm(:)
!
      save
!
      end module common_nrbtmp
!
!                             *******************
!
      module common_nrbuse
!
!-----------------------------------------------------------------------
!
! module replacement for
!     common /nrbuse/buse(mxeng),busi(mxeng,mxeng),btmp(mxeng,mxeng)
!
!-----------------------------------------------------------------------
!
      use precsn, only: bp,qp,sp,ep,wp
!
      implicit none
!
      logical(bp) buguse,buse,busi,btmp
!
      allocatable :: buse(:),busi(:,:),btmp(:,:)
!
      save
!
      data buguse/.false./
!
      end module common_nrbuse
!
!***********************************************************************
!
!-----------------------------------------------------------------------
!
!adas701      SUBROUTINE ASDECK30
!
!-----------------------------------------------------------------------
!
      PROGRAM MAIN
!
!-----------------------------------------------------------------------
!
!  PR.MAIN CONTROLS THE CALCULATION.
!  IT SETS-UP THE NECESSARY FILES AND THEN
!
!  IT CALLS:
!    SR.DEIE
!!    SR.DEII
!    SR.DFACT
!    SR.TARGET
!    SR.ZERO
!
!-----------------------------------------------------------------------
!
!par!                                                               !par
!par      use comm_interface, only : iam,nproc,comm_init,           !par&
!par     &                           comm_barrier,comm_finalize     !par
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_MISC,   ONLY: NF0,BNAME
!
      USE COMMON_NRBDW,  ONLY: IDW
!par!                                                               !par
!par      use common_nrbpar, only: num                              !par
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      CHARACTER(LEN=6) NAM
      CHARACTER(LEN=3) NAM0
!
      LOGICAL BEX                         !INQUIRE REQUIRES DEFAULT KIND
!par!                                                               !par
!par!---------------------------------------------------------------!par
!par!                                                               !par
!par! initialize for parallel                                       !par
!par!                                                               !par
!par!---------------------------------------------------------------!par
!par!                                                               !par
!par      call comm_init()                                          !par
!par      write(mw0,*)'Starting proc', iam                          !par
!
!-----------------------------------------------------------------------
!
! START TIME COUNTER:
!   TIME=ABSOLUTE TIME (MINS)
!   TTIME=RELATIVE TIME (MINS)
!
!-----------------------------------------------------------------------
!
      TTIME=DZERO
      CALL NRB_TIME(TIME)
      TIME=TIME/D60
!
!-----------------------------------------------------------------------
!
! SUMMARY OF FILE/UNIT USAGE
!
!-----------------------------------------------------------------------
!
! NUNIT IS THE MAX UNIT NUMBER IN CURRENT USE
!
! IUNIT KEEPS TRACK OF WHETHER A UNIT HAS BEEN USED OR NOT AND WHETHER
! IT IS CURRENTLY CLOSED OR NOT. TRIVIALLY, IF OPEN, IT IS USED. THUS IT
! IS MORE GENERAL THAN INQUIRE(OPENED=STAT) OR INQUIRE(EXIST=STAT).
! NOTE, A CORRESPONDING (OUTPUT) FILE MAY EXIST FROM A PREVIOUS RUN.
!
      IF(NUNIT.GT.MXD14)THEN
        WRITE(MW0,*)                                                    &
     &            '*** ERROR: UNIT NUMBER TOO LARGE, INCREASE MXD14 TO:'&
     &            ,NUNIT
        NUNIT=0
        NF=-1
        GO TO 100
      ENDIF
      DO I=1,NUNIT                                !INITIALIZE ALL CLOSED
        IUNIT(I)=0
      ENDDO
!
!
! FILES OPENED IN RELEVANT SUBPROGRAM, ONLY IF NEEDED, ARE COMMENTED OUT
! HERE FOR INFO ONLY.
!
!     OPEN(1,FILE='TCC.DAT',STATUS='REPLACE')    ! OPTIONAL TCC'S JAJOM
!     OPEN(2,FILE='CASC',STATUS='REPLACE')    ! OPTIONAL CASCADE COEFFS
!     OPEN(3,FILE='CONFIG.DAT',STATUS='UNKNOWN')     ! OPTIONAL CONFIGS
!     OPEN(4,FILE='TCCDW.DAT',STATUS='REPLACE') ! OPTIONAL TCC'S STGICF
!
! UNIT 5 IS THE READ INPUT DATAFILE, ALL MACHINES
!
!par!                                                               !par
!par      iunit(MR5)=-1                                             !par
!
! UNCOMMENT cpar ABOVE IF *NOT* RE-DIRECTING FROM COMMAND LINE (serial)
!
      IF(IUNIT(MR5).LT.0)THEN
        INQUIRE(FILE='das',EXIST=BEX)
        IF(BEX)THEN
          IUNIT(MR5)=1
          OPEN(MR5,FILE='das',STATUS='OLD')              !STANDARD INPUT
        ELSE
          WRITE(MW0,*)'UNIT5 USER INPUT FILE "das" MISSING, ',          &
     &                'BUT IS REQUIRED!'
          NF=-1
          GO TO 100
        ENDIF
      ENDIF
!
! INQUIRE CHECKS FOR OPTIONAL INPUT FILES, REST MAYBE OUTPUT TO
!
      IUNIT(MW6)=1
      NAM0=''
!par!                                                               !par
!par      i1=iam/100                                                !par
!par      i2=(iam-100*i1)/10                                        !par
!par      i3=iam-100*i1-10*i2                                       !par
!par      nam0=num(i1)//num(i2)//num(i3)                            !par
!par!                                                               !par
      NAM='olg'//NAM0
      OPEN(MW6,FILE=NAM,STATUS='REPLACE')               !STANDARD OUTPUT
!
!     OPEN(MW7,FILE='oca',STATUS='REPLACE')  !CA AA, AR RATES & ENERGIES
!     OPEN(MW7,FILE='ols',STATUS='REPLACE')  !LS AA, AR RATES & ENERGIES
!     OPEN(MW8,FILE='oic',STATUS='REPLACE')  !IC "   "             "
!
      INQUIRE(FILE='hffcin',EXIST=BEX)
      IF(BEX)THEN
        IUNIT(MR9)=1
        OPEN(MR9,FILE='hffcin',STATUS='OLD')  !OPT POT (E.G. HF-FC, FAC)
      ENDIF
      INQUIRE(FILE='potin',EXIST=BEX)
      IF(BEX)THEN
        IF(IUNIT(MR9).EQ.0)THEN
          IUNIT(MR9)=1
          OPEN(MR9,FILE='potin',STATUS='OLD')
                                             !OPT POTS (E.G. HF-FC, FAC)
        ELSE
          WRITE(MW6,*)'FILES "hffcin" AND "potin" BOTH PRESENT, ',      &
     &                'IGNORING THE LATTER...'
          WRITE(MW0,*)'FILES "hffcin" AND "potin" BOTH PRESENT, ',      &
     &                'IGNORING THE LATTER...'
        ENDIF
      ENDIF
!
! SR.ALGEB RESTART FILE
!     OPEN(MRW10,FILE='RESTART',FORM='UNFORMATTED',STATUS='UNKNOWN')
! OR
! SR.ALGX PASS FILE, CASE IDW.NE.0
!     OPEN(MRW10,FORM='UNFORMATTED',STATUS='SCRATCH')
!
      IUNIT(MRW11)=1                         !IDW.NE.0 DWX PASS FILE AND
      OPEN(MRW11,STATUS='SCRATCH',FORM='UNFORMATTED')   !IDW=0 CONT ORBS
!
      INQUIRE(FILE='radwin',EXIST=BEX)
      IF(BEX)THEN
        IUNIT(MR12)=1
        OPEN(MR12,FILE='radwin',STATUS='OLD')    !INPUT BOUND ORBS (OPT)
      ENDIF
!
!     OPEN(MW13,FILE='radout',STATUS='REPLACE') !OUTPUT BOUND ORBS (OPT)
!
!     OPEN(MRW14,FILE='CAVES',STATUS='REPLACE')                !CFG LIST
!     OPEN(MRW14,FILE='TERMS',STATUS='REPLACE')               !TERM LIST
!     OPEN(MRW15,FILE='LEVELS',STATUS='REPLACE')             !LEVEL LIST
!
!     OPEN(MW16,FILE='OVRLAP',STATUS='REPLACE')    !ORBITAL OVERLAP LIST
!
!     OPEN(MW17,FILE='opca',STATUS='REPLACE')   !CA PHOTOIONIZATION DATA
!     OPEN(MW17,FILE='opls',STATUS='REPLACE')   !LS PHOTOIONIZATION DATA
!     OPEN(MW18,FILE='opic',STATUS='REPLACE')   !IC       "         "
!
      INQUIRE(FILE='SHFTLS',EXIST=BEX)          !can use for ca shift...
      IF(BEX)THEN
        IUNIT(MR19)=1
        OPEN(MR19,FILE='SHFTLS',STATUS='OLD')   !TERM ENERGY CORRECTIONS
      ENDIF
!
      INQUIRE(FILE='SHFTIC',EXIST=BEX)
      IF(BEX)THEN
        IUNIT(MR20)=1
        OPEN(MR20,FILE='SHFTIC',STATUS='OLD')  !LEVEL ENERGY CORRECTIONS
      ENDIF
!
!     OPEN(MW21,FILE='adasex.in.form',STATUS='REPLACE') !adasex TEMPLATE
!     OPEN(MW22,FILE='adasexj.in.form',STATUS='REPLACE') !adasexj   "
!
!     OPEN(MRW23,FILE='OMGINFCA',STATUS='REPLACE') !INF. ENERGY OMEGA-CA
!     OPEN(MRW23,FILE='OMGINFLS',STATUS='REPLACE') !INF. ENERGY OMEGA-LS
!     OPEN(MRW24,FILE='OMGINFIC',STATUS='REPLACE') !INF. ENERGY OMEGA-IC
!
!     OPEN(MRW25,FILE='adf04ca',STATUS='REPLACE')  !FIN. ENERGY OMEGA-CA
!     OPEN(MRW25,FILE='adf04ls',STATUS='REPLACE')  !FIN. ENERGY OMEGA-LS
!     OPEN(MRW26,FILE='adf04ic',STATUS='REPLACE')  !FIN. ENERGY OMEGA-IC
!
!     OPEN(MW27,FILE='ocau',FORM='UNFORMATTED',STATUS='REPLACE') !c.f. 7
!     OPEN(MW27,FILE='olsu',FORM='UNFORMATTED',STATUS='REPLACE') !c.f. 7
!     OPEN(MW28,FILE='oicu',FORM='UNFORMATTED',STATUS='REPLACE') !c.f. 8
!
!     OPEN(MW29,FILE='opcau',FORM='UNFORMATTED',STATUS='REPLACE')!c.f.17
!     OPEN(MW29,FILE='oplsu',FORM='UNFORMATTED',STATUS='REPLACE')!c.f.17
!     OPEN(MW30,FILE='opicu',FORM='UNFORMATTED',STATUS='REPLACE')!c.f.18
!
!     OPEN(MRW31,FILE='ITANAL',STATUS='OLD')  !TERM ENERGY CONTRIBUTIONS
!
!     OPEN(MRW32,FILE='DISKDC',FORM='UNFORMATTED',STATUS='XXX')     !FOR
!     OPEN(MRW33,FILE='DSKDMP',FORM='UNFORMATTED',STATUS='XXX')  !DISKDC
!
!par! open(MW34,file='n-mesh.dat',status='replace') !nprocperl.gt.1 !par
!
! IN ADDITION, UNIT=80,81,82,... ARE RESERVED FOR LOCAL SCRATCH FILES.
! THEY ARE NOT FLAGGED BY IUNIT SINCE THEY EXIST ONLY IN A SUBPROGRAM
! AND MUST-BE/ARE CLOSED BEFORE RETURN.
!
!-----------------------------------------------------------------------
!
! SR.ZERO PRINTS DIMENSIONS FOR THIS RUN
!
!-----------------------------------------------------------------------
!
      CALL ZERO
!
!-----------------------------------------------------------------------
!
! SR.DFACT PRE-CALCULATES ALL POSSIBLE FACTORIALS
!
!-----------------------------------------------------------------------
!
      CALL DFACT
!
!-----------------------------------------------------------------------
!
! SR.TARGET DESCRIBES BOTH BOUND-BOUND AND BOUND-CONTINUUM PROBLEMS,
! TREATING THE LATTER AS AN (N+1)-ELECTRON STRUCTURE PROBLEM.
!
!-----------------------------------------------------------------------
!
      CALL TARGET(TIME,TTIME)
!
      if(nf.ne.nf0)write(mw0,*)'nf,nf0=',nf,nf0
      IF(NF.LE.0.OR.NF0.LT.0)GO TO 100
!
!-----------------------------------------------------------------------
!
! SR.DEIE DESCRIBES DIRECT ELECTRON-IMPACT EXCITATION
!
!-----------------------------------------------------------------------
!
      IF(ABS(IDW).EQ.1)CALL DEIE(TIME,TTIME)
!
!-----------------------------------------------------------------------
!
! SR.DEII DESCRIBES DIRECT ELECTRON-IMPACT IONIZATION (PLACEHOLDER)
!
!-----------------------------------------------------------------------
!
!      IF(ABS(IDW).EQ.2)CALL DEII(TIME,TTIME)
!
!-----------------------------------------------------------------------
!
  100 CONTINUE
!
!-----------------------------------------------------------------------
!
! SR.DFACT - CLEAR FACTORIAL ARRAY
!
!-----------------------------------------------------------------------
!
      DEALLOCATE(DFS,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'MAIN: DE-ALLOCATION FAILS FOR DFS'
        IF(NF.GT.0)NF=0
      ENDIF
!
!-----------------------------------------------------------------------
!
! SR.ZERO PRINTS STORAGE USED FOR THIS RUN
!
!-----------------------------------------------------------------------
!
      CALL ZERO
!
!-----------------------------------------------------------------------
!
! CLOSE-OFF ANY UNITS STILL OPEN (I.E. GLOBAL FILES)
!
!-----------------------------------------------------------------------
!
      DO I=1,NUNIT
        IF(IUNIT(I).GT.0)THEN
          CLOSE(I)
          IUNIT(I)=-1
        ENDIF
      ENDDO
!par!                                                               !par
!par!---------------------------------------------------------------!par
!par!                                                               !par
!par! finish-up parallel                                            !par
!par!                                                               !par
!par!---------------------------------------------------------------!par
!par!                                                               !par
!par      write(mw0,*)'Ending proc', iam                            !par
!par      call comm_barrier()                                       !par
!par      call comm_finalize()                                      !par
!par!                                                               !par
!par!---------------------------------------------------------------!par
!
      IF(NF.LT.0)THEN                                      !.OR.NF0.Lt.0
!par        if(iam.eq.0)then                                        !par
        iu=nunit+1
        open(iu,file='errlog')
        rewind(iu)
        write(iu,*)'ERROR: SOMETHING BAD HAPPENED...'
!        if(nf.eq.0)write(iu,*)'DE/ALLOCATION FAILURE'
        if(nf.lt.0)write(iu,*)' !!! ABNORMAL END - SEE OLG FILE ): !!!'
        close(iu)
!par        endif                                                   !par
        STOP ' !!! ABNORMAL END - SEE OLG FILE ): !!!'
      ELSE
!        STOP !' (: *** NORMAL END *** ' !COMMENT-OUT FOR SILENT SUCCESS
      ENDIF
!
!-----------------------------------------------------------------------
!
!adas701      RETURN
!
!-----------------------------------------------------------------------
!
!adas701      END SUBROUTINE ASDECK30
!
!-----------------------------------------------------------------------
!
      END PROGRAM MAIN
!ADAS!
!ADAS!                             *******************
!ADAS!
!ADAS      function adasip(elemu,iz1)
!ADAS!
!ADAS!------------------------------------------------------------------
!ADAS! get ionisation potential for arbitrary ionisation stage
!ADAS!
!ADAS! the user must have a valid ADASCENT environment variable set.
!ADAS!
!ADAS! compile and link :
!ADAS!       f95 adasip.for -L/home/adas/lib -ladaslib
!ADAS!------------------------------------------------------------------
!ADAS!
!ADAS      use common_misc,   only: badas
!ADAS!
!ADAS      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!ADAS!
!ADAS!------------------------------------------------------------------
!ADAS!
!ADAS      implicit none
!ADAS!
!ADAS      INTEGER(SP) iz1,i,L1,L2
!ADAS!
!ADAS      REAL(WP) adasip,fip
!ADAS!
!ADAS      character(len=2) elem,esym,elemu
!ADAS      character(len=30) adascent
!ADAS      character(len=120) dsfull
!ADAS!
!ADAS!------------------------------------------------------------------
!ADAS!
!ADAS      badas=.true.
!ADAS!test
!ADAS!      elemu='FE'
!ADAS!      iz1=13
!ADAS!
!ADAS      call xxcase(elemu,elem,'LC')               !  for lowercase
!ADAS!
!ADAS      call get_environment_variable("ADASCENT",adascent)
!ADAS!
!ADAS!---------------------hps 19 Aug 2011 -----------------------------
!ADAS!       adascent='/home/hps/adas_dev/adas'
!ADAS!------------------------------------------------------------------
!ADAS!
!ADAS      do i=len(adascent),1,-1
!ADAS        if(adascent(i:i).NE.' ')go to 20
!ADAS      enddo
!ADAS  20  L1=i
!ADAS      do i=len(elem),1,-1
!ADAS        if(elem(i:i).NE.' ')go to 30
!ADAS      enddo
!ADAS  30  L2=i
!ADAS!
!ADAS      dsfull=adascent(1:L1)//'/adf00/'//elem(1:L2)//'.dat'
!ADAS!
!ADAS      open(unit=99,file=dsfull)
!ADAS!
!ADAS      read(99,'(A)')esym      ! skip line 1
!ADAS      do i=1,iz1            ! skip lines up to stage of interest
!ADAS        read(99,'(A)')esym
!ADAS      enddo
!ADAS      read(99,*)i,fip
!ADAS!
!ADAS      adasip=fip*8066.0693
!ADAS!
!ADAS!test      write(mw0,*)'Ionisation potential: ',adasip
!ADAS!
!ADAS      close(99)
!ADAS!
!ADAS      end function adasip
!                                                                  !ADAS
!                             *******************                  !ADAS
!                                                                  !ADAS
      function adasip(elemu,iz1)                                   !ADAS
!                                                                  !ADAS
!------------------------------------------------------------------!ADAS
!                                                                  !ADAS
! dummy routine for normal (non-ADAS) useage.                      !ADAS
!                                                                  !ADAS
!------------------------------------------------------------------!ADAS
!                                                                  !ADAS
      use common_misc,   only: badas                               !ADAS
!                                                                  !ADAS
      USE PRECSN, ONLY: BP,QP,SP,EP,WP                             !ADAS
      USE PARAM                                                    !ADAS
      USE UTILITY                                                  !ADAS
      USE CONSTANTS                                                !ADAS
!                                                                  !ADAS
!------------------------------------------------------------------!ADAS
!                                                                  !ADAS
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)                            !ADAS
      IMPLICIT LOGICAL(BP) (B)                                     !ADAS
      IMPLICIT INTEGER(SP) (I-N)                                   !ADAS
      IMPLICIT INTEGER(QP) (Q)                                     !ADAS
!                                                                  !ADAS
!      INCLUDE './INCLUDE'                                         !ADAS
!                                                                  !ADAS
      character(len=2) elemu,cdum                                  !ADAS
!                                                                  !ADAS
      badas=.false.                         !.true. for test       !ADAS
!                                                                  !ADAS
! suppress compiler warnings (sigh...)                             !ADAS
!                                                                  !ADAS
      cdum=elemu                                                   !ADAS
      idum=iz1                                                     !ADAS
!                                                                  !ADAS
      adasip=dzero                                                 !ADAS
!                                                                  !ADAS
      return                                                       !ADAS
!                                                                  !ADAS
      end function adasip                                          !ADAS
!
!                             *******************
!
      SUBROUTINE ALGEB(IRET)
!
!-----------------------------------------------------------------------
!
!  SR.ALGEB CONTROLS THE ALGEBRAIC BRANCH, INCLUDING RESTART FACILITY.
!
!  NOTE: ANGULAR QUANTUM NUMBERS WILL BE INTERNALLY STORED AS TWICE
!  THEIR VALUE; THIS ALLOWS FOR INTEGER NOTATION AND MEETS THE
!  REQUIREMENTS OF THE COPENHAGEN PACKAGE OF ANGULAR SUBROUTINES.
!
!  IT IS CALLED BY:
!    SR.TARGET
!
!  IT CALLS:
!    SR.ALGEB0
!    SR.ALGEB1
!    SR.ALGEB2
!    SR.ALGEB3
!    SR.ALGEB4
!    SR.CALGEB
!    SR.DIMUSE
!    SR.DISKDC
!    SR.NRB_TIME
!    SR.REDSS
!    SR.VCU
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam                            !par
!
      USE COMMON_ALGEB,  ONLY: MPRINT
      USE COMMON_ALGEB,  ONLY: IWRK1,IWRK2
      USE COMMON_ALGEB,  ONLY: MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD     &
     &                        ,KFBUFF
      USE COMMON_ALGEB,  ONLY: BFANO
      USE COMMON_ALGEB,  ONLY: BFOT
!!      COMMON /BASIC/NF,MGAP1(5),MSST,MGAP2(5)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,IBSK2=>IBSK2,IBSK3=>IBSK3,IBSK4=>IBSK4,IBSK5=>IBSK5&
     &              ,IBSK6=>IBSK6,MSST=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9 &
     &              ,IBSK10=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_CFCT,   ONLY: VCA,VCB,MXLL,MAXLL0,MAXLL1,BVC,BDLBD
      USE COMMON_COEFF,  ONLY: DRKP,QRLP,IRLP,NRKP,NADP,IPLANT_SOI      &
     &                        ,MXSOC0,MXSOI0
      USE COMMON_COEFF,  ONLY: IRKP,IRKP0
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY,QCGS
      USE COMMON_DC,     ONLY: BFAST,DC,IDC,IXIDC,LREC,IREC             &
     &                        ,MAXDC0,MXST00
      USE COMMON_DMQSS3, ONLY: DSS,MSS,QSS,NADR,IPLANT_MI               &
     &                        ,MAXMI0,MXRSS0
      USE COMMON_DMQSS3, ONLY: IRS,IRS0,NL,NL000
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL,NAD
      USE COMMON_DXRL,   ONLY: IRK,IRK0,IOS,IOS0
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR,NTJ,NFJ
      USE COMMON_MISC,   ONLY: IDIAG
      USE COMMON_MISC,   ONLY: NF0,BNAME
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_QTG,    ONLY: MTGD,NXLL,NTT,NTG,JTGD,QTGS,QTGL,QTGD    &
     &                        ,NFI,NFK,NFQ,MAXCT0
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      use common_misc,   only: iw,iwp,btime,btimex
!
      USE COMMON_NRBAL0, ONLY: IRET0,LORIG,LMIN,MPRNT0,MOD0,MSTRT0,BPASS&
     &                        ,MLIT
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL1, ONLY: NFS,KF,NB,JAS,JBS,KSI,KSF,NTGA,NTGB
      USE COMMON_NRBAL1, ONLY: ISCALR
      USE COMMON_NRBAL2, ONLY: MDEL,MXORBR,MPOL00,MPOL0,MPOLE,MPOLX,CODE
      USE COMMON_NRBAL2, ONLY: MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBAL3, ONLY: MCFSS,KCFSS,KUTSS,KUTSO,QQCUT
      USE COMMON_NRBAL4, ONLY: MBP1MX,MBP2MX,MEKVMX,KUTM1,MPOLM,QCUT
      USE COMMON_NRBDR,  ONLY: IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR
      USE COMMON_NRBDR,  ONLY: LNEW,LCON,LSUM,LMAX,lcmin,BLOOP          &
     &                        ,MAXNV
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,NASTB,MINSTB,MAXSTB,MINLTB,MAXLTB,LSPIB  &
     &                        ,NASTJB,MINJTB,MAXJTB,JPIB,LFACT,JFACT    &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG0,NMETAG,NMETGJ
      USE COMMON_NRBEKP, ONLY: NED
      USE COMMON_NRBGCF, ONLY: KGSL,KGCF,NKSL,KSLX
      USE COMMON_NRBGRJ, ONLY: NSLJ,NGSLJ
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBIAD, ONLY: IADD,IADJ,IADJ8,NP8
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,NASTJ                           &
     &                        ,MINJT,MAXJT,NEIGENJ
      USE COMMON_NRBKUT, ONLY: KCUTX,LSKUT,NASTK
      USE COMMON_NRBKUTP,ONLY: KCUTP,LSKUTP,NASTKP
      USE COMMON_NRBLIM, ONLY: ECNTRB,ITANAL,BANAL
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,NAST                          &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBLSS, ONLY: NESSH,NASTS,MINSTS,MAXSTS,MINLTS,MAXLTS
      USE COMMON_NRBLSP, ONLY: LSPIP,NLSPIP,NASTP                       &
     &                        ,MINSTP,MAXSTP,MINLTP,MAXLTP
      USE COMMON_NRBMKP, ONLY: NMD1,NMD2
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBNF2, ONLY: DETA,DXSI,DZL,DXTWO
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX                     &
     &                        ,MXBORB,MXVORB,MXFORB,NGRP
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBRN2, ONLY: BINDB,MENGB
!par!                                                               !par
!par      use common_nrbpar, only: niam,liam,jiam,mapiam            !par&
!par     &                        ,lproc,nprocperl                  !par
!par      use common_nrbpar, only: num                              !par
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,IBUFF4
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (IRL5=6)                        !5+1 NOW ALG3/4 SEPARATE
!
      CHARACTER(LEN=2) NAME0
      CHARACTER(LEN=9) NAME
!
      LOGICAL BEX                         !INQUIRE REQUIRES DEFAULT KIND
!
      ALLOCATABLE :: MAM(:),NAM(:),QLMC(:),QLMS(:),QBML(:),QBMS(:)
!
      ALLOCATABLE :: JYI(:),JYF(:)
!
!-----------------------------------------------------------------------
!
      bpar=.false.
!par      bpar=.true.                                               !par
!par!                                                               !par
!
!      if(btime)                         !btime not initialized yet
      call nrb_time(time0)
!
!      QBMS(1)=2                         !NO LONGER USED (AS I*2)
!      QBML(1)=0                         !NO LONGER USED (AS I*2)
!
      MSTART=0                                       !to silence ftnchek
      MXMTGD=3*2**26                    !MAX REC LEN FOR DC ARRAY (<2GB)
      MXMTGD=MXMTGD*(8/LREC)            !NECESS FOR PGI, BUT ORACLE FINE
!***
      QQCUTX=1                          !TBD (OR COULD USE TARGET QQCUT)
!***
!
! SET NEW L FOR L-LOOP, OR RETURN AND EXIT
!
      IF(BLOOP)THEN
        LSUM=LSUM+1
        IF(LNEW.LT.LMAX)REWIND(MR5)              !REWIND USER INPUT FILE
        IF(LNEW.EQ.LMAX)LSUM=0
        IF(LNEW.EQ.LMAX)THEN
          IF(IUNIT(MRW10).GT.0)THEN                       !CLOSE RESTART
            IUNIT(MRW10)=-1
            CLOSE(MRW10)                                     !idw=0 here
          ENDIF
          IF(BNAME)THEN
            IRET=1
            RETURN
          ENDIF
        ENDIF
      ENDIF
!
      NF0=0
!
! READ USER INPUT, AND SET-UP ACCORDINGLY.
!   IRET=1 SIGNALS A TERMINATOR AND SO FLAGS EXIT WITHOUT CALL TO MINIM
!
!***********************************************************************
!
      CALL ALGEB0(DC0,MAXEL)                                        !-0-
!
!***********************************************************************
!
      if(.not.btime.and.btimex)then
!par!       if(iam.eq.0)then                                        !par
        write(iw,*)'Starting target'
!par!       endif                                                   !par
      endif
!
      IF(NF.LE.0)GO TO 1800
!
      IRET=IRET0
      IF(IRET.EQ.1)GO TO 2000                   !RETURN
!
! SCRATCH
!
      REWIND(MRW11)
!
!-----------------------------------------------------------------------
!
! EX-COMMON/DBD2/
      IXEL0=MAXEL               !MAXEL=NF+1 CASE DW, FOR HISTORIC COMMON
      ALLOCATE(QCP(KMAX),QCG(IXEL0,KMAX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR QCP,QCG'
        GO TO 2300
      ENDIF
!
      CALL DIMUSE('MXEL0',IXEL0)
!
!-----------------------------------------------------------------------
!
! CONFIGURATION-AVERAGE ALGEBRA BRANCH, BYPASS REST OF ALGEB ON RETURN
!
!-----------------------------------------------------------------------
!
      IF(NSL0.LT.0)THEN                         !CONFIGURATION AVERAGE
!
        CALL CALGEB(MAXEL)
!
        IF(NF.LE.0)GO TO 1800
        GO TO 2000                              !RETURN
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! T-TERM SELECTION
!
! EX-COMMON/NRBLIM/    (NEED ALWAYS AS INITIALIZED TO .F. FOR SR DIAGON)
      ALLOCATE(BANAL(KMAX),STAT=IERR)      !RE-ALLOC AS MINIM DE-ALLOCS
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR BANAL'
        GO TO 2300
      ENDIF
!
      IF(ITANAL.NE.0)THEN                         !WANTED,
!
        IF(IUNIT(MRW31).EQ.0)THEN                 !BUT NOT YET OPENED
          INQUIRE(FILE='ITANAL',EXIST=BEX)
          IF(BEX)THEN
            OPEN(MRW31,FILE='ITANAL',STATUS='OLD')
            IUNIT(MRW31)=1
          ELSE
            WRITE(MW0,*)'USER INPUT ITANAL REQUIRES FILE "ITANAL", ',   &
     &                  'BUT NOT FOUND!'
            WRITE(MW6,*)'USER INPUT REQUIRES FILE "ITANAL", ',          &
     &                  'BUT NOT FOUND: ITANAL=',ITANAL
            GO TO 2200
          ENDIF
        ELSEIF(IUNIT(MRW31).GT.0)THEN              !FOR L-LOOP
          REWIND(MRW31)
        ENDIF
!
      ENDIF
!
! INITIALIZE FOR RESTART
!
      BDLBD=.FALSE.                      !INIT FOR RESTART=3
      MST5=MOD(MSTRT0,IRL5)
      BSTART=(MST5.EQ.0.OR.MPRINT.LT.-3).AND.IDW.EQ.0
      IF(MST5.NE.0)BPASS=.FALSE.         !ENABLE PARTIAL RESTART-1,2,3,4
!                                        !.T. REDUCES I/O BUT NEGLIGIBLE
!-----------------------------------------------------------------------
!
! LOCAL
      IF(MST5.NE.5)ALLOCATE(JYI(KMAX),JYF(KMAX))    !IF 5 THE ALGEB DONE
!
!-----------------------------------------------------------------------
!
! INITIAL DISKDC STORAGE
!
      BDISK=MOD(KUTDSK,I10000).LT.KMAX.AND.MST5.NE.5   !IF 5, ALGEB DONE
      IF(BDISK)THEN
        IUD=MRW32                               !DISKDC
        MDCF8=0
        MDCFT8=0
      ENDIF
      MDCBUF=0                                  !BEST NOT UNDEFINED
!
      IF(BSTART)GO TO 400                       !<----- NO RESTART -----
!
      IF(IUNIT(MRW10).EQ.0)THEN                    !RESTART FILE
        if(idw.eq.0)then
          NAME0=''
!par!                                                               !par
!par          j1=liam/10                                            !par
!par          j2=liam-(10*(liam/10))                                !par
!par          name0=num(j1)//num(j2)                                !par
!par!                                                               !par
          NAME='RESTART'//NAME0
          INQUIRE(FILE=NAME,EXIST=BEX)
!
          IF(ABS(MST5).EQ.1)THEN
            OPEN(MRW10,FILE=NAME,FORM='UNFORMATTED',STATUS='REPLACE')
            IF(.NOT.BEX)LORIG=LMIN
          ELSE
            IF(BEX)THEN
              OPEN(MRW10,FILE=NAME,FORM='UNFORMATTED',STATUS='OLD')
            ELSE
              WRITE(MW0,*)'USER INPUT MSTART REQUIRES FILE "RESTART", ',&
     &                    'BUT NOT FOUND!'
              WRITE(MW6,*)'USER INPUT REQUIRES FILE "RESTART", ',       &
     &                    'BUT NOT FOUND: MSTART=',MSTRT0
              GO TO 2200
            ENDIF
          ENDIF
        else
          OPEN(MRW10,FORM='UNFORMATTED',STATUS='SCRATCH')
          BEX=.TRUE.
        endif
        IUNIT(MRW10)=1
        IF(BEX)REWIND(MRW10)
      ENDIF
!
      IF(IDW.EQ.0.and.mstrt0.ne.5.and..not.bpar)THEN
        WRITE(MW0,*)                                                    &
     &           '** NOTE: MSTART=5 RESTARTS A COMPLETED ALGEBRA RUN **'
        WRITE(MW6,*)                                                    &
     &           '** NOTE: MSTART=5 RESTARTS A COMPLETED ALGEBRA RUN **'
      ENDIF
!
      GO TO 200
!
! WRITE RESTART INFO AFTER EVERY CALL TO ALGEBN, N=1,2,3,4
!
  100 WRITE(MW6,10050)MLIT,MSTRT0
!
! enable RESTART to be read anew during existing calc. else
!      call flush(MRW10)                !f2003
!
      IF(ABS(MSTRT0).GE.IRL5)THEN      !EXIT AFTER ONE STAGE
        IF(LMAX.GT.LMIN)THEN
          WRITE(MW0,*)'*** WARNING: CAN/HAVE ONLY RUN ONE L-PER-PROC',  &
     &                ' FOR MSTART=',MSTRT0
          WRITE(MW6,*)'*** WARNING: CAN/HAVE ONLY RUN ONE L-PER-PROC',  &
     &                ' FOR MSTART=',MSTRT0
!par!                                                               !par
!par      write(mw0,*)'*** Aborting parallel run for (your) safety!'!par
!par      go to 5000                                                !par
!par!                                                               !par
        ENDIF
!
        CALL DIMUSE('MAXTM',NTT)      !NOT STRICTLY SO, BUT GIVES ACTUAL
!
        NF=0                       !RUN O.K. BUT NEED TO EXIT GRACEFULLY
        GO TO 1900
      ENDIF
!
      MSTRT0=MSTRT0+MSTRT0/MSTART
      IF(MSTRT0.LT.0)THEN               !REWIND AND RE-READ AT EACH STEP
        IF(BLOOP)THEN                !NEED TO BACKSPACE APPROPRIATE NREC
          WRITE(MW6,*)'*** ERROR: CANOT USE MSTART.LT.0 WITH L-LOOP'
          WRITE(MW0,*)'*** ERROR: CANOT USE MSTART.LT.0 WITH L-LOOP'
          GO TO 2200
        ENDIF
        REWIND(MRW10)
        GO TO 200
      ENDIF
!
      IF(MSTART.EQ.1)GO TO 800          !<--------------- RESTART SWITCH
      IF(MSTART.EQ.2)GO TO 1000         !<--------------- RESTART SWITCH
      IF(MSTART.EQ.3)GO TO 1200         !<--------------- RESTART SWITCH
      IF(MSTART.GT.3)GO TO 1700         !<--------------- RESTART SWITCH
!
  200 CONTINUE
!
! LORIG IS FIRST L FOR WHICH RESTART ALGEBRA WAS WRITTEN (=LMIN DEFAULT)
! LMIN  IS FIRST L FOR WHICH RESTART ALGEBRA IS TO BE READ
!
      IF(BLOOP.AND.LSUM.EQ.0.AND.LMIN.NE.LORIG)THEN
        IF(LMIN.LT.LORIG)THEN
          WRITE(MW6,10060)LORIG,LMIN
          WRITE(MW0,*)'ERROR IN RESTART ALGEBRA L-LOOP'
          GO TO 2200
        ENDIF
!
! PARTIAL ALGEBRA RUNS CANNOT BE HANDLED BY L-LOOP, I.E. ONLY MSTART=1,5
!        IF(MSTART.GT.1.AND.MSTART.LT.5)THEN
!          WRITE(MW6,*)'RESTART ERROR: NEED LMIN=LORIG FOR MSTART=2,3,4'
!          WRITE(MW0,*)'RESTART ERROR: NEED LMIN=LORIG FOR MSTART=2,3,4'
!          GO TO 995
!        ENDIF
! should be handled minimally by preceding two tests on MSTRT0...
!
        READ(MRW10)MLIT,MXORB,NW,NF,MODD      !IN CASE IC NOW OFF
        BACKSPACE(MRW10)
        IF(ABS(MODD).GT.1)THEN             !LS WAS WRITTEN
          LREC5=1
        ELSE                               !IC WAS WRITTEN
          LREC5=7
        ENDIF
        LREC3=6
!
        NREC=1+1+LREC3+1+LREC5+1+1
        MRD=NREC*(LMIN-LORIG)
        DO M=1,MRD
          READ(MRW10,END=250)
        ENDDO
        GO TO 300
  250   WRITE(MW6,*)'*** ATTEMPT TO READ PAST END OF RESTART FILE...'
        WRITE(MW0,*)'*** ATTEMPT TO READ PAST END OF RESTART FILE...'
        GO TO 2200
      ENDIF
!
  300 MSTART=MOD(ABS(MSTRT0),IRL5)
!
      IF(MSTART.GT.1)GO TO 700          !<--------------- RESTART SWITCH
!
  400 MSTART=1
!
! USE DIMENSION CHECK MODE TO GET NUMBER OF TERMS AND SLATER-STATES
! MAX "BUFFER" DIMENSION REQUIRED FOR THIS IS PER CONFIGURATION.
! SLATER-STATES MEMORY RE-ALLOCATED IF NEED BE BUT, CURRENTLY, TERMS NOT
!
      if(btime)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Starting proc',iam,' for vcu dimensions'  !par
!par        else                                                    !par
        write(iw,*)'Starting vcu dimensions'
!par        endif                                                   !par
        if(bloop)write(iw,*)'l=',lnew
        call nrb_time(timei)
      endif
!
      MPRNT0=MPRINT
      MPRINT=-3
      MOD0=MODD
      IF(IDW.NE.0)MODD=0
!
! temp; if selection used then ixst0 can be too small for vcg buffer, so
      kcut0=kcut
      kcutp0=kcutp
      nastp0=nastp
      nast0=nast
      nastj0=nastj
      nasts0=nasts
      kcut=0
      kcutp=0
      nastp=0
      nast=0
      nastj=0
      nasts=0
! if this generates too large an ixst0, then use mstart=7 to exit after
! call algeb1 and restart with mstart=8. this uses exact/minimum ixst0
! for algeb2,3,4.
!
!-----------------------------------------------------------------------
!
! ALLOCATES FOR VCU DIMENSION RUN
!
      IAXCT=MAX(MAXCT0,MAXCT,IAXCT)                !USE LARGEST PREVIOUS
!      IAXCT=MAX(MAXCT0,MAXCT)                      !RESET
      IAXTM=0                 !COUNT TERMS (N.B. SR.VCU DOES NOT BUFFER)
!
      KSLX=0  !COUNT MAX POSSIBLE SL GROUPS OF A CONFG, I.E. LOCAL IAXLS
!
! LOCAL
      IAXDC=1
      IXIDC=1
      ALLOCATE(DC(0:IAXDC),IDC(IXIDC))                            !SMALL
      DC(0)=DZERO
!
! EX-COMMON/NRBVCX/
      ALLOCATE(QCGS(IXEL0))                              !FOR VCU, SMALL
!
! MAKE BEST USE OF ARRAYS QLMC,QLMS(MAXEL,MAXST) - OPTIMIZE MAXST.
!
!old      MAXST=MXEST
!old      IF(MAXEL.GT.0)MAXST=MAXST/MAXEL
!old      IF(MAXST.GT.MXST0)MAXST=MXST0
!
! historically, user could inflate mxst0 but be bounded by mxest.
! now, with allocate, and knowing maxel, we should use mxest=maxel*mxst0
! internally, since the interplay of mxest/mxst0/maxel is unknown to
! users, but need to safeguard against any historic inflation of mxst0.
!
      IXST0=1
      IAXST=MAX(MXST0,MXST00)
      IAXST=MIN(IAXST,IBUFF4/MAXEL)               !DO NOT INFLATE
!
! RE-ENTRY POINT IF MXST0 BUFFER TOO SMALL FOR VCU
!
      NTGA=0
      NXNX=0
      NB=0
!
      KSI=1
      KSF=MXORB
      KF1=1
!
  500 IXEST=MAXEL*IAXST
!
! LOCAL
      ALLOCATE(QLMC(IXEST),QLMS(IXEST),QBML(IAXST),QBMS(IAXST),         &
     &         STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR    QXXX'
        GO TO 2300
      ENDIF
!
  600 CONTINUE
!
      IF(NB.NE.-3)THEN
! EX-COMMON/QTG/
        ALLOCATE(JTGD(0:IAXCT),QTGS(IAXCT),QTGL(IAXCT),QTGD(IAXCT),     &
     &           STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR  JTGD,QTGS,QTGL,QTGD'
          GO TO 2300
        ENDIF
      ENDIF
!
      DO KF=KF1,KMAX
!
        MTGD=0
!        NTG(0)=0
!        JTGD(0)=0
!        KGCF(0)=0
        QCP(KF)=0
!
        JBS=1
        MSST=2                           !INITIAL SS STAT WEIGHT COUNTER
!
        CALL VCU(QLMC,QLMS,QBML,QBMS,IAXST,MAXEL)
!
        IF(NFS.LE.0)THEN
          NF=NFS
          GO TO 1900
        ENDIF
!
        IF(NB.EQ.-3)THEN
!
          IXXX=7*(IAXST/5+1)
!
          WRITE(MW6,*)'*** ALGEB: increasing MXST0 from ',IAXST,' to: ',&
     &                IXXX
          WRITE(MW0,*)'*** ALGEB: increasing MXST0 from ',IAXST,' to: ',&
     &                IXXX
!
          IAXST=IXXX
!
          DEALLOCATE(QBMS,QBML,QLMS,QLMC,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'ALGEB: DE-ALLOCATION FAILS FOR QXXX'
            GO TO 1900
          ENDIF
!
          KF1=KF                                                 !RE-SET
          GO TO 500                                              !RE-RUN
!
        ENDIF
!
        IF(NB.EQ.-2)THEN             !UNLIKELY, NOT BIG, NO NEED TO FLAG
          DEALLOCATE(JTGD,QTGS,QTGL,QTGD,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'ALGEB: DE-ALLOCATION FAILS FOR  JTGD,QTGX'
            GO TO 2300
          ENDIF
          IXXX=7*(IAXCT/5+1)
!          write(mw0,*)'increasing iaxct:',iaxct,ixxx
          IAXCT=IXXX
          KF1=KF                                                 !RE-SET
          GO TO 600                                              !RE-RUN
        ENDIF
!
        NXNX=MAX(NXNX,NTGB)              !MAX UNRESTRICTED TERMS OF A CF
        IAXTM=IAXTM+NTGB
        JX=JBS-JAS+1
        IXST0=IXST0+JX
        JXMX=0
        CALL DIMUSE('MXST0',JXMX)
!        write(mw6,*)'algeb: jxmx=',jxmx
!        write(mw0,*)kf,ntgb,jx,iaxtm,ixst0,jxmx
!
! NOW GET NO. OF SL GROUPS IN THE CONFG (SO LOCAL, NOT GLOBAL IAXSL).
! OBVIOUSLY NO. .LE. HISTORIC MAXSL (OLD NKSL ALLOC WAS GLOBAL) BUT
! WE NEED NKSL ALLOC BEFORE WE KNOW ACTUAL GLOBAL.
!
        K0=1
        J=0
        QCS=QTGS(1)
        QCL=QTGL(1)
        DO I=1,NTGB
          IF(QCS.EQ.QTGS(I).AND.QCL.EQ.QTGL(I))THEN
            J=J+1            !NO. TERMS IN GROUP K0 OF CONFG KF
          ELSE
            QCS=QTGS(I)
            QCL=QTGL(I)
            K0=K0+1
            J=1
          ENDIF
        ENDDO
!        NKSL(K0,KF)=J      !THIS IS WHY WE ARE DOING IT, SO CAN ALLOC
        KSLX=MAX(KSLX,K0)   !MAX NO. GROUPS IN ANY CONFG
!
        IF(NB.NE.0)THEN     !VCU FAILURE, SHOULD NOT HAPPEN
          WRITE(MW6,10010)NB
          GO TO 2200
        ENDIF
!
      ENDDO
!
!-----------------------------------------------------------------------
!
      if(btime)then
        call nrb_time(timef)
        times=timef-timei
!
        if(bloop)write(iw,*)'l=',lnew
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Ending proc',iam,' for vcu dimensions:'   !par&
!par     &               ,' time=',nint(times),'sec,     '          !par&
!par     &               ,nint(times/60),'min'                      !par
!par          call flush(iw)                                        !par
!par        else                                                    !par
        write(iw,*)'Ending vcu dimensions: time=',nint(times),          &
     &             'sec,     ',nint(times/60),'min'
!par        endif                                                   !par
      endif
!
!      if(mprint.eq.-3)stop 'dim test'
      MPRINT=MPRNT0
      MODD=MOD0
!
! temp; re-instate
      kcut=kcut0
      kcutp=kcutp0
      nastp=nastp0
      nast=nast0
      nastj=nastj0
      nasts=nasts0
!
!-----------------------------------------------------------------------
!
! NEED TO BUFFER IAXTM IF ALLOCATING IAXCT IN SR.ALGEB1 FOR SR.VCG.
! USE MAX UNRESTRICTED NUMBER OF TERMS PER CF, +1.
!
      IAXCT=IAXTM+NXNX+1
!
! EX-COMMON/QTG/
      DEALLOCATE(JTGD,QTGS,QTGL,QTGD,STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)                                                    &
     &             'ALGEB: DE-ALLOCATION FAILS FOR  JTGD,QTGS,QTGL,QTGD'
        IF(NF.GT.0)NF=0
        GO TO 2300
      ENDIF
!
! NOW RE-ALLOCATE SLATER-STATES MEMORY AS ACTUALLY NEEDED
!
! EX-COMMON/NRBVCX/
      DEALLOCATE(QCGS)                      !ALGEB1 RE-ALLOCATES ACTUAL
!
! LOCAL
      DEALLOCATE(QLMC,QLMS,QBML,QBMS,STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: DE-ALLOCATION FAILS FOR QXXX'
        IF(NF.GT.0)NF=0
        GO TO 2300
      ENDIF
!
      IAXST=IXST0+JXMX                              !+BUFFER FOR VCG ETC
!      if(kcut+kcutp+nastp+nast+nastj.ne.0)iaxst=iaxst+jxmx    !kcut alt
      IXEST=MAXEL*IAXST
      IF(IXEST.GT.MXEST)THEN
        IF(MXEST.GT.0)WRITE(MW6,10090)IXEST,MXEST
      ENDIF
!
! LOCAL
      ALLOCATE(QLMC(IXEST),QLMS(IXEST),QBML(IAXST),QBMS(IAXST),         &
     &         STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR    QXXX'
        GO TO 2300
      ENDIF
!
! LOCAL
      DEALLOCATE(DC,IDC)
!
      IAXDC=MAX(MAXDC0,MAXDC,IAXDC)
      IXIDC=IAXDC
      IF(DC0.LT.DZERO)IXIDC=1
!
! LOCAL
      ALLOCATE(DC(0:IAXDC),IDC(IXIDC),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR DC,IDC'
        GO TO 2300
      ENDIF
!
      DC(0)=DC0                               !FLAGS OPT MEMORY OR SPEED
!
!-----------------------------------------------------------------------
!
! INITIALIZE (OPEN) WRITE/READ DC ARRAY TO/FROM DISK.
!
      IF(BDISK)CALL DISKDC(IUD,IZERO,IZERO,IZERO,IZERO,IZERO,MSTRT0)
!
      if(btime)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Starting proc',iam,' for algeb1'          !par
!par        else                                                    !par
        write(iw,*)'Starting algeb1'
!par        endif                                                   !par
        if(bloop)write(iw,*)'l=',lnew
        call nrb_time(timei)
      endif
!
!***********************************************************************
!
      CALL ALGEB1(QLMC,QLMS,QBML,QBMS,JYI,JYF,IAXST,MAXEL)          !-1-
!
!***********************************************************************
!
      if(btime)then
        call nrb_time(timef)
        times=timef-timei
!
        if(bloop)write(iw,*)'l=',lnew
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Ending proc',iam,' for algeb1:'           !par&
!par     &               ,' time=',nint(times),'sec,     '          !par&
!par     &               ,nint(times/60),'min'                      !par
!par          call flush(iw)                                        !par
!par        else                                                    !par
        write(iw,*)'Ending algeb1: time=',nint(times),'sec,     ',      &
     &             nint(times/60),'min'
!par        endif                                                   !par
      endif
!
      IF(NF.LE.0)GO TO 1800
!
      NSS=JYF(KMAX)                !FINAL TOT NO. SLATER STATES RETAINED
!
! LOCAL
      ALLOCATE(MAM(NSS),NAM(NSS),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR MAM,NAM'
        GO TO 2300
      ENDIF
!
      IF(BSTART)GO TO 800                       !<----- NO RESTART -----
!
      IF(IDW.NE.0)THEN    !DW DUMP IS NOW AFTER ALGEB3 SO CAN STRIKE-OUT
        BSTART=.TRUE.          !M_S CASES NOT NEEDED FOR BP WHEN NO 2-FS
        GO TO 800
      ENDIF
!
      IF(BREL)NPRINT=MIN(-IFIVE,NPRINT-IFIVE)
      NESS=MAXEL*NSS                     !NO. ELECTRONS*SLATER STATES
      IF(DC0.LT.DZERO)THEN
        MDCBUF=-MDCBUF
        MTGDI=1
        IDC(1)=0
      ELSE
        MTGDI=MTGD
      ENDIF
!PC
!PC AT SOME POINT, WHEN CONVENIENT TO LOSE BACKWARDS COMPATIBILITY
!PC ,MXBORB,MXVORB,MXFORB,NGRP
!PC SHOULD BE ADDED TO RESTART WRITE LINE 3
!PC UNTIL THEN WE PACK IEQ(0) (AGAIN) BUT MORE ROBUSTLY IF NECESSARY.
!PC THE ONLY UNPACK IS AFTER THE CORRESPONDING READ.
!PC
      IF(IEQ(0).LT.0)IEQ(0)=-MXBORB
      IF(IEQ(0).GT.0)THEN
!pc        write(mw0,*)'write:',ieq(0),mxorb,ngrp,mxborb,mxvorb,mxforb
        IEQ(0)=MXORB+MXBORB
        if(ieq(0).ge.1000.or.mxvorb.ge.10.or.mxforb.ge.40)then
          stop 'sr.algeb RESTART pack failure'
        endif
        IEQ(0)=IEQ(0)+1000*MXVORB+10000*MXFORB+400000*NGRP
!pc        write(mw0,*)'write:',ieq(0)
      ENDIF
!!                                                                 !REC1
      WRITE(MRW10)MLIT,MXORB,NW,NF,MODD,KCUT,KUTDSK,QQCUT,QCL0,QCS0,    &
     &            MDCBUF,KSLX,MTGD,MTGDI,NTT,NSS,MAXEL,KMAX,NPRINT,MA,  &
     &            MB,MAXNV,IRLX,ITANAL,((NEL(I,J),I=1,MXORB),J=1,KMAX), &
     &            ((NNL(I,J),I=1,NW),J=1,3),                            &
     &            ((QCG(I,J),I=1,MAXEL),J=1,KMAX),(QL(I),I=1,MXORB),    &
     &            (QN(I),I=1,MXORB),(DEY(I),I=1,MXORB),                 &
     &            (MSTAT(I),I=1,KMAX),(IEQ(I),I=0,MXORB),               &
     &            (IGRCF(I),I=1,MXORB),(ICFGP(I),I=1,KMAX),             &
     &            (KGCF(I),I=0,KMAX),                                   &
     &            ((NKSL(I,J),I=1,KGCF(J)-KGCF(J-1)),J=1,KMAX),         &
     &            (NTG(I),I=0,KMAX),(QCP(I),I=1,KMAX),                  &
     &            (BANAL(I),I=1,KMAX)
!
      MDCBUF=ABS(MDCBUF)
!
      IF(BPASS)GO TO 100
!
      WRITE(MRW10)(QLMS(I),I=1,NESS)                               !REC2
!!
      NMTGD=MTGD/MXMTGD
      MTGD0=0
      MTGD1=-1
      DO N=1,NMTGD
        MTGD1=MTGD1+MXMTGD
        WRITE(MRW10)(DC(I),I=MTGD0,MTGD1)                          !REC3
        MTGD0=MTGD1+1
      ENDDO
      WRITE(MRW10)(DC(I),I=MTGD0,MTGD)                             !REC3
!!
      IMTGD=(MTGDI-1)/MXMTGD
      IMTGD=IMTGD/(LREC/IREC)
      MTGD0=1
      MTGD1=0
      DO N=1,IMTGD
        MTGD1=MTGD1+MXMTGD*(LREC/IREC)
        WRITE(MRW10)(IDC(I),I=MTGD0,MTGD1)                         !REC3
        MTGD0=MTGD1+1
      ENDDO
      WRITE(MRW10)(IDC(I),I=MTGD0,MTGDI)                           !REC3
!!                                                                 !REC3
      WRITE(MRW10)(JYI(I),I=1,KMAX),(JYF(I),I=1,KMAX),(QBML(I),I=1,NSS),&
     &            (QBMS(I),I=1,NSS),(QLMC(I),I=1,NESS),(JTGD(I),I=0,NTT)&
     &            ,(QTGS(I),I=1,NTT),(QTGL(I),I=1,NTT),(QTGD(I),I=1,NTT)
!!
      GO TO 100
!
!-----------------------------------------------------------------------
!
! BEGIN RECOVER ALGEB1
!
!-----------------------------------------------------------------------
!!        !TBD SPLIT REC1, BUT KEEP BACKWARD COMPAT 4 NOW          !REC1
  700 READ(MRW10,ERR=2100)MLIT,MXORB,NW,NF,MODD,KCUT,KUTDSK,QQCUT,QCL0, &
     &                    QCS0,MDCBUF,KSLX,MTGD,MTGDI,NTT,NSS,MAXEL,    &
     &                    KMAX,NPRNT0,MA,MB,MAXNV,IRLX,ITANAL
      BACKSPACE(MRW10)
!
      IAXTM=NTT
      IAXCT=NTT
      IAXCF=KMAX
      IAXGR=MXORB
      IAXCL=MAX(IONE,NW)
!
      CALL DIMUSE('MAXTM',IAXTM)
      CALL DIMUSE('MAXCT',IAXCT)
      CALL DIMUSE('MAXCF',IAXCF)
      CALL DIMUSE('MAXGR',IAXGR)
      CALL DIMUSE('MAXCL',IAXCL)
!
!-----------------------------------------------------------------------
!
! NEED TO DEALLOCATE ARRAYS SET IN ALGEB0 BEFORE ALLOCATE CURRENT DIMENS
!
! EX-COMMON/MQVC/
      DEALLOCATE(NEL)
!
      ALLOCATE(NEL(MXORB,KMAX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR NEL'
        GO TO 2300
      ENDIF
!
! EX-COMMON/CCLSH/
      DEALLOCATE(NNL)
!
      ALLOCATE(NNL(IAXCL,3),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR NNL'
        GO TO 2300
      ENDIF
!
! EX-COMMON/DBD2/
      DEALLOCATE(QCP,QCG,QL,QN,DEY)
!
      ALLOCATE(QCP(KMAX),QCG(MAXEL,KMAX),QL(MXORB),QN(MXORB),DEY(MXORB),&
     &         STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR QCP,QCG,QL,QN,DEY'
        GO TO 2300
      ENDIF
!
! EX-COMMON/NRBLIM/
      IF(ALLOCATED(BANAL))DEALLOCATE(BANAL)
!
      ALLOCATE(BANAL(KMAX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR BANAL'
        GO TO 2300
      ENDIF
!
! EX-COMMON/NRBORB/
      DEALLOCATE(ICFGP)
!
      ALLOCATE(ICFGP(KMAX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.ALGEB: ALLOCATION FAILS FOR ICFGP'
        GO TO 2300
      ENDIF
!
! EX-COMMON/NRBORB/
      DEALLOCATE(IEQ,IGRCF)
!
      ALLOCATE(IEQ(0:MXORB),IGRCF(MXORB),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.ALGEB: ALLOCATION FAILS FOR IEQ,IGRCF'
        GO TO 2300
      ENDIF
!
! THE FOLLOWING ARE NEW ALLOCATIONS
!
! EX-COMMON/QTG/
      ALLOCATE(NTG(0:KMAX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR  NTG'
        GO TO 2300
      ENDIF
!
! EX-COMMON/NRBAL1/
      ALLOCATE(MSTAT(KMAX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB1: ALLOCATION FAILS FOR MSTAT'
        GO TO 2300
      ENDIF
!
! EX-COMMON/NRBGCF/ - KSLX->MAXSL TO READ V27.x
      ALLOCATE(KGCF(0:KMAX),NKSL(KSLX,KMAX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB1: ALLOCATION FAILS FOR KGCF,NKSL'
        GO TO 2300
      ENDIF
!
!-----------------------------------------------------------------------
!!                                                                 !REC1
      READ(MRW10,ERR=2100)MLIT,MXORB,NW,NF,MODD,KCUT,KUTDSK,QQCUT,QCL0, &
     &                    QCS0,MDCBUF,KSLX,MTGD,MTGDI,NTT,NSS,MAXEL,    &
     &                    KMAX,NPRNT0,MA,MB,MAXNV,IRLX,ITANAL,          &
     &                    ((NEL(I,J),I=1,MXORB),J=1,KMAX),              &
     &                    ((NNL(I,J),I=1,NW),J=1,3),                    &
     &                    ((QCG(I,J),I=1,MAXEL),J=1,KMAX),              &
     &                    (QL(I),I=1,MXORB),(QN(I),I=1,MXORB),          &
     &                    (DEY(I),I=1,MXORB),(MSTAT(I),I=1,KMAX),       &
     &                    (IEQ(I),I=0,MXORB),(IGRCF(I),I=1,MXORB),      &
     &                    (ICFGP(I),I=1,KMAX),(KGCF(I),I=0,KMAX),       &
     &                    ((NKSL(I,J),I=1,KGCF(J)-KGCF(J-1)),J=1,KMAX), &
     &                    (NTG(I),I=0,KMAX),(QCP(I),I=1,KMAX),          &
     &                    (BANAL(I),I=1,KMAX)
!!
!PC AT SOME POINT, WHEN CONVENIENT TO LOSE BACKWARDS COMPATIBILITY
!PC ,MXBORB,MXVORB,MXFORB,NGRP
!PC SHOULD BE ADDED TO RESTART READ LINE 3
!PC UNTIL THEN WE UNPACK IEQ(0)
!PC
      IF(IEQ(0).EQ.0)THEN
        NGRP=0
      ELSEIF(IEQ(0).LT.0)THEN
        NGRP=1
        MXBORB=-IEQ(0)
      ELSEIF(IEQ(0).GT.0)THEN
        ID=IEQ(0)-MXORB
        NGRP=ID/400000
        ID=ID-400000*NGRP
        MXFORB=ID/10000
        ID=ID-10000*MXFORB
        MXVORB=ID/1000
        ID=ID-1000*MXVORB
        MXBORB=ID
!pc         write(mw0,*)'read:',ieq(0),mxorb,ngrp,mxborb,mxvorb,mxforb
        IEQ(0)=MXORB+1                  !SO IEQ(0).NE.QCG(I,KF)
      ENDIF
!PC
      IF(BDISK)THEN
        IF(MDCBUF.LT.0)THEN
          MDCBUF=-MDCBUF
          MXTGDI=1
        ELSE
          MXTGDI=MDCBUF
        ENDIF
        MXTGD=MDCBUF
      ELSE
        MXTGD=MTGD
        MXTGDI=MTGDI
      ENDIF
!
!-----------------------------------------------------------------------
!
      NMTGD=MTGD/MXMTGD
      IMTGD=(MTGDI-1)/MXMTGD
      IMTGD=IMTGD/(LREC/IREC)
      NESS=MAXEL*NSS
!
      IF(MSTART.EQ.2)THEN
!
        ALLOCATE(QLMS(NESS),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR    QLMS'
          GO TO 2300
        ENDIF
!!
        READ(MRW10)(QLMS(I),I=1,NESS)                              !REC2
!!
      ENDIF
!
      IF(MSTART.LT.5)THEN
!
! LOCAL
        DEALLOCATE(JYI,JYF)
        ALLOCATE(JYI(KMAX),JYF(KMAX))
!
! EX-COMMON/QTG/
        ALLOCATE(JTGD(0:NTT),QTGS(NTT),QTGL(NTT),QTGD(NTT),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR  JTGD,QTGX'
          GO TO 2300
        ENDIF
!
! LOCAL
        ALLOCATE(QLMC(NESS),QBML(NSS),QBMS(NSS),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR    QXXX'
          GO TO 2300
        ENDIF
!
! LOCAL
        ALLOCATE(MAM(NSS),NAM(NSS),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR MAM,NAM'
          GO TO 2300
        ENDIF
!
! LOCAL
        ALLOCATE(DC(0:MXTGD),IDC(MXTGDI),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR DC,IDC'
          GO TO 2300
        ENDIF
!
        DC(0)=DC0                             !FLAGS OPT MEMORY OR SPEED
!
        IAXDC=MXTGD
        IXIDC=MXTGDI
        IXEST=NESS
        IAXST=NSS
!
        CALL DIMUSE('MAXDC',IAXDC)
        CALL DIMUSE('MXDIC',IXDIC)
        CALL DIMUSE('MXEST',IXEST)
        CALL DIMUSE('MXST0',IAXST)
!
! INITIALIZE (OPEN) WRITE/READ DC ARRAY TO/FROM DISK.
!
        IF(BDISK)CALL DISKDC(IUD,IZERO,IZERO,IZERO,IZERO,IZERO,MSTRT0)
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      KCUTX=SIGN(KCUT,KCUTX)
      BREL0=NPRNT0.LE.-5
      MPRINT=MOD(NPRNT0,IFIVE)
      IF(MPRNT0.GT.MPRINT)NPRINT=MPRINT+5*(NPRINT/5)
      BREL=BREL.OR.NPRINT.LE.-5
!
      IF(BREL.AND..NOT.BREL0)THEN
!        WRITE(MW0,1011)
        WRITE(MW6,10070)
      ENDIF
!
      WRITE(MW6,10040)MLIT,MSTART
!
      IF(MSTART.GT.2)GO TO 900          !<--------------- RESTART SWITCH
!!
      MTGD0=0
      MTGD1=-1
      DO N=1,NMTGD
        MTGD1=MTGD1+MXMTGD
        READ(MRW10,ERR=2100)(DC(I),I=MTGD0,MTGD1)                  !REC3
        MTGD0=MTGD1+1
      ENDDO
      READ(MRW10,ERR=2100)(DC(I),I=MTGD0,MTGD)                     !REC3
!!
      MTGD0=1
      MTGD1=0
      DO N=1,IMTGD
        MTGD1=MTGD1+MXMTGD*(LREC/IREC)
        READ(MRW10,ERR=2100)(IDC(I),I=MTGD0,MTGD1)                 !REC3
        MTGD0=MTGD1+1
      ENDDO
      READ(MRW10,ERR=2100)(IDC(I),I=MTGD0,MTGDI)                   !REC3
!!                                                                 !REC3
      READ(MRW10,ERR=2100)(JYI(I),I=1,KMAX),(JYF(I),I=1,KMAX),          &
     &                    (QBML(I),I=1,NSS),(QBMS(I),I=1,NSS),          &
     &                    (QLMC(I),I=1,NESS),(JTGD(I),I=0,NTT),         &
     &                    (QTGS(I),I=1,NTT),(QTGL(I),I=1,NTT),          &
     &                    (QTGD(I),I=1,NTT)
!
!-----------------------------------------------------------------------
!
! END RECOVER ALGEB1
!
!-----------------------------------------------------------------------
!!
  800 MSTART=2
!
      if(btime)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Starting proc',iam,' for algeb2'          !par
!par        else                                                    !par
        write(iw,*)'Starting algeb2'
!par        endif                                                   !par
        if(bloop)write(iw,*)'l=',lnew
        call nrb_time(timei)
      endif
!
!***********************************************************************
!
      CALL ALGEB2(MAM,NAM,QLMC,QLMS,QBML,QBMS,JYI,JYF,MAXEL)        !-2-
!
!***********************************************************************
!
      if(btime)then
        call nrb_time(timef)
        times=timef-timei
!
        if(bloop)write(iw,*)'l=',lnew
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Ending proc',iam,' for algeb2:'           !par&
!par     &               ,' time=',nint(times),'sec,     '          !par&
!par     &               ,nint(times/60),'min'                      !par
!par          call flush(iw)                                        !par
!par        else                                                    !par
        write(iw,*)'Ending algeb2: time=',nint(times),'sec,     ',      &
     &             nint(times/60),'min'
!par        endif                                                   !par
      endif
!
!-----------------------------------------------------------------------
!
! LOCAL
      DEALLOCATE(QLMS,STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: DE-ALLOCATION FAILS FOR QLMS'
        GO TO 2300
      ENDIF
!
!-----------------------------------------------------------------------
!
      IF(NF.LE.0)GO TO 1800
!
      IF(BSTART)GO TO 1000                      !<----- NO RESTART -----
!
      IF(.NOT.BPASS)THEN
        DO N=1,NMTGD+IMTGD+3
          BACKSPACE(MRW10)                                         !REC3
        ENDDO
        BACKSPACE(MRW10)                                           !REC2
      ENDIF
!
      IRKK=MAX(IOS,IRK)
      IRKO=1
      IF(KUTOO.NE.0)IRKO=IRK
      IF(MPOL00.GE.0)THEN           !BORN CODING NOW USED MORE GENERALLY
        MXORB2=(MXORB*(MXORB+1))/2
        LHM=MPOLE/4
        IF(BREL)LHM=LHM+1
      ELSE
        MXORB2=1
        LHM=0
      ENDIF
      IF(MPRNT0.EQ.-2)THEN
        ID1=1
        ID2=1
      ELSE
        ID1=NSL0
        ID2=NTT
      ENDIF
!
!!                                                                 !REC2
      WRITE(MRW10)IADD,IRK,IRKO,IRL,MTGD,MPOL00,MPOLE,IOS,NXLL,KUTLS,   &
     &            NSL0,NMETA,MXORBR
!                                                                  !REC3
      WRITE(MRW10)(NSL(I),I=1,NSL0),(QSI(I),I=1,NSL0),(QLI(I),I=1,NSL0),&
     &            (QPI(I),I=1,NSL0),(NMETAG(I),I=1,NSL0),               &
     &            ((KGSL(I,J),I=1,KMAX),J=1,NSL0),(NADG(I),I=1,NSL0),   &
     &            (NFI(I),I=1,NTT),(NFK(I),I=1,NTT),(NFQ(I),I=1,NTT)
      WRITE(MRW10)(NAD(I),I=0,IADD)
      WRITE(MRW10)(DRK(I),I=1,IRKK)
      WRITE(MRW10)(NRK(I),I=1,IRKK)
      WRITE(MRW10)(((NED(I,J,K),I=1,2),J=1,ID1),K=1,ID2) !SHOULD BE O.K.
      WRITE(MRW10)((QRL(J,I),J=1,5),I=1,IRL),(DEK(I),I=1,IRKO),         &
     &            (BFALL(I),I=1,IRKO),                                  &
     &            ((BINDB(I,LH),I=1,MXORB2),LH=0,LHM)
!               (DEK(I),I=1,IRKO),(BFALL(I),I=1,IRKO)  !OFF, LARGE CASES
      LREC3=6
!
      IF(BPASS)GO TO 100
!!
      MTGD0=0
      MTGD1=-1
      DO N=1,NMTGD
        MTGD1=MTGD1+MXMTGD
        WRITE(MRW10)(DC(I),I=MTGD0,MTGD1)                          !REC4
        MTGD0=MTGD1+1
      ENDDO
      WRITE(MRW10)(DC(I),I=MTGD0,MTGD)                             !REC4
!!
      MTGD0=1
      MTGD1=0
      DO N=1,IMTGD
        MTGD1=MTGD1+MXMTGD*(LREC/IREC)
        WRITE(MRW10)(IDC(I),I=MTGD0,MTGD1)                         !REC4
        MTGD0=MTGD1+1
      ENDDO
      WRITE(MRW10)(IDC(I),I=MTGD0,MTGDI)                           !REC4
!!                                                                 !REC4
      WRITE(MRW10)(JYI(I),I=1,KMAX),(JYF(I),I=1,KMAX),(QBML(I),I=1,NSS),&
     &            (QBMS(I),I=1,NSS),(QLMC(I),I=1,NESS),(JTGD(I),I=0,NTT)&
     &            ,(QTGS(I),I=1,NTT),(QTGL(I),I=1,NTT),(QTGD(I),I=1,NTT)
      GO TO 100
!
!-----------------------------------------------------------------------
!
! BEGIN RECOVER ALGEB2
!
!-----------------------------------------------------------------------
!!                                                                 !REC2
  900 READ(MRW10,ERR=2100)IADD,IRK,IRKO,IRL,MTGD,MPOL0,MPOLX,IOS,NXLL,  &
     &                    KUTLS,NSL0,NMETA,MXORBR
!!
!
!      IAXAD=IADD
      IF(IRKO.EQ.1)KUTOO=0
      IRKK=MAX(IRK,IOS)
      IAXRK=IRKK
      IAXRL=IRL
      IAXSL=NSL0
!
      CALL DIMUSE('MAXAD',IADD)
      CALL DIMUSE('MAXRK',IAXRK)
      CALL DIMUSE('MAXRL',IAXRL)
      CALL DIMUSE('MAXSL',IAXSL)
!
      MPOLE=MIN(MPOLE,MPOLX)      !CAN DO BECAUSE BINDB AT END OF RECORD
      IM=MAX(IONE,MPOLE/2)
      CALL DIMUSE('MXBLM',IM)
!
      MPOL00=MAX(MPOL00,MPOL0)
      IF(MPOL00.GE.0)THEN                 !OLD .EQ.0, NOW USED GENERALLY
        MXORB2=(MXORB*(MXORB+1))/2
        LHM=MPOLE/4
        if(brel0)then
          if(brel)lhm=lhm+1
          lhm0=lhm
        else
          if(brel)lhm=lhm+1
          lhm0=min(lhm,mpolx/4)
        endif
      ELSE
        MXORB2=1
        LHM=0
        lhm0=0
      ENDIF
!
      IF(MPRINT.EQ.-2)THEN
        ID1=1
        ID2=1
      ELSE
        ID1=NSL0
        ID2=NTT
      ENDIF
!
!-----------------------------------------------------------------------
!
! EX-COMMON/DXRL/
      ALLOCATE(DRK(IRKK),QRL(5,IRL),NRK(IRKK),NAD(0:IADD),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR  DRK,QRL,NRK,NAD'
        GO TO 2300
      ENDIF
!
! EX-COMMON/QTG/
      ALLOCATE(NFI(NTT),NFK(NTT+1),NFQ(NTT),STAT=IERR)   !+1 for bundle
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR  NFI,NFK,NFQ'
        GO TO 2300
      ENDIF
!
! EX-COMMON/TERMS/
      ALLOCATE(NSL(NSL0),QSI(NSL0),QLI(NSL0),QPI(NSL0),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR NSL,QSI,QLI,QPI'
        GO TO 2300
      ENDIF
!
! EX-COMMON/NRBDWM/
      ALLOCATE(NMETAG(0:NSL0),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR NMETAG'
        GO TO 2300
      ENDIF
!
! EX-COMMON/NRBEKP/
      ALLOCATE(NED(2,ID1,ID2),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR  NED'
        GO TO 2300
      ENDIF
!
! EX-COMMON/NRBGCF/
      ALLOCATE(KGSL(KMAX,NSL0),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR KGSL'
        GO TO 2300
      ENDIF
!
! EX-COMMON/NRBGRP/
      ALLOCATE(NGRPI(NSL0),NADG(NSL0),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR NGRPI,NADG'
        GO TO 2300
      ENDIF
!
! EX-COMMON/NRBNF1/
      ALLOCATE(DEK(IRKO),BFALL(IRKO),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR  DEK, BFALL'
        GO TO 2300
      ENDIF
!
! EX-COMMON/NRBRN2/
      ALLOCATE(BINDB(MXORB2,0:LHM),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR  BINDB'
        GO TO 2300
      ENDIF
!
!-----------------------------------------------------------------------
!!                                                                 !REC3
      READ(MRW10,ERR=2100)(NSL(I),I=1,NSL0),(QSI(I),I=1,NSL0),          &
     &                    (QLI(I),I=1,NSL0),(QPI(I),I=1,NSL0),          &
     &                    (NMETAG(I),I=1,NSL0),                         &
     &                    ((KGSL(I,J),I=1,KMAX),J=1,NSL0),              &
     &                    (NADG(I),I=1,NSL0),(NFI(I),I=1,NTT),          &
     &                    (NFK(I),I=1,NTT),(NFQ(I),I=1,NTT)
      READ(MRW10,ERR=2100)(NAD(I),I=0,IADD)
      READ(MRW10,ERR=2100)(DRK(I),I=1,IRKK)
      READ(MRW10,ERR=2100)(NRK(I),I=1,IRKK)
      READ(MRW10,ERR=2100)(((NED(I,J,K),I=1,2),J=1,ID1),K=1,ID2)
      READ(MRW10,ERR=2100)((QRL(J,I),J=1,5),I=1,IRL),(DEK(I),I=1,IRKO), &
     &                    (BFALL(I),I=1,IRKO),                          &
     &                    ((BINDB(I,LH),I=1,MXORB2),LH=0,lhm0)
!
      NMETAG(0)=NMETAG0             !UNUSED VIA RESTART AS ONLY IDW.NE.0
!
      do lh=lhm0+1,lhm
        do i=1,mxorb2
          bindb(i,lh)=.false.    !brel but no retardation as brel0 false
        enddo
      enddo
!
      IF(MSTART.GT.3)GO TO 1100
!!
      MTGD0=0
      MTGD1=-1
      DO N=1,NMTGD
        MTGD1=MTGD1+MXMTGD
        READ(MRW10,ERR=2100)(DC(I),I=MTGD0,MTGD1)                  !REC4
        MTGD0=MTGD1+1
      ENDDO
      READ(MRW10,ERR=2100)(DC(I),I=MTGD0,MTGD)                     !REC4
!!
      MTGD0=1
      MTGD1=0
      DO N=1,IMTGD
        MTGD1=MTGD1+MXMTGD*(LREC/IREC)
        READ(MRW10,ERR=2100)(IDC(I),I=MTGD0,MTGD1)                 !REC4
        MTGD0=MTGD1+1
      ENDDO
      READ(MRW10,ERR=2100)(IDC(I),I=MTGD0,MTGDI)                   !REC4
!!                                                                 !REC4
      READ(MRW10,ERR=2100)(JYI(I),I=1,KMAX),(JYF(I),I=1,KMAX),          &
     &                    (QBML(I),I=1,NSS),(QBMS(I),I=1,NSS),          &
     &                    (QLMC(I),I=1,NESS),(JTGD(I),I=0,NTT),         &
     &                    (QTGS(I),I=1,NTT),(QTGL(I),I=1,NTT),          &
     &                    (QTGD(I),I=1,NTT)
!
!-----------------------------------------------------------------------
!
! EX-COMMON/NRBLSP/  WAS ALLOCATED IN ALGEB0 BUT ONLY IN ALGEB1,2 BRANCH
      IF(ALLOCATED(LSPIP))THEN
        DEALLOCATE(LSPIP,NLSPIP,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB: DE-ALLOCATION FAILS FOR LSPIP,NLSPIP'
          GO TO 2300
        ENDIF
      ENDIF
!
! EX-COMMON/NRBLSS/  WAS ALLOCATED IN ALGEB0 BUT ONLY IN ALGEB1,2 BRANCH
      IF(ALLOCATED(NESSH))THEN
        DEALLOCATE(NESSH)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB: DE-ALLOCATION FAILS FOR NESSH'
          GO TO 2300
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
! END RECOVER ALGEB2
!
!-----------------------------------------------------------------------
!!
 1000 MSTART=3
!
      if(btime)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Starting proc',iam,' for algeb3'          !par
!par        else                                                    !par
        write(iw,*)'Starting algeb3'
!par        endif                                                   !par
        if(bloop)write(iw,*)'l=',lnew
        call nrb_time(timei)
      endif
!
!***********************************************************************
!
      CALL ALGEB3(MAM,NAM,QLMC,QBML,QBMS,JYI,JYF,MAXEL)             !-3-
!
!***********************************************************************
!
      if(btime)then
        call nrb_time(timef)
        times=timef-timei
!
        if(bloop)write(iw,*)'l=',lnew
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Ending proc',iam,' for algeb3:'           !par&
!par     &               ,' time=',nint(times),'sec,     '          !par&
!par     &               ,nint(times/60),'min'                      !par
!par          call flush(iw)                                        !par
!par        else                                                    !par
        write(iw,*)'Ending algeb3: time=',nint(times),'sec,     ',      &
     &             nint(times/60),'min'
!par        endif                                                   !par
      endif
!
      IF(NF.LE.0)GO TO 1800
!
      IF(BSTART)GO TO 1200                      !<----- NO RESTART -----
!
      IADJ0=0
      IF(NL.GT.0)IADJ0=IADJ
      IRLP000=IRLP
!!
      IF(.NOT.BPASS)THEN
        DO N=1,NMTGD+IMTGD+3
          BACKSPACE(MRW10)                                         !REC4
        ENDDO
      ENDIF
!
      WRITE(MRW10)NJO,IRS,NL,IADJ8,IADJ0,IRKP,IRLP,NLEV,NMETAJ     !REC4
!
!!
      IF(NJO.EQ.0)THEN                          !LS
        WRITE(MRW10)NJO                                            !REC5
        LREC5=1
      ELSE
!                                                                  !REC5
        WRITE(MRW10)NJO,(NRR(I),I=1,NLEV),(NT(I),I=1,NJO),              &
     &              (JN(I),I=1,NLEV),(NGR(I),I=1,NLEV),                 &
     &              (NMETGJ(I),I=1,NJO),((NSLJ(J,I),J=1,NSL0),I=1,NJO), &
     &              (NGSLJ(I),I=1,NJO),(NTJ(I),I=1,KMAX),               &
     &              (NFJ(I),I=1,NLEV),((QRLP(J,I),J=1,4),I=1,IRLP),     &
     &              ((QSS(J,I),J=1,5),I=1,NL)
!T        WRITE(MRW10)(NADP(NP8),NP8=0,IADJ8)
        WRITE(MRW10)(NADP(NP8),NP8=1,IADJ8)          !*** TEMP 0->1 ****
        WRITE(MRW10)(DRKP(I),I=1,IRKP)
        WRITE(MRW10)(NRKP(I),I=1,IRKP)
        WRITE(MRW10)(NADR(I),I=0,IADJ0)
        WRITE(MRW10)(DSS(I),I=1,IRS)
        WRITE(MRW10)(MSS(I),I=1,IRS)
        LREC5=7
!
        IF(BPASS)GO TO 100
!!
        MTGD0=0
        MTGD1=-1
        DO N=1,NMTGD
          MTGD1=MTGD1+MXMTGD
          WRITE(MRW10)(DC(I),I=MTGD0,MTGD1)                        !REC6
          MTGD0=MTGD1+1
        ENDDO
        WRITE(MRW10)(DC(I),I=MTGD0,MTGD)                           !REC6
!!
        MTGD0=1
        MTGD1=0
        DO N=1,IMTGD
          MTGD1=MTGD1+MXMTGD*(LREC/IREC)
          WRITE(MRW10)(IDC(I),I=MTGD0,MTGD1)                       !REC6
          MTGD0=MTGD1+1
        ENDDO
        WRITE(MRW10)(IDC(I),I=MTGD0,MTGDI)                         !REC6
!!                                                                 !REC6
        WRITE(MRW10)(JYI(I),I=1,KMAX),(JYF(I),I=1,KMAX),                &
     &              (QBML(I),I=1,NSS),(QBMS(I),I=1,NSS),                &
     &              (QLMC(I),I=1,NESS),(JTGD(I),I=0,NTT),               &
     &              (QTGS(I),I=1,NTT),(QTGL(I),I=1,NTT),                &
     &              (QTGD(I),I=1,NTT)
      ENDIF
      GO TO 100
!
!-----------------------------------------------------------------------
!
! BEGIN RECOVER ALGEB3
!
!-----------------------------------------------------------------------
!!                                                                 !REC4
 1100 READ(MRW10,ERR=2100)NJO,IRS,NL,IADJ8,IADJ0,IRKP,IRLP,NLEV,NMETAJ
!!
!
      IF(ABS(MOD0).GT.1.OR.NJO.EQ.0)THEN
        READ(MRW10,ERR=2100)NJO                                    !REC5
        NJO=0
      ELSE
!
!-----------------------------------------------------------------------
!
! SET ALLOCATE SIZE
        IAXJG=NJO
        IAXLV=NLEV
        IXSOC=IRKP
        IXSOI=IRLP
        IXRSS=IRS
        IAXMI=NL
        IADJ=INT(IADJ8,SP)                            !FOR I*4 BRANCHES
!
        IF(MSTART.LT.5)THEN       !NOT YET MAXIMAL
          IXSOC=MAX(MXSOC0,MXSOC,IXSOC)           !USE LARGEST PREVIOUS
          IXSOI=MAX(MXSOI0,MXSOI,IXSOI)           !USE LARGEST PREVIOUS
          IXRSS=MAX(MXRSS0,MXRSS,IXRSS)           !USE LARGEST PREVIOUS
          IAXMI=MAX(MAXMI0,MAXMI,IAXMI)           !USE LARGEST PREVIOUS
          IRLP000=IRLP
        ELSE
          IRLP000=IRLP-1       !SINGLE PASS, DON'T HAVE, TRY & LOOK FOR
        ENDIF
!
        CALL DIMUSE('MAXJG',IAXJG)
        CALL DIMUSE('MAXLV',IAXLV)
        CALL DIMUSE('MXSOC',IXSOC)
        CALL DIMUSE('MXSOI',IXSOI)
        CALL DIMUSE('MXRSS',IXRSS)
        CALL DIMUSE('MAXMI',IAXMI)
        CALL DIMUSE('MXADJ',IADJ)
!
! EX-COMMON/COEFF/
        ALLOCATE(DRKP(IXSOC),QRLP(4,IXSOI),NRKP(IXSOC),NADP(0:IADJ8),   &
     &           STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB:ALLOCATION FAILS FOR DRKP,QRLP,NRKP,NADP'
          GO TO 2300
        ENDIF
!
! EX-COMMON/DMQSS3/
        ALLOCATE(DSS(IXRSS),MSS(IXRSS),QSS(5,IAXMI),NADR(0:IADJ0),      &
     &           STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR  DSS,MSS,QSS,NADR'
          GO TO 2300
        ENDIF
!
! EX-COMMON/JSPOR/
        ALLOCATE(NRR(NLEV+1),NT(NJO),JN(NLEV),NGR(NLEV),STAT=IERR)  !+1
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR NJO,NRR,NT,JN,NGR'
          GO TO 2300
        ENDIF
!
! EX-COMMON/QTG/
        ALLOCATE(NTJ(KMAX),NFJ(NLEV),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR NTJ,NFJ'
          GO TO 2300
        ENDIF
!
! EX-COMMON/NRBDWM/
        ALLOCATE(NMETGJ(NJO),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR NMETGJ'
          GO TO 2300
        ENDIF
!
! EX-COMMON/NRBGRJ/
        ALLOCATE(NSLJ(NSL0,NJO),NGSLJ(NJO),STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR NSL0,NGSLJ'
          GO TO 2300
        ENDIF
!
!-----------------------------------------------------------------------
!!                                                                 !REC5
        READ(MRW10,ERR=2100)NJO,(NRR(I),I=1,NLEV),(NT(I),I=1,NJO),      &
     &                      (JN(I),I=1,NLEV),(NGR(I),I=1,NLEV),         &
     &                      (NMETGJ(I),I=1,NJO),                        &
     &                      ((NSLJ(J,I),J=1,NSL0),I=1,NJO),             &
     &                      (NGSLJ(I),I=1,NJO),(NTJ(I),I=1,KMAX),       &
     &                      (NFJ(I),I=1,NLEV),                          &
     &                      ((QRLP(J,I),J=1,4),I=1,IRLP),               &
     &                      ((QSS(J,I),J=1,5),I=1,NL)
        nadp(0)=0                                          !*** TEMP ***
        READ(MRW10,ERR=2100)(NADP(NP8),NP8=1,IADJ8)   !*** TEMP 0->1 ***
!T        READ(MRW10,ERR=994)(NADP(NP8),NP8=0,IADJ8)
        READ(MRW10,ERR=2100)(DRKP(I),I=1,IRKP)
        READ(MRW10,ERR=2100)(NRKP(I),I=1,IRKP)
        READ(MRW10,ERR=2100)(NADR(I),I=0,IADJ0)              !+/- ALGEB4
        READ(MRW10,ERR=2100)(DSS(I),I=1,IRS)
        READ(MRW10,ERR=2100)(MSS(I),I=1,IRS)
!
        IF(MSTART.EQ.4)THEN
          MTGD0=0
          MTGD1=-1
          DO N=1,NMTGD
            MTGD1=MTGD1+MXMTGD
            READ(MRW10,ERR=2100)(DC(I),I=MTGD0,MTGD1)              !REC6
            MTGD0=MTGD1+1
          ENDDO
          READ(MRW10,ERR=2100)(DC(I),I=MTGD0,MTGD)                 !REC6
!!
          MTGD0=1
          MTGD1=0
          DO N=1,IMTGD
            MTGD1=MTGD1+MXMTGD*(LREC/IREC)
            READ(MRW10,ERR=2100)(IDC(I),I=MTGD0,MTGD1)             !REC6
            MTGD0=MTGD1+1
          ENDDO
          READ(MRW10,ERR=2100)(IDC(I),I=MTGD0,MTGDI)               !REC6
!!                                                                 !REC6
          READ(MRW10,ERR=2100)(JYI(I),I=1,KMAX),(JYF(I),I=1,KMAX),      &
     &                        (QBML(I),I=1,NSS),(QBMS(I),I=1,NSS),      &
     &                        (QLMC(I),I=1,NESS),(JTGD(I),I=0,NTT),     &
     &                        (QTGS(I),I=1,NTT),(QTGL(I),I=1,NTT),      &
     &                        (QTGD(I),I=1,NTT)
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
! EX-COMMON/NRBAL3/    WAS ALLOCATED IN ALGEB0 BUT ONLY IN ALGEB3 BRANCH
      IF(ALLOCATED(KCFSS))THEN
        DEALLOCATE(KCFSS,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB: DE-ALLOCATION FAILS FOR KCFSS'
          GO TO 2300
        ENDIF
      ENDIF
!!
      IF(MSTART.GT.4)THEN
        NL000=NL
        GO TO 1400
      ENDIF
!
!-----------------------------------------------------------------------
!
! END RECOVER ALGEB3
!
!-----------------------------------------------------------------------
!
 1200 MSTART=4
!
      if(btime)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Starting proc',iam,' for algeb4'          !par
!par        else                                                    !par
        write(iw,*)'Starting algeb4'
!par        endif                                                   !par
        if(bloop)write(iw,*)'l=',lnew
        call nrb_time(timei)
      endif
!
!***********************************************************************
!
      CALL ALGEB4(MAM,NAM,QLMC,QBML,QBMS,JYI,JYF,MAXEL)             !-4-
!
!***********************************************************************
!
      if(btime)then
        call nrb_time(timef)
        times=timef-timei
!
        if(bloop)write(iw,*)'l=',lnew
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Ending proc',iam,' for algeb4:'           !par&
!par     &               ,' time=',nint(times),'sec,     '          !par&
!par     &               ,nint(times/60),'min'                      !par
!par          call flush(iw)                                        !par
!par        else                                                    !par
        write(iw,*)'Ending algeb4: time=',nint(times),'sec,     ',      &
     &             nint(times/60),'min'
!par        endif                                                   !par
      endif
!
      IF(NF.LE.0)GO TO 1800
!
      IF(BSTART)GO TO 1700                      !<----- NO RESTART -----
!
!      NJO=JSP(1)
!      IF(NJO.LT.0)GO TO 79                   !NO LONGER POSSIBLE,=0 OFF
!
      IF(NJO.GT.0.AND..NOT.BPASS)THEN
        DO N=1,NMTGD+IMTGD+3
          BACKSPACE(MRW10)                                         !REC6
        ENDDO
      ENDIF
!
!OLD      IF(NL000.LT.NL)NL000=NL000+1
!!
      IF(NL000.LE.NL.AND.IRLP.LE.IRLP000)THEN    !NO CONTRIBS
        WRITE(MRW10)NL                                             !REC6
        WRITE(MRW10)MBP1MX                                         !REC7
      ELSE
        DO L=1,LREC5
          BACKSPACE(MRW10)                                         !REC5
        ENDDO
        BACKSPACE(MRW10)                                           !REC4
        DO L=1,LREC3
          BACKSPACE(MRW10)                                         !REC3
        ENDDO
!!                                                                 !REC3
        WRITE(MRW10)(NSL(I),I=1,NSL0),(QSI(I),I=1,NSL0),                &
     &              (QLI(I),I=1,NSL0),(QPI(I),I=1,NSL0),                &
     &              (NMETAG(I),I=1,NSL0),((KGSL(I,J),I=1,KMAX),J=1,NSL0)&
     &              ,(NADG(I),I=1,NSL0),(NFI(I),I=1,NTT),               &
     &              (NFK(I),I=1,NTT),(NFQ(I),I=1,NTT)
        WRITE(MRW10)(NAD(I),I=0,IADD)
        WRITE(MRW10)(DRK(I),I=1,IRKK)
        WRITE(MRW10)(NRK(I),I=1,IRKK)
        WRITE(MRW10)(((NED(I,J,K),I=1,2),J=1,ID1),K=1,ID2)
        WRITE(MRW10)((QRL(J,I),J=1,5),I=1,IRL),(DEK(I),I=1,IRKO),       &
     &              (BFALL(I),I=1,IRKO),                                &
     &              ((BINDB(I,LH),I=1,MXORB2),LH=0,LHM)
!
        WRITE(MRW10)NJO,IRS,NL000,IADJ8,IADJ0,IRKP,IRLP,NLEV,NMETAJ
                                                                   !REC4
!                                                                  !REC5
        WRITE(MRW10)NJO,(NRR(I),I=1,NLEV),(NT(I),I=1,NJO),              &
     &              (JN(I),I=1,NLEV),(NGR(I),I=1,NLEV),                 &
     &              (NMETGJ(I),I=1,NJO),((NSLJ(J,I),J=1,NSL0),I=1,NJO), &
     &              (NGSLJ(I),I=1,NJO),(NTJ(I),I=1,KMAX),               &
     &              (NFJ(I),I=1,NLEV),((QRLP(J,I),J=1,4),I=1,IRLP),     &
     &              ((QSS(J,I),J=1,5),I=1,NL000)
!T      WRITE(MRW10)(NADP(NP8),NP8=0,IADJ8)                        !^^^
        WRITE(MRW10)(NADP(NP8),NP8=1,IADJ8)          !*** TEMP 0->1 ****
        WRITE(MRW10)(DRKP(I),I=1,IRKP)
        WRITE(MRW10)(NRKP(I),I=1,IRKP)
        WRITE(MRW10)(NADR(I),I=0,IADJ0)
        WRITE(MRW10)(DSS(I),I=1,IRS)
        WRITE(MRW10)(MSS(I),I=1,IRS)
!
        WRITE(MRW10)NL,IPLANT_SOI,IPLANT_MI                        !REC6
!                                                                  !REC7
        WRITE(MRW10)MBP1MX,MBP2MX,MEKVMX,                               &
     &              (((NMD1(I,J,K),I=1,2),J=1,NJO),K=1,NLEV),           &
     &              (((NMD2(I,J,K),I=1,2),J=1,NJO),K=1,NLEV)
      ENDIF
!
      GO TO 100
!
!-----------------------------------------------------------------------
!
! BEGIN RECOVER ALGEB4
!
!-----------------------------------------------------------------------
!
 1300 IF(IRLP000.LT.IRLP)THEN                !TRY FOR NO ALEGB4 CONTRIBS
        IRLP000=IRLP
        BACKSPACE(MRW10)
      ELSE
        GO TO 2100                                             !BAIL OUT
      ENDIF
!!
 1400 READ(MRW10,ERR=1500,END=1500)NL                              !REC6
      go to 1600
!!
 1500 nl=nl000                         !for non-flush, hope for the best
!      write(mw0,*)nl,nl000,mbp1mx
 1600 IF(ABS(MOD0).GT.1.OR.NL000.LE.NL.AND.IRLP.LE.IRLP000)THEN    !NONE
!     &                     .AND.MBP1MX.LT.0.AND.MPOLE.LT.6)THEN !FOR M2
!
!-----------------------------------------------------------------------
! EX-COMMON/NRBMKP/
        ALLOCATE(NMD1(1,1,1),NMD2(1,1,1),STAT=IERR)
!
!-----------------------------------------------------------------------
!!
        READ(MRW10,ERR=1650,END=1650)MBP1MX                        !REC7
!!
 1650   IF(ABS(MOD0).GT.1.OR.KUTSS.EQ.-1)NL=0
        NL000=NL
        MBP1MX=-2
        MBP2MX=0
        MEKVMX=-2
        NMD1(1,1,1)=-1
        NMD2(1,1,1)=-1
      ELSE                             !E3, M1+BP etc not v26 compatible
        BACKSPACE(MRW10)
        READ(MRW10,ERR=1300)NL,IPLANT_SOI,IPLANT_MI                !REC6
!
!-----------------------------------------------------------------------
! EX-COMMON/NRBMKP/
        ALLOCATE(NMD1(2,NJO,NLEV),NMD2(2,NJO,NLEV),STAT=IERR)
!
!-----------------------------------------------------------------------
!!                                                                 !REC7
        READ(MRW10,ERR=2100)MBP1MX,MBP2MX,MEKVMX,                       &
     &                      (((NMD1(I,J,K),I=1,2),J=1,NJO),K=1,NLEV),   &
     &                      (((NMD2(I,J,K),I=1,2),J=1,NJO),K=1,NLEV)
!!
      ENDIF
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB: ALLOCATION FAILS FOR  NMD1,NMD2'
        GO TO 2300
      ENDIF
!
!-----------------------------------------------------------------------
!
! END RECOVER ALGEB4
!
!-----------------------------------------------------------------------
!
 1700 CONTINUE
!
      IF(IDW.NE.0)THEN
!
! SEE IF WE CAN REDUCE THE TARGET SLATER-STATE EXPANSION FOR THE
! COLLISION PROBLEM AT HAND.
!
        CALL REDSS(MAM,QLMC,QBML,QBMS,JYI,JYF,MAXEL)               !,NAM
!
        NPRNT0=NPRINT
        IF(BREL)NPRNT0=MIN(-IFIVE,NPRINT-IFIVE)
!
        NSS=JYF(KMAX)                      !TOT NO. SLATER STATES NEEDED
        NESS=MAXEL*NSS                     !NO. ELECTRONS*SLATER STATES
        IF(DC0.LT.DZERO)THEN
          MDCBUF=-MDCBUF
          MTGDI=1
          IDC(1)=0
        ELSE
          MTGDI=MTGD
        ENDIF
!
!-----------------------------------------------------------------------
!
! THIS DUMP IS JUST THE RESTART DUMP AFTER THE CALL TO ALGEB1
! (NOT EVERYTHING IS NECESSARILY NEEDED).
!
        IRKO=1                             !NOT USED
        IADJ0=0                            !NOT USED
!
        REWIND(MRW10)
!                                                                  !REC1
        WRITE(MRW10)MLIT,MXORB,NW,NF,MODD,KCUTX,KUTDSK,QQCUTX,QCL0,QCS0,&
     &              MDCBUF,KSLX,MTGD,MTGDI,NTT,NSS,MAXEL,KMAX,NPRNT0,MA,&
     &              MB,MAXNV,IRLX,ITANAL,MXBORB,MXVORB,MXFORB,NGRP,     &
     &              ((NEL(I,J),I=1,MXORB),J=1,KMAX),                    &
     &              ((NNL(I,J),I=1,NW),J=1,3),                          &
     &              ((QCG(I,J),I=1,MAXEL),J=1,KMAX),(QL(I),I=1,MXORB),  &
     &              (QN(I),I=1,MXORB),(DEY(I),I=1,MXORB),               &
     &              (MSTAT(I),I=1,KMAX),(IEQ(I),I=0,MXORB),             &
     &              (IGRCF(I),I=1,MXORB),(ICFGP(I),I=1,KMAX),           &
     &              (KGCF(I),I=0,KMAX),                                 &
     &              ((NKSL(I,J),I=1,KGCF(J)-KGCF(J-1)),J=1,KMAX),       &
     &              (NTG(I),I=0,KMAX),(QCP(I),I=1,KMAX),                &
     &              (BANAL(I),I=1,KMAX)
!
        WRITE(MRW10)(DC(I),I=0,MTGD)                               !REC3
        WRITE(MRW10)(IDC(I),I=1,MTGDI)                             !REC3
        WRITE(MRW10)(JYI(I),I=1,KMAX),(JYF(I),I=1,KMAX),                &
     &              (QBML(I),I=1,NSS),(QBMS(I),I=1,NSS),                &
     &              (QLMC(I),I=1,NESS),(JTGD(I),I=0,NTT),               &
     &              (QTGS(I),I=1,NTT),(QTGL(I),I=1,NTT),                &
     &              (QTGD(I),I=1,NTT)
!
! THIS IS A PARTIAL DUMP OF THE RESTART AFTER THE CALL TO ALGEB2
! (NOT EVERYTHING IS NECESSARILY NEEDED).
!                                                                  !REC2
        WRITE(MRW10)IADD,IRK,IRKO,IRL,MTGD,MPOL00,MPOLE,IOS,NXLL,KUTLS, &
     &              NSL0,NMETA,MXORBR
!                                                                  !REC3
        WRITE(MRW10)(NGRPI(I),I=1,NSL0),(NSL(I),I=1,NSL0),              &
     &              (QSI(I),I=1,NSL0),(QLI(I),I=1,NSL0),                &
     &              (QPI(I),I=1,NSL0),(NMETAG(I),I=0,NSL0),             &
     &              ((KGSL(I,J),I=1,KMAX),J=1,NSL0),(NADG(I),I=1,NSL0), &
     &              (NFI(I),I=1,NTT),(NFK(I),I=1,NTT),(NFQ(I),I=1,NTT)
!
! THIS IS A PARTIAL DUMP OF THE RESTART AFTER THE CALL TO ALGEB3
! (NOT EVERYTHING IS NECESSARILY NEEDED).
!
        WRITE(MRW10)NJO,IRS,NL,IADJ8,IADJ0,IRKP,IRLP,NLEV,NMETAJ   !REC4
!
        IF(NJO.EQ.0)THEN                          !LS
          WRITE(MRW10)NJO                                          !REC5
        ELSE                                                       !REC5
          WRITE(MRW10)NJO,(NRR(I),I=1,NLEV),(NT(I),I=1,NJO),            &
     &                (JN(I),I=1,NLEV),(NGR(I),I=1,NLEV),               &
     &                (NMETGJ(I),I=1,NJO),((NSLJ(J,I),J=1,NSL0),I=1,NJO)&
     &                ,(NGSLJ(I),I=1,NJO)
!     &           ,(NTJ(I),I=1,KMAX),(NFJ(I),I=1,NLEV)
        ENDIF
!
! ANY/EVERYTHING ELSE IS RE-CREATED OR STILL HELD IN MEMORY.
! TBD: ALL IS DUMPED/RE-CREATED SO THAT CAN IMPLEMENT COLLISION ALGEBRA
! RESTARTX.
!
      ELSE
        IF(IUNIT(MRW10).GT.0.AND..NOT.BLOOP)THEN
          IUNIT(MRW10)=-1
          CLOSE(MRW10)
        ENDIF
      ENDIF
!
 1800 CONTINUE
!
      IF(MPRINT.LE.-3)THEN
        WRITE(MW6,10030)MPRINT
        IF(BLOOP.AND.LNEW.LT.LMAX)NF0=NF
        IF(NF.GT.0)NF=0
      ENDIF
!
      IF(NF.LT.0.AND..NOT.BSTART.AND.BPASS.AND.MSTART.GT.1)             &
     &   WRITE(MW6,10080)
!      write(mw0,*)nl,nl000,mbp1mx,mbp2mx,mekvmx,mpole
!
      IF(BREL)NPRINT=MOD(NPRINT,IFIVE)
!
!
 1900 CONTINUE
!
!-----------------------------------------------------------------------
!
! FINALIZE:
!
! IDW=0 (CLOSE) WRITE/READ DC ARRAY TO/FROM DISK
! IDW>0 REPOINT/REWIND FOR ALGX BRANCH
!
      IF(BDISK)THEN                                      !BREAK TESTS...
        IF(IUNIT(IUD).GT.0)CALL DISKDC(IUD,IDW,IZERO,IZERO,IZERO,IZERO, &
     &                                 MSTRT0)
      ENDIF
!
!-----------------------------------------------------------------------
!
! DE-ALLOCATE
!
! LOCAL
      IF(ALLOCATED(JYI))DEALLOCATE(JYI,JYF)
!
! EX-COMMON/QTG/
      IF(ALLOCATED(JTGD))THEN
        DEALLOCATE(JTGD,QTGS,QTGL,QTGD,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)                                                  &
     &              'ALGEB: DE-ALLOCATION FAILS FOR JTGD,QTGS,QTGL,QTGD'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBGCF/
      IF(ALLOCATED(KGCF))THEN
        DEALLOCATE(KGCF,NKSL,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB: DE-ALLOCATION FAILS FOR KGCF,NKSL'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBGCF/
      IF(ALLOCATED(KGSL))THEN
        DEALLOCATE(KGSL,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB: DE-ALLOCATION FAILS FOR KGSL'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! LOCAL
      IF(ALLOCATED(DC))THEN
        DEALLOCATE(DC,IDC,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB: DE-ALLOCATION FAILS FOR DC,IDC'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! LOCAL
      IF(ALLOCATED(MAM))THEN
        DEALLOCATE(MAM,NAM,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB: DE-ALLOCATION FAILS FOR MAM,NAM'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! LOCAL
      IF(ALLOCATED(QBMS))THEN
        DEALLOCATE(QBMS,QBML,QLMC,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB: DE-ALLOCATION FAILS FOR QXXX'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! LOCAL
      IF(ALLOCATED(QLMS))THEN
        DEALLOCATE(QLMS,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB: DE-ALLOCATION FAILS FOR QLMS'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
!
 2000 CONTINUE
!
!-----------------------------------------------------------------------
!
      if(btime)then
        call nrb_time(timef)
        times=timef-time0
!
        if(bloop)write(iw,*)'l=',lnew
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Ending proc',iam,' for algeb:'            !par&
!par     &               ,' time=',nint(times),'sec,     '          !par&
!par     &               ,nint(times/60),'min'                      !par
!par          call flush(iw)                                        !par
!par        else                                                    !par
        write(iw,*)'Total algeb: time=',nint(times),'sec,     ',        &
     &             nint(times/60),'min'
!par        endif                                                   !par
      endif
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
 2100 WRITE(MW6,*)'*** RESTART ERROR - PROBABLY DUE TO INCONSISTENT',   &
     &            ' MSTART FOR STATE OF RESTART FILE...'
      WRITE(MW0,*)'*** RESTART ERROR - CHECK MSTART ***'
      NF=0
      GO TO 1900
!par!                                                               !par
!par 5000 continue                                                  !par
!
 2200 NF=-1
      GO TO 1900
!
 2300 NF=0
      WRITE(MW6,10020)
      WRITE(MW0,*)'***SR.ALGEB: STORAGE EXCEEDED ***'
      GO TO 1900
!
!-----------------------------------------------------------------------
!
!     COMMENT TO SR VCU AND VCG (CALLED IN SR ALGEB1)
!
!-----------------------------------------------------------------------
!
!  KF.GT.KCUT(.GT.0):  ONLY THOSE TERMS RETAINED THAT SERVE AS
!           CORRELATION TERMS TO TERMS OF PREVIOUS CONFIGURATIONS KF.
!
!  MODD.EQ.0:
!      ALL VCC FOR ALL COMPLETE TERMS I OF CONFIG C  STORED IN DC
!WE    PROVIDED KCUT=0 IS SPECIFIED (WHICH DEFAULTS TO KCUT.GE.KF)
!WE    OTHERWISE RESTRICTIONS ON MS APPLY: SEE LOOP DO33.
!WE    COLFS MAY HAVE TO BE OPENED FOR FS-COLLISION PROBLEMS.
!NRB***OLD RESTRICTIONS SUPPRESSED NOW THAT WE RE-COUPLE SUB-SHELLS
!
!  MODD.EQ.1:
!      ONLY VCC FOR SLATER-STATES WITH /ML=MS/=MIN OF ALL TERMS I OF C
!
!  MODD.EQ.2:
!      ONLY VCC FOR SLATER-STATES WITH ML=0,MS=MIN OF ALL TERMS I OF C
!
!  MODD.EQ.-1,-2
!      EQUIV TO +1,+2 FOR ML,MS.LT.0, BUT ALL -,-.GT.0 RETAINED
!
!  MODD.GE.3:
!      ONLY SLATER-STATES AND VCC WITH ML=L,MS=S OF TERM 2S=QCS0,2L=QCL0
!
!  MODD.LE.-3:
!      ANY ML=L-1 ALSO INCLUDED (KCUT IGNORED FOR ABS(MODD).GE.3)
!
!-----------------------------------------------------------------------
!
10010 FORMAT(//" SR.ALGEB: STORAGE EXCEEDED IN VCU"//18X,               &
     &"'DISK'=-3 IF TOO MANY SLATER STATES ((JB').GT.MAXST), -2 IF TOO "&
     &,"MANY TERMS (SUM(ND).GT.MAXCT), -1 IF TOO MANY VCC ",            &
     &",(MTGD.GT.MAXDC)"//"  AUGMENT MXST0 (IN CASE -3),  AUGMENT  ",   &
     &"MAXTM (IN CASE -2),  AUGMENT  MAXDC (IN CASE -1):   DISK=",I8)
10020 FORMAT(//' **** SR.ALGEB: STORAGE EXCEEDED - UNABLE TO ALLOCATE', &
     &       ' ANY MORE MEMORY - REDUCE SIZE OF PROBLEM ****'//)
10030 FORMAT(/' THIS WAS NO MORE THAN A DIMENSION CHECK -- MPRINT=',I2/)
10040 FORMAT(//"RESTART FILE '",2A4,"' READ BACK WITH MSTART=",I2//)
10050 FORMAT(//"SR.ALGEB CREATES RESTART FILE '",2A4,"', MSTART=",I2/)
10060 FORMAT(' ERROR IN RESTART ALGEBRA L-LOOP, FIRST L WRITTEN=',I3,   &
     &       ' BUT FIRST L TO BE READ=',I3)
10070 FORMAT(' *** WARNING: READ OF RESTART FILE GENERATED BY NON-',    &
     &       'RELATIVISTIC ORBITAL RUN - RETARDATION NEGLECTED!!')
10080 FORMAT(//'INCOMPLETE ALGEBRA RUN, BUT RESTART CANNOT BE RECOVERED'&
     &       /                                                          &
     & 'FIX PROBLEM AND RUN WITH MSTART=1, SET BPASS=.FALSE. TO BE ABLE'&
     & /' TO RECOVER ANY FUTURE INCOMPLETE RUN.')
10090 FORMAT('SR.ALGEB: ALLOCATION INCREASES TOTAL NO. OF SLATER STATES'&
     &       ,' IXEST=',I10,' .GT. MXEST=',I10)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE ALGEB
!
!                             *******************
!
      SUBROUTINE ALGEB0(DC0,MAXEL)
!
!-----------------------------------------------------------------------
!
!  SR.ALGEB0 READS USER INPUT, CONFIGURATIONS ETC, CONTROLLING ANGULAR
!  ALGEBRA OPERATION AND SETS-UP ACCORDINGLY FOR ITS SUBSEQUENT
!  GENERATION.
!  ALSO, CASE A.S., AUTOMATICALLY GENERATES N+1 ELECTRON CONFIGS FROM
!  N-ELECTRON TARGET, FOR BOUND-CONTINUUM PROBLEMS (DR/RR ETC.)
!
!     THIS ROUTINE IS SOMEWHAT MESSY DUE RETENTION OF EARLIER INPUT
!     FORMATS, SOME OF WHICH MAY NO LONGER WORK.......
!
!  IT IS CALLED BY:
!    SR.ALGEB
!
!  IT CALLS:
!    SR.CONFG0
!    SR.CONFG1
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!
!  IT CONTAINS:
!    SR.SO2NL
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam,nproc                      !par
!
      USE COMMON_ALGEB,  ONLY: MPRINT
      USE COMMON_ALGEB,  ONLY: IWRK1,IWRK2,MXD08,MXD10,IXD08
      USE COMMON_ALGEB,  ONLY: MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD     &
     &                        ,KFBUFF
      USE COMMON_ALGEB,  ONLY: BFANO
      USE COMMON_ALGEB,  ONLY: BFOT
!!      COMMON /BASIC/NF,KX,KG,K1,K2,MGAP(7)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,IBSK2=>IBSK2,KG=>IBSK3,IBSK4=>IBSK4,IBSK5=>IBSK5   &
     &              ,IBSK6=>IBSK6,IBSK7=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9&
     &              ,IBSK10=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_DBD2,   ONLY: QL,QN,DEY
      USE COMMON_JSPOR,  ONLY: JAXLV
      USE COMMON_MISC,   ONLY: BEIVEC,IDIAG
      USE COMMON_MISC,   ONLY: NF0,BNAME
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,KMAX,NEL,NPLUS1
      USE COMMON_QTG,    ONLY: JAXTM
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      use common_misc,   only: ione1,ione0
      use common_misc,   only: iw,iwp,btime,btimex
!
      USE COMMON_NRBAL0, ONLY: IRET0,LORIG,LMIN,MPRNT0,MOD0,MSTRT0,BPASS&
     &                        ,MLIT
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL1, ONLY: ISCALR
      USE COMMON_NRBAL2, ONLY: MDEL,MXORBR,MPOL00,MPOL0,MPOLE,MPOLX,CODE
      USE COMMON_NRBAL2, ONLY: MAXLAM0,MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBAL3, ONLY: MCFSS,KCFSS,KUTSS,KUTSO,QQCUT
      USE COMMON_NRBAL4, ONLY: MBP1MX,MBP2MX,MEKVMX,KUTM1,MPOLM,QCUT
      USE COMMON_NRBDR,  ONLY: IDR
      USE COMMON_NRBDR,  ONLY: NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR,NBOUND
      USE COMMON_NRBDR,  ONLY: LNEW,LCON,LSUM,LMAX,lcmin,BLOOP
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,NASTB,MINSTB,MAXSTB,MINLTB,MAXLTB,LSPIB  &
     &                        ,NASTJB,MINJTB,MAXJTB,JPIB,LFACT,JFACT    &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG0,NMETAG,NMETGJ
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,NASTJ                           &
     &                        ,MINJT,MAXJT,NEIGENJ
      USE COMMON_NRBKUT, ONLY: KCUTX,LSKUT,NASTK
      USE COMMON_NRBKUTP,ONLY: KCUTP0,KCUTP,LSKUTP,NASTKP
      USE COMMON_NRBLIM, ONLY: ECNTRB,ITANAL,BANAL
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,NAST                          &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBLSP, ONLY: LSPIP,NLSPIP,NASTP                       &
     &                        ,MINSTP,MAXSTP,MINLTP,MAXLTP
      USE COMMON_NRBLSS, ONLY: NESSH,NASTS,MINSTS,MAXSTS,MINLTS,MAXLTS
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
!p         &               ,MXBORB,MXVORB,MXFORB,NGRP   !& RM CONFG0 ARG
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD,BMVD0
      USE COMMON_NRBRN2, ONLY: BINDB,MENGB
      USE COMMON_NRBVAL, ONLY: BRAD,BAUGER
!par!                                                               !par
!par      use common_nrbpar, only: niam,liam,jiam,mapiam            !par&
!par     &                        ,lproc,nprocperl                  !par
!par      use common_nrbpar, only: num                              !par
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
      USE ADF00, ONLY: BADF00,MSC00,MXCONFH,QCFG0,QCFGX,JZ0,JZX,EXCITE
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (D1PT26=1.26_WP)
!
! SLAGEB
      CHARACTER(LEN=8) TITLE
      CHARACTER(LEN=5) RAD,AUGER
      CHARACTER(LEN=4) MLIT0,PHASE,COD,RUN
      CHARACTER(LEN=4) CUP,BORN,BASIS
      CHARACTER(LEN=3) CPU,TARGET,RAD3,MVD
      CHARACTER(LEN=1) XDR,XDR0,QLIT,C2C
!
! SMINIM
      CHARACTER(LEN=3) RADOUT,POTOUT,POTL,ORTHOG,STONLZ,MIXBV  !RAD,
      CHARACTER(LEN=4) POTIN,FAC                     !,MYRGE
      CHARACTER(LEN=5) PPOT
      CHARACTER(LEN=6) DDIAG,PRINT,TCC
      real(wp) maxe                                  !for gfortran "bug"
!par!                                                               !par
!par      character(len=2) name0                                    !par
!par      character(len=9) name                                     !par
!par!                                                               !par
!par      logical bex                                               !par
!par!                                                               !par
!par      parameter (irl5=6)              !5+1 now alg3/4 separate  !par
!
      ALLOCATABLE :: KCFS0(:),ITMP(:),JTMP(:),QCFG(:),MNAL(:),MXAL(:)
!
      DIMENSION MLIT0(2),COD(20),QLIT(0:10),C2C(21)
      DIMENSION I2I(21)
!
!-----------------------------------------------------------------------
!
      NAMELIST/SALGEB/                                                  &
     & AUGER,BASIS,BDISK,BFOT,BORN,BPASS,btop,                          &
     & CPU,CUP,                                                         &
     & ECNTRB,                                                          &
     & FACTJ,FACTL,                                                     &
     & ICFG,IDIAG,IDW,IFILL,INAST,INASTJ,IPAR,ISCALR,ITANAL,            &
     & IMINJT,IMAXJT,                                                   &
     & IMINLT,IMAXLT,                                                   &
     & IMINST,IMAXST,                                                   &
     & J2MIN,J2MAX,JNAST,IJNAST,                                        &
     & K1,K2,KCOR1,KCOR2,KCUT,KCUT0,KCUTCC,KCUTI,KCUTP,KORB1,KORB2,     &
     & KPOL0,KPOL1,KPOLE,KPOLM,KSUBCF,KUTDSK,KUTLS,KUTM1,KUTOO,KUTOOX,  &
     & KUTSO,KUTSS,KUTSSX,                                              &
     & LCMIN,LCON,LCON0,LCONI,LCONDW,LCONDWJ,LMAX,                      &
     & LRGLAM,LVMIN,LVMAX,LXTRA,                                        &
     & MBP1MX,MBP2MX,MEKVMX,                                            &
     & MAXJFS,MAXLAM,MXLAMX,MAXLX,MAXLOO,MCFSS,MDEL,MENGB,              &
     & MINJT,MAXJT,MINJTP,MAXJTP,                                       &
     & MINLT,MAXLT,MINLTP,MAXLTP,MINLTS,MAXLTS,                         &
     & MINST,MAXST,MINSTP,MAXSTP,MINSTS,MAXSTS               !ANSI LIMIT
      NAMELIST/SALGEB/                                                  &
     & MODD,MPRINT,MSTART,MSTRT0,MVD,MXCCF,MXCONF,MXVORB,               &
     & NAST,NASTJ,NASTJP,NASTP,NASTS,                                   &
     & NELEC,                                                           &
     & NMETA,NMETAJ,NMULTE,NMULTX,NPLUS1,NXTRA,                         &
     & NXPROM,NXCITE,LXCITE,NXCORE,EXCITE,nzion,                        &
     & PHASE,                                                           &
     & QCL0,QCS0,QCUT,QQCUT,                                            &
     & RAD,RUN,                                                         &
     & TARGET,TITLE,                                                    &
     & XDR
      NAMELIST/SALGEB/                                                  &
     & iw,iwp,btime,btimex,ione1                   !,ione0
!par      namelist/salgeb/                                          !par&
!par     & lproc,mapiam                                             !par
!
! N.B.
!     BREAK NAMELIST/SLAGEB/ FOR ANSI LIMIT 19 CONTINUATION LINES.
!
!     J2MIN,J2MAX,JNAST,IJNAST                    !RM STGJK VARIABLES
!     MBP1MX,MBP2MX,MEKVMX             !NOT FOR USER JOE TO MESS WITH
! !TBD IMPLEMENT: QQCUTX
!
!-----------------------------------------------------------------------
!
      NAMELIST/DRR/                                                     &
     & JND,LCON,LCON0,LINC,LMIN,LMAX,LORIG,LRANGE,                      &
     & NBOUND,NMESH,NMIN,NMAX,NRAD,NS0,NSW,NSX,RATN
!
!-----------------------------------------------------------------------
!
      NAMELIST/SMINIM/                                                  &
     & AJUSTX,ALAV,ALFD,ATM,badas,                                      &
     & BALAN,BEIVEC,                                                    &
     & CMXLSA,CMXLSR,CMXICA,CMXICR,                                     &
     & DDIAG,DEFLAM,DHNS0,DLAMX,DLAMDX,DLAMQX,                          &
     & ECNTRB,ECORR,ECORRJ,EIMXLS,EIMXIC,EIONPOT,ESKPL,ESKPH,           &
     & FAC,FAC_AHX,FAC_HXS,FAC_IHX,FAC_HX0,FAC_HX1,fac_csi,faca,facsp,  &
     & ibreit,IBWRM,ICAV,IDIAG,IFIX,IFLAGV,ifacy,                       &
     & IGAGR,IGAUGE,IMAXIT,INCLUD,INUKE,IOPTIM,IORT,IPOLFN,IREL,irtard, &
     & ISHFTLS,ISHFTIC,ISTATIC,ITANAL,ITOL,IWGHT,IXTRA,IZESP,           &
     & JPRINT,JRAD,JLOWMN,JLOWMX,JUPMN,JUPMX,                           &
     & KCUT,KORT,KTCC,KUTCA,KUTCAS,KUTDSK,KUTLS,                        &
     & LDIAG,LLOWMN,LLOWMX,LUPMN,LUPMX,                                 &
     & M,MAXE,MAXLAM,MCFMX,MCFSTOX,MDELE,MDEN,MEXPOT,MEXTRE,MGRP,MHF,   &
     & MIXBV,MPNCH,MPRINT,MPSEUD,MRAD,MRED,MSTEP,MULTS,                 &
     & NDEN,NGAPSTO,NEIGEN,NEIGENJ,NFIX,NLAM,NLAMD,NLAMQ,NMETAP,NMETAPJ,&
     & NMETAR,NMETARJ,NOCC,NOCCX,NPE,NPITER,NRSLMX,NVAR,NVARD,NVARQ,    &
     & NZION,                                                           &
     & ORTHOG,                                                          &
     & POTIN,POTL,POTOUT,PPOT,PRINT,                                    &
     & QED                                                   !ANSI LIMIT
      NAMELIST/SMINIM/                                                  &
     & RAD,RADOUT,RCAV,RCUT,RMIN1,RMIN2,RNUKE,RZERO,                    &
     & SCALER,SKIN,STOLB,STONLZ,                                        &
     & TCC,TINORB,TK0,TOLB,TOLE,TOLTCC,TVARY,                           &
     & WLG1,WLG2,                                                       &
     & XBEE,xmax,XMIX
!
!-----------------------------------------------------------------------
!
      NAMELIST/SRADWIN/KEY                                 !FOR CHECK
!
!-----------------------------------------------------------------------
!
      DATA QLIT/' ','0','1','2','3','4','F','S','Q','W','X'/
!
!-----------------------------------------------------------------------
!
      QKCUT=INT(ICHAR('1'),QP)
      LBLNK=ICHAR(' ')
!
!-----------------------------------------------------------------------
!
! LOOK AHEAD TO SEE IF USER HAS SET A FAC OPTION
!
      IFAC=-1
      POTIN='  '
      PPOT='   '
      FAC='  '
!
      READ(MR5,SMINIM,END=100)
!
      POTIN=STRUPCASE(POTIN)
      PPOT=STRUPCASE(PPOT)
      FAC=STRUPCASE(FAC)
!
      IF(PPOT.EQ.'FAC'.OR.FAC.EQ.'FAC'.OR.PPOT.EQ.'RATS'.OR.            &
     &   FAC.EQ.'RATS')THEN                            !SIMPLE USER FLAG
        FAC='YES'
        PPOT='SCCA'
      ENDIF
!
      IF(POTIN.EQ.'FAX'.OR.FAC.EQ.'FAX')THEN
        IFAC=1
      ELSEIF(POTIN.EQ.'FAC'.OR.FAC.EQ.'YES')THEN
        IFAC=0
      ENDIF
!
  100 REWIND(MR5)
!
!-----------------------------------------------------------------------
!
! SOME INITIALISATIONS (MANY CAN BE SET VIA NAMELIST)
!
      btime=.false.                 !detailed structure timing
      btimex=.false.                !detailed collision timing
      iw=0                    !=0 to screen, =6 to file, if btime .true.
      iwp=0                         !just initialize for non-par common
!par!                                                               !par
!par      iwp=6                   !suppress some screen writes      !par
!par      lproc=0                   !nproc used for mstart=1        !par
!par      mapiam=0          !.le.0 nprocperl;.eq.1 for 1 proc per n !par
!par      nprocperl=1               !default, no n-parallel         !par
!
      KMAX=999                      !POSSIBLE NASTP BUFFER FOR S.S.
      KUTDSK=9999                   !VCC FOR CF.LE.KUTDSK IN MEMORY
      NSL0=0                        !LS/IC FLAG
      DC0=DONE
      NF=0
      IRET0=0
      IDW=0
      IDR=0
      BFOT=.FALSE.
      BMVD=.FALSE.
      BRAD=.TRUE.
      BAUGER=.TRUE.
      KPOLE=-999
      KPOL0=-999
      KPOL1=60                        !MAX SAFE E-POLE (AVOID OVERFLOW)
      KPOLM=100
      IEQ0=0
      MENGB=-2
      IRLX=0
      IDIAG=0         ! TRY SR.DIAG FIRST FOR DIAGONALIZATION OF S/L**2
      ICFG=0
      QQCUT=0         ! 1 ALL 2FS, 2 SO, 3 SOO, 4 SS
      MAXLAM=MAXLAM0  !MAX SLATER LAMBDA MULTIPOLE INTERACTION
      NMULTE=999      !NUMBER OF MULTIPOLES PER INTERACTION
      KUTLS=99999
      KUTM1=0
      ISCALR=0
      ITANAL=0
      ECNTRB=9999999
      LCMIN=-999
!
      INASTJ=0
      IMINJT=0
      IMAXJT=-2000
      NASTJ=0
      MINJT=0
      MAXJT=2000
      NASTJP=0
      MINJTP=0
      MAXJTP=2000
      INAST=0
      IMINST=0
      IMAXST=100
      IMINLT=0
      IMAXLT=-1000
      NAST=0
      MINST=0
      MAXST=100
      MINLT=0
      MAXLT=1000
      IPAR=2
      NASTS=0
      MINSTS=0
      MAXSTS=100
      MINLTS=0
      MAXLTS=1000
      NASTP=0
      MINSTP=0
      MAXSTP=100
      MINLTP=0
      MAXLTP=1000
      MAXLX=MAXLT
      MAXLOO=MAXLT
      MXLAMX=1000
      NMULTX=999
      KUTLSX=99999     !not active as no partition yet, use kutls=0 then
      MAXJFS=-999
      KUTSSX=-1937
!TBD      QQCUTX=1     !=1 HARD-WIRED WHERE USED FOR NOW
      KUTOOX=-999
      LFACT=100
      JFACT=200
!
      NMETA=0
      NMETAJ=0
      ione0=0         !algxls/fs ione1, elastic needed for mixing
      ione1=1         !=1/0 exc/inc elastic transitions: idw.ne.0
!
      LCONDW=0
      LCONDWJ=0
      LRGLAM=-999     !TOP-UP FLAG (L/2J)
      LVMIN=0         !RYDBERG L-RANGE FOR THRESHOLD DW
      LVMAX=-1        !WRITES TO ADF04 FOR ADF46 BBGP USE
      btop=.true.     !fix for born top-up failure
!
      KSUBCF=999      !FULL SUBCONFIGURATION RESOLUTION
      KCUTP=-9999     !PARENT CF CORRELATION
      KCUTCC=0        !N+1 BOUND CF CORRELATION
      KCUT0=0         !CONT CORE RE-ARRANGE CORRELATION (=KCUTI)
!
! READ CODE
! CODE(1).EQ.'S.S.' FOR ORIGINAL EISSNER (SS) INPUT OF CONFIGURATIONS
! CODE(1).EQ.'A.S.' FOR OCCUPATION NUMBERS.
! CODE(2-20) FOR INFORMATION PURPOSES.
!
      READ(MR5,10150)COD
!
      WRITE(MW6,10160)COD
!
      CODE=COD(1)
      CODE=STRUPCASE(CODE)                       !CONVERT ANY LOWER CASE
!
      IF(CODE.NE.'S.S.'.AND.CODE.NE.'A.S.')THEN
        IF(CODE.EQ.'STOP')THEN                               !CANCEL JOB
          IRET0=1
          GO TO 900                                              !RETURN
        ENDIF
        WRITE(MW6,10170)CODE
        WRITE(MW0,*)                                                    &
     &            "INPUT ERROR:NEED 'S.S.' OR 'A.S.' AT START OF LINE 1"
        GO TO 1200
      ENDIF
!
!-----------------------------------------------------------------------
!
! ORIGINAL SS INPUT (EISSNER NOTATION FOR CONFIGS)
!
      IF(CODE.EQ.'S.S.')THEN
!
        IXD08=MXD08
        ALLOCATE(IWRK1(IXD08),IWRK2(IXD08),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB0: ALLOCATION FAILS FOR IWRK1,IWRK2'
          NF=0
          GO TO 800
        ENDIF
!
        BNAME=.FALSE.
        READ(MR5,SALGEB,END=150)       !BUT SEE IF WE HAVE NAMELIST ELSE
        BNAME=.TRUE.
  150   REWIND(MR5)
        READ(MR5,*)
!
! IN IF-LOOP 96 CARDS ARE READ UNTIL A TERMINATOR IS FOUND
! (A CARD THAT IS BLANK IN T10,I2 IS REFERRED TO AS A C-TERMINATOR).
!
        I=0
        KH=I
  200   KG=KH
!
        I=I+21
        IF(I.GT.IXD08)THEN
          IXXX=7*(IXD08/5+1)
          IXXX=MAX(I,IXXX)
!
          CALL RE_ALLOC(IWRK1,IONE,IXD08,IXXX,IERR1)
          CALL RE_ALLOC(IWRK2,IONE,IXD08,IXXX,IERR2)
!
          IF(IERR1+IERR2.NE.0)THEN
            WRITE(MW0,*)'ALGEB0: RE-ALLOCATION FAILS FOR IWRK1,IWRK2'
            NF=0
            GO TO 800
          ENDIF
          IXD08=IXXX
        ENDIF
!
        KF=KH+1
        KH=I
!
        READ(MR5,10040)MSTRT0,IFREE,QCS0,QCL0,XDR0,                     &
     &                 (I2I(J),C2C(J),J=1,21),MLIT
!
        J=0
        DO K=KF,KH
          J=J+1
          IWRK2(K)=I2I(J)
          IWRK1(K)=ICHAR(C2C(J))
        ENDDO
!
! A TERMINATOR AS FIRST CONFIGURATION CARD CANCELS THE JOB
!
        IF(IWRK2(1).EQ.0)THEN
          IRET0=1
          GO TO 900                                         !RETURN
        ENDIF
!
! OTHERWISE (T10,21(I2,Z1)) EXCEPT ON THE TERMINATOR ARE READ AS A
! STRING OF Q=MOD(C(I2),50) EQUIVALENT ELECTRONS NL=FUNCTION(C(Z1));
! Q+50 STANDS FOR: THESE Q ELECTRONS FORM A CONFIGURATION TOGETHER
! WITH WHAT STANDS LEFT OF IT.
! EXAMPLE: ' 22523 12533' IN COLUMNS 10..21 WILL BE INTERPRETED (IN
! SR ALGEB1) AS TWO CONFIGURATIONS, 2S**2+2P**2 AND 2S+2P**3,
! PROVIDED THE TERMINATOR IS BLANK IN COLUMNS 16..60; THEN K=C(Z1)=
! 1,2,3,..9,A,..F STANDS FOR 1S,2S,2P,..4D,4F,..5G.
! THE STRING MAY BE BROKEN BY A MULTIPLE OF THREE GAPS AFTER ANY
! CONFIGURATION, BUT ON THE NEXT CARD IT MUST CONTINUE IN T10,I2,Z1.
!
! MPRINT=-5,-6,-7: SAME AS 0,-1,-2 BUT KAPPA-AVERAGE RADIAL FUNCTIONS.
!
        IF(KF.EQ.1.AND..NOT.BNAME)THEN   !FIRST LINE DEFINES CONTROLS
          MPRINT=MSTRT0
          MODD=IFREE
          MLIT0(1)=MLIT(1)
          MLIT0(2)=MLIT(2)
          K1=QCS0
          K2=QCL0
          XDR=XDR0
          XDR=STRUPCASE(XDR)
        ENDIF
!
! ON THE SECOND AND FOLLOWING CARDS COLUMNS 1..9 AND 73..80 ARE
! IGNORED; THE LAST 8 COLUMNS OF THE FIRST CARD ARE PRINTED AT THE
! BEGINNING OF THE HEADLINE (AS LITERAL DATA); C(T1,I2)=BLANK SUP-
! PRESSES PRINTOUT OF SLATER STATES AND OF ALL ANGULAR COEFFICIENTS.
! C(T3,I2)=MODD IS INPUT TO SR VCU AND IS DESCRIBED BELOW;
! FOR THE PROBLEMS DEALT WITH HERE MODD=-1 SUFFICES.
! C(T5,I2)=K1 AND C(T7,I2)=K2 WILL BE INTERPRETED AS FOLLOWS: K1..K2
! FORM A CORE CONFIGURATION C0 OF CLOSED SUBSHELLS WHICH WILL BE ADD
! ED ONTO ALL CONFIGURATIONS LISTED IN THE STRING BEHIND (AN ORBITAL
! (N,L) SPECIFIED IN BOTH PLACES WILL BE IGNORED IN THE LATTER).
!
        IF(IWRK2(KF).NE.0)GO TO 200
!
        IF(I.GT.IXD08)THEN                      !NOT ENOUGH BUFFER SPACE
          KGG=I
          GO TO 500
        ENDIF
!
      ELSE
!
! 'A.S.' R-MATRIX STYLE INPUT, AND SO .....
!
        BNAME=.TRUE.
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      IF(BNAME)THEN               !INITIALIZE CONTROLS FOR S.S. AND A.S.
!
        K1=0
        K2=0
        MPRINT=-2
        MODD=-999
        XDR=' '
        PHASE='    '
        TITLE='        '
!
      ENDIF
!
! SYNCHRONISE FILES
!
      IF(.NOT.BLOOP.OR.LSUM.LE.0)THEN
        IF(IUNIT(MW7).GT.0)BACKSPACE(MW7)
        IF(IUNIT(MW8).GT.0)BACKSPACE(MW8)
        IF(IUNIT(MW17).GT.0)BACKSPACE(MW17)
        IF(IUNIT(MW18).GT.0)BACKSPACE(MW18)
        IF(IUNIT(MW27).GT.0)BACKSPACE(MW27)
        IF(IUNIT(MW28).GT.0)BACKSPACE(MW28)
        IF(IUNIT(MW29).GT.0)BACKSPACE(MW29)
        IF(IUNIT(MW30).GT.0)BACKSPACE(MW30)
      ENDIF
!
!-----------------------------------------------------------------------
!
      IF(CODE.EQ.'S.S.')THEN
!
!
! COLUMNS 16..60 OF THE TERMINATOR ALLOW FOR REDEFINING K=1,2,3..15:
! IF THE K'TH (I2,I1) IS NOT BLANK  NK=C(I2)+LK=C(I1) (IN ALGEB1).
! IF(T63,A1) IS NON-ZERO CODING CONTINUES ON NEXT CARD 15(I2,A1)
! COLUMNS 16 TO 60.
! THIS PROVIDES AN ALTERNATIVE DEFINITION OF ORBITALS TO SCREENING
! PARAMETER IN SR.MINIM ( IF BOTH ARE USED THE LATTER HOLDS TRUE)
! NAMELY:
! N=1-69 BOUND ORBITALS CALCULATED IN SR.RADIAL
! N=70-79 ORBITALS INPUT FROM SR.RADWIN
! N=80-89 VALENCE ORBITALS TO BE SUMMED OVER IN DR PART OF PROGRAM
! N=90-99 CONTINUUM ORBITALS CALCULATED IN SR.RADCON
!
! EVT  IF(IWRK1(KH).EQ.QX)GO TO 96 ,  WHERE  DATA..QX/'X'/.
!
        IF(.NOT.BNAME)THEN
          QCUT=INT(IWRK1(KH),QP)
          MDEL=IFREE               !OMIT RADIATION WITH N-N' .LT. MDEL
          KCUT=IWRK2(KF+1)
          IF(IWRK1(KF).EQ.QKCUT)KCUT=KCUT+100
          KUTSS=IWRK2(KH)
          MCFSS=0
!         MCFSS=IWRK2(KH-1)
!         KUTOO=0
          KUTOO=IWRK2(KH-1)
          KUTSO=IWRK2(KG+19)
          MBP1MX=-1
          MBP2MX=1
          MEKVMX=1
          BPASS=.FALSE.
        ENDIF
!
        KGG=KG+18
        I=KH
  250   IF(IWRK1(KGG).EQ.LBLNK)GO TO 300
!
        I=I+21
        IF(I.GT.IXD08)THEN
          IXXX=7*(IXD08/5+1)
          IXXX=MAX(I,IXXX)
!
          CALL RE_ALLOC(IWRK1,IONE,IXD08,IXXX,IERR1)
          CALL RE_ALLOC(IWRK2,IONE,IXD08,IXXX,IERR2)
!
          IF(IERR1+IERR2.NE.0)THEN
            WRITE(MW0,*)'ALGEB0: RE-ALLOCATION FAILS FOR IWRK1,IWRK2'
            NF=0
            GO TO 800
          ENDIF
          IXD08=IXXX
        ENDIF
!
        KF=KH+1
        KH=I
!
        READ(MR5,10050)(I2I(J),C2C(J),J=1,21)
!
        J=0
        DO K=KF,KH
          J=J+1
          IWRK2(K)=I2I(J)
          IWRK1(K)=ICHAR(C2C(J))
        ENDDO
!
        IF(I.LE.IXD08)KGG=KGG+21
        GO TO 250
!
  300   IF(I.GT.IXD08)THEN                      !NOT ENOUGH BUFFER SPACE
          KGG=I
          GO TO 500
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! BOTH CODES ('A.S.' IS NAME ONLY ALLOWED).
!
      IF(BNAME)THEN
!
        MSTRT0=0
        MSTART=0
        BPASS=.TRUE.
        MCFSS=0
        KUTSS=-1
        KUTSO=-1
        KUTOO=0
        MDEL=0
        KCUT=0
        QCS0=0
        QCL0=0
        QCUT=0
        RUN='  '
        CUP='  '
        RAD='  '                !TAKES DEFAULT MPRINT=-2, NONE
        AUGER='   '
        KORB1=0
        KORB2=0
        KCOR1=0
        KCOR2=0
!        NAST=0
        LRANGE=-1
        BORN='  '
        BASIS='    '
        MBP1MX=-1               !MAX MULTIPOLE 1-BODY BP MK
        MBP2MX=0                !MAX MULTIPOLE 2-BODY BP MK - ONLY M1
        MEKVMX=-1               !MAX MULTIPOLE FOR EK REL VEL
        FACTL=DONE
        FACTJ=DONE
        CPU='MEM'               !OPTIMIZE FOR MEMORY ANYTHING ELSE SPEED
        TARGET='NEW'            !FLAG USE OF OLD/NEW TERMS/LEVELS FILES
        BDISK=.FALSE.           !STORE *ALL* DC ARRAY ON DISK
        MVD='   '               !YES/NO OVERRIDES ANY CUP, ESP 'IC'.
!
! THESE NEXT ARE ONLY USED BY 'A.S.'
!
        MXVORB=0                !MUST BE RESET
        MXCONF=0                !MUST BE RESET
        MXCCF=-999
        NXTRA=-1
        LXTRA=-1
        IFILL=-11
        NPLUS1=1               !SR.CONFG N+1 USER GENERATOR FLAG (1 OR 2)
!
! CASE MXCONF.LT.0: GROUND CFG PROMO RULES TO RETAIN LOWEST -MXCONF CFGS
! EXISTING NXTRA, LXTRA CAN BE USED TO EXPAND/RESTRICT ORBITAL SET
!
        NELEC=0                !MUST BE SET THEN (NO. TARGET ELECTRONS)
        NXPROM=2               !MAX NO. OF ELECTRON PROMOTIONS
        NXCITE=1               !MAX N CHANGE IN PROMOTION
        LXCITE=1               !MAX L CHANGE OF PROMOS
        NXCORE=99              !PROMOTE CLOSED SHELLS ORBS .GT. NXCORE
        EXCITE=-1              !RETAIN ALL CFGS WITHIN EXCITE OF GROUND
!
        LMAX=-1
        LCON=-1
        LCON0=-1                !INNER-SHELL
        LCONI=LCON0             !ALTERNATE
        KCUTI=KCUT0             !ALTERNATE
!
        JNAST=-1                !RM
        IJNAST=-1               !RM
        J2MIN=-1                !RM
        J2MAX=-1                !RM
!
!
        READ(MR5,SALGEB,END=1000,ERR=1000)  ! <---------------- NAMELIST
!
!
! SYNC. ALTERNATES
!
        LCON0=MAX(LCON0,LCONI)
        KCUT0=MAX(KCUT0,KCUTI)
        NASTJ=MAX(JNAST,NASTJ)
        INASTJ=MAX(IJNAST,INASTJ)
        MINJT=MAX(J2MIN,MINJT)
        MAXJT=MAX(J2MAX,MAXJT)
!
        PHASE=STRUPCASE(PHASE)
        MLIT0(1)=PHASE
        MLIT(1)=TITLE(1:4)
        MLIT(2)=TITLE(5:8)
!
! SET MAIN "RUN" SWITCHES:
!
        RUN=STRUPCASE(RUN)
!
        BDR=RUN.EQ.'DR'.OR.RUN.EQ.'RR'.OR.RUN.EQ.'RE'.OR.RUN.EQ.'PE'
        BFOT=BFOT.OR.RUN.EQ.'RR'.OR.RUN.EQ.'PI'
!
! HISTORIC READ TOO LATE FOR LCON & LMAX...(ALTHOUGH ALSO IN SALGEB NOW)
!
        IF(BDR)THEN
          IDR=1                                     !FLAG EXPECT RYDBERG
          REWIND(MR5)                  !CASE USER NAMELISTS OUT OF ORDER
          READ(MR5,DRR,END=1100,ERR=1100)         !case LCON only in DRR
          REWIND(MR5)                                    !REPOSITION FOR
          READ(MR5,SALGEB)                           !NON-NAMELIST READS
!          if(lcon.gt.0)lcon=2*(lcon/2)+1                    !ensure odd
        ENDIF
!
        IF(CODE.EQ.'A.S.'.AND.MXVORB.GT.0)THEN  !CHECK FOR ANY (ILLEGAL)
!                                               !ORBITAL FLAGS
          IF(KCOR2.LT.0)THEN
            MXVORB=MXVORB-KCOR2
          ELSEIF(KORB2.LT.0)THEN
            MXVORB=MXVORB-KORB2
          ENDIF
          ALLOCATE(ITMP(MXVORB),JTMP(MXVORB))                     !LOCAL
          READ(MR5,*)(ITMP(I),JTMP(I),I=1,MXVORB)
          IFLAG100=0
          IFLAG70=0
          IFLAGN60=0
          IFLAGL60=0
          if(iunit(MR12).ne.0)then                           !for radwin
            n69=69
          else
!            n69=79                    !needs radwin present if external
            n69=69       !restrict to 60-9 normally, can extend to 79...
          endif
          n69=-n69        !switch-off use, as likely superceded by kutls
          IFLAG00=0
          DO I=MXVORB,1,-1
            IF(ITMP(I).GE.100)IFLAG100=ITMP(I)
            IF(ITMP(I).GE.80.AND.ITMP(I).LE.89)IDR=1    !RYDBERG PRESENT
            IF(ITMP(I).GE.70.AND.ITMP(I).LE.79)IFLAG70=ITMP(I)
            IF(ITMP(I).GE.60.AND.ITMP(I).LE.N69.AND.IFLAGL60.EQ.0)THEN
              IFLAGN60=ITMP(I)
              IM=MOD(ITMP(I),I60)
              IF(IM.LE.JTMP(I))IFLAGL60=JTMP(I)+1              !HOLD L+1
            ENDIF
            IF(ITMP(I).LE.0)IFLAG00=ITMP(I)
          ENDDO
          DEALLOCATE(ITMP,JTMP)
!
! use RUN='RYD' to keep target rydberg configs for PWB and ='   ' to be
! able to drop configs when such in target via core re-arrangement Auger
! when using run_PP script (non-script, user can simply re-set mxconf)
!
          IF(RUN.EQ.'RYD')THEN              !ALLOW RYD FOR PWB
            RUN='   '
          ELSEIF(RUN.EQ.'   ')THEN          !RYD CONFGS DROPPED
            IDR=0
          ENDIF
!
          IF(IFLAG00.NE.0)THEN
            WRITE(MW6,10070)IFLAG00
            WRITE(MW0,*)'*** ERROR: ILLEGAL INPUT N-VALUE=',IFLAG00
          ENDIF
          IF(IFLAG100.GT.0)THEN
            WRITE(MW6,10080)IFLAG100
            WRITE(MW0,*)'*** ERROR: UNSUITABLE INPUT N-VALUE=',IFLAG100
          ENDIF
          IF(IFLAG70.GT.0)THEN
            KEY=0
            READ(MR5,SRADWIN,END=310,ERR=310)
  310       IF(IUNIT(MR12).EQ.0.AND.KEY.NE.-10)THEN
              WRITE(MW6,10090)IFLAG70
              WRITE(MW0,*)'*** ERROR: NO radwin FILE FOUND FOR N-VALUE='&
     &                    ,IFLAG70
            ELSE
              IFLAG70=0
            ENDIF
          ENDIF
          IF(IFLAGN60.GT.0)THEN
            WRITE(MW6,10100)IFLAGN60
            WRITE(MW0,*)'*** ATTENTION: USER INPUT N-VALUE=',IFLAGN60,  &
     &                  ' IS RESERVED...'
          ENDIF
          IF(IFLAGL60.GT.0)THEN
            WRITE(MW6,10110)IFLAGL60-1,MOD(IFLAGN60,I60)
            WRITE(MW0,*)'*** ERROR:  ILLEGAL INPUT L-VALUE=',IFLAGL60-1,&
     &                  ' FOR ABOVE N-VALUE'
          ENDIF
!
          REWIND(MR5)                                    !REPOSITION FOR
          READ(MR5,SALGEB)                           !NON-NAMELIST READS
!
          IF(ABS(IFLAG00)+IFLAGL60+IFLAG70+IFLAG100.GT.0)THEN
            NF=-1
            GO TO 800
          ENDIF
!
        ENDIF
        LCONT=LCON
!
! CONVERT ANY LOWER CASE TO UPPER
!
        RUN=STRUPCASE(RUN)
        CUP=STRUPCASE(CUP)
        RAD=STRUPCASE(RAD)
        AUGER=STRUPCASE(AUGER)
        BORN=STRUPCASE(BORN)
        BASIS=STRUPCASE(BASIS)
        CPU=STRUPCASE(CPU)
        TARGET=STRUPCASE(TARGET)
        PHASE=STRUPCASE(PHASE)
        XDR=STRUPCASE(XDR)
        MVD=STRUPCASE(MVD)
!
! NOW SAFE TO REDEFINE NAMELIST VARIABLES
!
        IF(MSTART.NE.0)MSTRT0=MSTART                     !RESTART SWITCH
!
        IF(CPU.NE.'MEM')DC0=-DONE           !THEN OPTIMIZE VCC FOR SPEED
!
        IF(KUTDSK.LT.0)KUTDSK=0
        IF(BDISK.AND.KUTDSK.EQ.999)KUTDSK=0
!        IF(MSTRT0.GE.5)KUTDSK=999
!
        IF(NPLUS1.LE.0)NPLUS1=1
        NPLUS1=2*NPLUS1-1                  !REMAP USER INPUT TO SR.CONFG
!
        ione1=mod(abs(ione1),itwo)        !in/exclude elastic EIE
!
        IF(MAXLAM.LT.0)THEN                !HISTORIC USER FLAG NO CF-MIX
          MAXLAM=-MAXLAM
          IF(KUTLS.EQ.99999)THEN           !SET DIAG/ON/FS FLAG
            KUTLS=-1
          ELSE
            WRITE(MW0,*)                                                &
     &                'NOTE: USER SETTING OF KUTLS OVERRIDES MAXLAM < 0'
            WRITE(MW6,*)                                                &
     &                'NOTE: USER SETTING OF KUTLS OVERRIDES MAXLAM < 0'
          ENDIF
        ENDIF
!
! weak high-l ic transitions need nmulte=l+1, where l=ql(n)/2 orbital-l,
! at least if PWB is anything to go by. normally, idw=1 nmultx=nmulte.
        IF(KPOLE.LT.-100)THEN
          IF(NMULTE.GT.100)NMULTE=7                !RESTRICT NO. LAMDAS
          IF(NMULTX.GT.100)NMULTX=7                !RESTRICT NO. LAMDAS
        ENDIF
!
        IF(KUTLS.LT.0)THEN
          WRITE(MW0,*)                                                  &
     &       '*** SR.ALGEB0: ATTENTION, CI-MIXING WITHIN A CONFIG ONLY!'
          WRITE(MW6,*)                                                  &
     &       '*** SR.ALGEB0: ATTENTION, CI-MIXING WITHIN A CONFIG ONLY!'
          KUTLS=-1
          IF(KUTSO.LT.-1.OR.KUTSO.EQ.0)THEN
            KUTSO=-1
            WRITE(MW0,*)                                                &
     &      '*** WARNING: ONE-BODY FINE-STRUCTURE IS NOW RESTRICTED TO '
            WRITE(MW0,*)                                                &
     &     '    BEING *WITHIN* A CONFIGURATION AS KUTLS OVERRIDES KUTSO'
            WRITE(MW6,*)                                                &
     &   '*** WARNING: KUTLS RESTRICTS ONE-BODY FINE-STRUCTURE TO BEING'&
     &   ,' *WITHIN* A CONFIGURATION, RESETTING KUTSO=',KUTSO
          ENDIF
          IF(KUTSS.LT.-1)THEN
            KUTSS=-KUTSS
            WRITE(MW0,*)                                                &
     &     ' *** WARNING: TWO-BODY FINE-STRUCTURE IS NOW RESTRICTED TO '
            WRITE(MW0,*)                                                &
     &    '     BEING *WITHIN* A CONFIGURATION AS KUTLS OVERRIDES KUTSS'
            WRITE(MW6,*)                                                &
     &  ' *** WARNING: KUTLS RESTRICTS TWO-BODY FINE-STRUCTURE TO BEING'&
     &  ,' *WITHIN* A CONFIGURATION, RESETTING KUTSS=',KUTSS
          ENDIF
        ENDIF
!
        IF(KUTOO.EQ.-1)KUTOO=0
!
!OLD        IF(IFILL.LT.0)IFILL=11      !NOW LET SR.CONFG USE NXCITE(CF)
!
! CANNOT DIFFERENTIATE BETWEEN USER OMISSION OF ICFG AND SCRIPTGENERATED
! STRUCTURE INPUT FOR SUBSEQUENT DR RUN. WRITEUP IS PLAIN...
!
        IF(MOD(MXCCF,I999).LT.0.AND.MOD(ICFG,ITEN).EQ.0)THEN
!          WRITE(MW0,*)
!     &        'NOTE: REQUIRE N-CFG ICFG.NE.0 TO AUTO-GENERATE N+1 CFGS'
          WRITE(MW6,*)                                                  &
     &         'NOTE: REQUIRE N-CFG ICFG.NE.0 TO AUTO-GENERATE N+1 CFGS'&
     &         ,' (CASE MXCCF.LT.0)'
        ENDIF
!
! PROCESS RUN OPTIONS:
!              (DR, RR, PE, PI, DE, RE, YLD - ALLOWED, DI NOT YET CODED)
!
        IF(RUN.EQ.'DIM'.OR.RUN.EQ.'DIM0'.OR.RUN.EQ.'DIM1'.OR.           &
     &     RUN.EQ.'DIM2')THEN                             !MUST OVERRIDE
          RAD3=RUN(1:3)
          RAD=RAD3
          RUN='   '
        ENDIF
!
        IF(RUN.EQ.'RYD')RUN='   '       !RE-SET (AGAIN)
!
        IF(RUN.NE.'  ')THEN             !CHECK FOR ALLOWED RUN VALUE
          IF(.NOT.BDR.AND..NOT.BFOT)THEN
            IF(RUN.EQ.'DI')THEN
              WRITE(MW6,*)'*** DIRECT ELECTRON IONIZATION NOT YET CODED'
              WRITE(MW0,*)'*** DIRECT ELECTRON IONIZATION NOT YET CODED'
              GO TO 1200
            ENDIF
            IF(RUN.EQ.'REDA')THEN      !'YLD' SHOULD NOT NEED A FLAG NOW
              WRITE(MW6,*)"*** RUN REDA AS 'RE' THEN 'YLD'"
              WRITE(MW0,*)"*** RUN REDA AS 'RE' THEN 'YLD'"
              GO TO 1200
            ENDIF
            IF(RUN.NE.'YLD'.AND.RUN.NE.'BBGP'.AND.RUN.NE.'DE')THEN
              WRITE(MW0,10230)
              WRITE(MW6,10230)
              WRITE(MW6,*)'*** UNRECOGNIZED RUN OPTION: "',RUN,'"'
              WRITE(MW0,*)'*** UNRECOGNIZED RUN OPTION'
              GO TO 1200
            ENDIF
          ENDIF
        ENDIF
!
        IF(RUN.EQ.'PE')THEN
          IDR=-1
          RUN='DR'      !PE JUST INVERSE OF DR
        ENDIF
!
        IF(RUN.EQ.'BBGP')THEN
          RUN='DE'
          IF(LVMAX.LT.0)LVMAX=8
        ENDIF
!
        IF(RUN.EQ.'DE')THEN
          LVMAX=MIN(LVMAX,I20)
          BTHRSH=LVMAX.GE.0.AND.LVMAX.GE.LVMIN
          IF(BTHRSH)LVMIN=MAX(IZERO,LVMIN)
        ELSE
          BTHRSH=.FALSE.
        ENDIF
        IF(.NOT.BTHRSH)THEN
          LVMAX=-1
          LVMIN=0
        ENDIF
!
        IF(RUN.EQ.'DE')IDW=1
        IF(RUN.EQ.'DI')IDW=2
!
        if(mstrt0.ne.0.and.IDW.ne.0)then
          stop "temp: a restart is not yet coded for RUN='DE' OR 'DI'"
        endif
!
! KUTLSX WILL ALWAYS BE PARTLY LINKED TO KUTLS SINCE KUTLS=-1 MUST FORCE
! KUTLSX=-1 (IF/WHEN IMPLEMENTED). BUT, IN PRINCIPLE, KUTLSX.LE.0 IS
! "INDEPENDENT" OF KUTLS, ALTHOUGH NOT NECESSEARILY ADVISABLE.
!
        IF(IDW.NE.0.AND.KUTLS.LT.0)THEN
          WRITE(MW6,*)                                                  &
     &     '*** ELECTRON IMPACT EXCITATION NOT YET CODED FOR KUTLS.LT.0'&
     &     ,', RE-SETTING KUTLS=0'
          WRITE(MW0,*)                                                  &
     &     '*** ELECTRON IMPACT EXCITATION NOT YET CODED FOR KUTLS.LT.0'&
     &     ,', RE-SETTING KUTLS=0'
          KUTLS=0
        ENDIF
        KUTLSX=KUTLS                         !FOR ANY USE IN "DW" BRANCH
!
! HISTORIC DIMENSION CHECK MODE IS OBSOLETE - (NOW) ONLY 10% FASTER BUT
! SIGNIFICANTLY OVERESTIMATED SOME DIMENSIONS. AN ACCURATE, BUT PARTIAL,
! DIMENSION CHECK HAS BEEN INTRODUCED INSTEAD.
!
! N.B. E1 OR E2 IS NO LONGER RELEVANT SINCE, LIKE MANY OTHER DIMENSIONS,
! ASSOCIATED ARRAYS ARE ALL ALLOCATABLE. DIMENSION CHECK JUST PICKS-UP
! THE CURRENT REMAINING (ALGEBRAIC) DIMENSIONS THAT ARE NOT FULLY
! ALLOCATABLE.
!
        IF(RAD.EQ.'DIM'.OR.RAD.EQ.'DIM1')MPRINT=-4  !E1 DIMENSION CHECK
        IF(RAD.EQ.'DIM0'.OR.RAD.EQ.'DIM2')MPRINT=-3 !E2 DIMENSION CHECK
        IF(MPRINT.EQ.-3.OR.MPRINT.EQ.-4)THEN
          RAD3=RAD(1:3)
          RAD=RAD3
        ENDIF
!
        IFLAG=0
        IF(RAD.EQ.'DIM')THEN
          RAD='  '
          IF(IDW.NE.0)THEN
            IDW=-ABS(IDW)
          ELSE
            IFLAG=1
          ENDIF
        ENDIF
        IF(IDW.LT.0)THEN
          IDW=-IDW
          IFLAG=-1
        ENDIF
        IF(IFLAG.EQ.1)THEN
          WRITE(MW0,*)'NOTE: THIS IS ONLY A *PARTIAL* DIMENSION TEST'
          WRITE(MW6,10210)
        ENDIF
        IF(IFLAG.EQ.-1)THEN
          WRITE(MW0,*)                                                  &
     &              'CURRENTLY, THERE IS NO DIMENSION CHECK MODE HERE..'
          WRITE(MW6,10220)
        ENDIF
!
! SET BORN SWITCHES (INTERACTS WITH RAD)
!
        IF(RAD.EQ.'NO')THEN
          IF(BORN.EQ.'  ')BORN='NO'
          IF(BORN.NE.'NO')THEN
            WRITE(MW6,*)'***SWITCHING-OFF BORN SINCE RAD.EQ."NO"'
            WRITE(MW0,*)'***SWITCHING-OFF BORN SINCE RAD.EQ."NO"'
            BORN='NO'
          ENDIF
        ENDIF
        IF(RAD.EQ.'ALL')THEN
          IF(BORN.NE.'YES'.AND.BORN.NE.'NO')BORN='INF'
          IF(BORN.EQ.'NO')MENGB=-1
          KPOLM=MIN(KPOLM,IFIVE)
          RAD='BP'
        ENDIF
        IF(IDW.EQ.0)THEN
          IF(BORN.EQ.'  ')BORN='NO'
          IF(RUN.NE.'  '.AND.BORN.NE.'NO')THEN
            WRITE(MW6,*)'***SWITCHING-OFF BORN SINCE RUN.NE." "'
            WRITE(MW0,*)'***SWITCHING-OFF BORN SINCE RUN.NE." "'
            BORN='NO'
          ENDIF
        ELSE
          IF(BTHRSH)THEN
            IF(LRGLAM.GT.0)THEN
              WRITE(MW6,*)'***SWITCHING-OFF TOP-UP SINCE NONE FOR',     &
     &             ' THRESHOLD PARTIAL COLLISION STRENGTHS (LVMAX.GE.0)'
              WRITE(MW0,*)'***SWITCHING-OFF TOP-UP SINCE NONE FOR',     &
     &             ' THRESHOLD PARTIAL COLLISION STRENGTHS (LVMAX.GE.0)'
            ENDIF
            LRGLAM=-2
          ENDIF
          IF(BORN.EQ.'YES')THEN
            WRITE(MW6,*)'*** CANNOT GENERATE FINITE ENERGY BORN WITH',  &
     &                  ' RUN="',RUN,'"'
            WRITE(MW6,*)'*** SWITCHING OFF FINITE ENERGY BORN...'
            WRITE(MW0,*)'*** SWITCHING OFF FINITE ENERGY BORN...'
            BORN='INF'
          ELSEIF(BORN.EQ.'NO')THEN
            MENGB=-1                             !GET DIPOLE & FLAG BORN
            IF(RAD.EQ.'NO')THEN
              ITEST=ABS(INAST)+ABS(INASTJ)
              IF(LRGLAM.GT.0.OR.LRGLAM.EQ.-999.AND.ITEST.EQ.0)THEN
                WRITE(MW6,*)'*** DIPOLE LIMIT REQUIRED FOR TOP-UP',     &
     &                  ', SWITCHING-ON RADIATION, SWITCH-OFF TOP-UP IF'&
     &                  ,' REALLY WANT RAD="NO"'
                WRITE(MW0,*)'*** SWITCHING-ON DIPOLE LIMIT FOR TOP-UP'
                KPOLE=1
              ELSE
                MENGB=-2
                WRITE(MW0,*)'*** NO ADF04 AS RAD="NO" !!!'
              ENDIF
            ELSE
              IF(BTHRSH)THEN
                IF(MPRINT.GE.0)THEN
                  KPOLE=MAX(KPOLE,ITWO)
                ELSE
                  KPOLE=MAX(KPOLE,IONE)
                ENDIF
              ENDIF
              WRITE(MW6,*)'*** INFINITE ENERGY BORN REQUIRED FOR A',    &
     &                    ' COMPLETE ADF04, PRESSING ON REGARDLESS...'
              WRITE(MW0,*)'*** ADF04 INCOMPLETE AS BORN="NO" !!!'
            ENDIF
          ELSE
            BORN='INF'
          ENDIF
        ENDIF
        IF(BORN.EQ.'YES')MENGB=0                   !FINITE ENERGY BORN
        IF(BORN.EQ.'INF')MENGB=1                   !INFINITE ENERGY BORN
        IF(MENGB.LT.0.AND.BORN.NE.'NO')THEN
          WRITE(MW6,*)'*** UNRECOGNIZED BORN OPTION: "',BORN,'"'
          WRITE(MW0,*)'*** UNRECOGNIZED BORN OPTION!'
          GO TO 1200
        ENDIF
        if(rad.eq.'NO'.and.born.eq.'NO'.and.mprint.gt.0)kpole=-1
!
! SET RELAXED ORBITAL SWITCHES:
! NEW ORBITAL BASIS FOR EACH CFG 'RLX', OR GROUP OF CFGS 'SRLX'.
!
        IF(BASIS.EQ.'RLX'.OR.BASIS.EQ.'RLX1'.OR.BASIS.EQ.'RLX2')THEN
          IEQ0=-1
          IRLX=1                                       !DEFAULT
          IF(BASIS.EQ.'RLX2')THEN                      !EXCEPT
            IRLX=2
            IF(IDW.NE.0)THEN
              WRITE(MW6,*)"*** NOTE: BASIS='RLX2' TARGET OVERLAP MATRIX"&
     &                    ,                                             &
     &          "IS APPLIED TO TARGET H ONLY, NOT THE SCATTERING MATRIX"
              WRITE(MW0,*)"*** NOTE: BASIS='RLX2' TARGET OVERLAP MATRIX"&
     &                    ,                                             &
     &          "IS APPLIED TO TARGET H ONLY, NOT THE SCATTERING MATRIX"
            ENDIF
          ENDIF
        ELSEIF(BASIS.EQ.'SRLX')THEN
          IF(CODE.EQ.'S.S.')THEN
            WRITE(MW6,*)                                                &
     &          "*** CANNOT USE BASIS='SRLX' WITH S.S. INPUT - USE A.S."
            WRITE(MW0,*)                                                &
     &          "*** CANNOT USE BASIS='SRLX' WITH S.S. INPUT - USE A.S."
            GO TO 1200
          ENDIF
          IEQ0=1
          IF(KCOR1.LT.0.OR.KORB1.LT.0)IRLX=-1          !NON-UNIQUE CORE
        ELSEIF(BASIS.NE.'    ')THEN
          WRITE(MW6,*)'*** UNRECOGNIZED BASIS OPTION: "',BASIS,'"'
          WRITE(MW0,*)'*** UNRECOGNIZED BASIS OPTION!'
          GO TO 1200
        ENDIF
        IF(IEQ0.NE.0)MDEL=0      !FORCE OFF SINCE USES NEL, NEVER USED
!
! SET COUPLING SWITCHES
!
        IF(CUP.EQ.'CA'.OR.CUP.EQ.'CAR'.OR.CUP.EQ.'CAM')THEN
          NSL0=-1                            !FLAG CONFIGURATION-AVERAGE
          IF(KUTOO.NE.0)THEN
            WRITE(MW0,*)' *** SWITCHING-OFF KUTOO AS CUP="CA"...'
            WRITE(MW6,*)' *** SWITCHING-OFF KUTOO AS CUP=',CUP
            KUTOO=0
          ENDIF
          IF(KUTSS.NE.-1)THEN
            WRITE(MW0,*)' *** SWITCHING-OFF KUTSS AS CUP="CA"...'
            WRITE(MW6,*)' *** SWITCHING-OFF KUTSS AS CUP=','"',CUP,'"'
            KUTSS=-1
          ENDIF
          IF(KUTSO.NE.-1)THEN
            WRITE(MW0,*)' *** SWITCHING-OFF KUTSO AS CUP="CA"...'
            WRITE(MW6,*)' *** SWITCHING-OFF KUTSO AS CUP=','"',CUP,'"'
            KUTSO=-1
          ENDIF
          IF(RAD.NE.'YES'.AND.RAD.NE.'NO'.AND.RAD.NE.'  '.AND.          &
     &       RAD.NE.'E1'.AND.RAD.NE.'E2'.AND.RAD.NE.'E3'.AND.           &
     &       RAD.NE.'E4'.AND.RAD.NE.'DIM1'.AND.RAD.NE.'DIM2'.AND.       &
     &       RAD.NE.'PI'.AND.RAD.NE.'RR')THEN
            WRITE(MW0,*)'*** ILLEGAL RAD OPTION FOR CUP="CA"...'
            WRITE(MW6,*)'*** ILLEGAL RAD OPTION: "',RAD,'" FOR CUP=',CUP
            GO TO 1200
          ENDIF
          IF(MSTRT0.NE.0)THEN
            WRITE(MW0,*)' *** SWITCHING-OFF RESTART AS CUP="CA"...'
            WRITE(MW6,*)' *** SWITCHING-OFF RESTART AS CUP=','"',CUP,'"'
            MSTRT0=0
          ENDIF
          IF(KUTLS.LE.0)THEN
            WRITE(MW0,*)' *** SWITCHING-OFF KUTLS AS CUP="CA"...'
            WRITE(MW6,*)' *** SWITCHING-OFF KUTLS AS CUP=','"',CUP,'"'
            KUTLS=1
          ENDIF
          IF(KCUT.NE.0.OR.KCUTCC.NE.0.OR.KCUTP.NE.-9999)THEN
            WRITE(MW0,*)' *** SWITCHING-OFF ALGEBRAIC CORRELATION AS',  &
     &                  ' CUP="CA"...'
            WRITE(MW6,*)' *** SWITCHING-OFF ALGEBRAIC CORRELATION AS',  &
     &                  ' CUP="',CUP,'"'
            KCUT=0
            KCUTP=0
            KCUTCC=0
          ENDIF
          if(ione1.eq.0)then
            WRITE(MW0,*)' *** SWITCHING-OFF ELASTIC AS CUP="CA"...'
            WRITE(MW6,*)' *** SWITCHING-OFF ELASTIC AS CUP=','"',CUP,'"'
            ione1=1
          endif
          IF(CUP.EQ.'CAR')THEN
            CUP='LSR'
          ELSEIF(CUP.EQ.'CAM')THEN
            CUP='LSM'
          ELSE
            CUP='LS'
          ENDIF
        ENDIF
!
        IF(CUP.EQ.'  '.AND.MODD.EQ.-999)CUP='LS'
        IF(CUP.EQ.'LS'.AND.KUTOO.NE.0)THEN
          WRITE(MW0,*)" *** SWITCHING-OFF KUTOO AS CUP='LS' ..."
          WRITE(MW6,*)" *** SWITCHING-OFF KUTOO AS CUP='LS' ..."
          KUTOO=0
        ENDIF
!
        BMVD=CUP.EQ.'LSM'.OR.CUP.EQ.'MVD'              !FLAG LS MVD PERT
        IF(BMVD)THEN
          CUP='LS'
        ELSE
          BMVD=CUP.EQ.'ICM'
          IF(BMVD)CUP='IC'
        ENDIF
!
        IF(MVD.EQ.'YES'.OR.MVD.EQ.'   ')THEN
          BMVD0=CUP(3:3).NE.'R'             !ONLY .TRUE. IF ON AS A PERT
        ELSEIF(MVD.EQ.'NO')THEN
          BMVD0=.FALSE.
          IF(BMVD)THEN
            WRITE(MW0,*)'*** MVD="NO" OVERRIDES CUP=',CUP
            WRITE(MW6,*)'*** MVD="NO" OVERRIDES CUP=',CUP
          ENDIF
        ELSE
          WRITE(MW0,*)'*** UNRECOGNIZED OPTION FOR MVD=',MVD,' IGNORED'
          WRITE(MW6,*)'*** UNRECOGNIZED OPTION FOR MVD=',MVD,' IGNORED'
        ENDIF
!
        IF(CUP.EQ.'JK')THEN
          IF(IDW.EQ.0)WRITE(MW6,*)'*** JK-COUPLING NOT USED FOR A ',    &
     &                            'STRUCTURE RUN, SWITCHING TO IC'
          CUP='IC'         !IF IDW.NE.0 WE ONLY HAVE JK, NO NEED TO FLAG
        ENDIF
        IF(CUP.EQ.'JKR')THEN
          IF(IDW.EQ.0)WRITE(MW6,*)'*** JK-COUPLING NOT USED FOR A ',    &
     &                            'STRUCTURE RUN, SWITCHING TO ICR'
          CUP='ICR'        !IF IDW.NE.0 WE ONLY HAVE JK, NO NEED TO FLAG
        ENDIF
!
        IF(CUP.EQ.'LS'.OR.CUP.EQ.'LSR')MODD=-2
        IF(CUP.EQ.'IC'.OR.CUP.EQ.'ICR')MODD=-1
!
        IF(MODD.EQ.-999)THEN
          WRITE(MW6,*)'*** UNRECOGNIZED CUP OPTION: "',CUP,'"'
          WRITE(MW0,*)'*** UNRECOGNIZED CUP OPTION'
          GO TO 1200
        ENDIF
!
! SET RADIATION SWICTHES
!
        IF(RAD.EQ.'  '.AND.(RUN.EQ.'PI'.OR.RUN.EQ.'RR'))RAD=RUN
!
        IF(RAD.EQ.'PI'.OR.RAD.EQ.'RR')THEN   !SWITCH-OFF RADIATIVE RATES
          BRAD=.FALSE.
          RAD='  '
        ELSE
          BRAD=.TRUE.                         !MAY STILL BE NO RAD RATES
        ENDIF
!
        IF(RAD.EQ.'LANDE')THEN
          ione1=0                                          !need elastic
          RAD='M1'               !set ione1 manually for alternative RAD
        ENDIF
!
        IF(MBP2MX.GT.1)THEN
          WRITE(MW6,*)'*** ERROR: 2-BODY BP CORRECTION TO M1 ONLY',     &
     &                ' NOT: M',MBP2MX
          WRITE(MW0,*)' *** ERROR: 2-BODY BP CORRECTION TO M1 ONLY'
          GO TO 1200
        ENDIF
        IF(MEKVMX.GT.1)THEN
          WRITE(MW6,*)' *** ERROR: BP CORRECTION TO E1 VEL ONLY, NOT: E'&
     &                ,MEKVMX
          WRITE(MW0,*)' *** ERROR: BP CORRECTION TO E1 VEL ONLY'
          GO TO 1200
        ENDIF
!        IF(RAD.NE.'  '.AND.MBP1MX.LT.0)MBP1MX=0
!
        IF(RAD.EQ.'BP1')THEN
          MBP1MX=0
          MBP2MX=-1
          MEKVMX=1
          RAD='M2'
        ENDIF
        IF(RAD.EQ.'BP'.OR.RAD.EQ.'BP2')THEN
          MBP1MX=0
!          MBP1MX=2
          MBP2MX=1
          MEKVMX=1
          RAD='M2'
        ENDIF
        IF(RAD.EQ.'M1BP')THEN
          MBP1MX=0
          MBP2MX=1
          MEKVMX=1
          RAD='M1'
        ENDIF
        IF(RAD.EQ.'M2BP')THEN
          MBP1MX=2
          MBP2MX=1
          MEKVMX=1
          RAD='M2'
        ENDIF
        IF(RAD.EQ.'M3BP')THEN
          MBP1MX=3
          MBP2MX=1
          MEKVMX=1
          RAD='M3'
        ENDIF
        IF(RAD.EQ.'M1')THEN
          IF(KPOLM.GE.100)KPOLM=1
          RAD='E2'
        ENDIF
        IF(RAD.EQ.'M2')THEN
          IF(KPOLM.GE.100)KPOLM=2
          RAD='E3'
        ENDIF
        IF(RAD.EQ.'M3')THEN
          IF(KPOLM.GE.100)KPOLM=3
          RAD='E4'
        ENDIF
!
        IF(RAD.NE.'YES'.AND.RAD.NE.'NO'.AND.RAD.NE.'  '.AND.            &
     &     RAD.NE.'E1'.AND.RAD.NE.'E2'.AND.RAD.NE.'E3'.AND.             &
     &     RAD.NE.'E4'.AND.RAD.NE.'DIM1'.AND.RAD.NE.'DIM2')THEN
          WRITE(MW6,*)'*** UNRECOGNIZED RAD OPTION: "',RAD,'"'
          WRITE(MW0,*)'*** UNRECOGNIZED RAD OPTION'
          GO TO 1200
        ENDIF
!
        IF(KPOLE.GT.KPOL1)THEN           !USER ASKING FOR V LARGE E-POLE
          WRITE(MW0,*)                                                  &
     &             '*** DO YOU REALLY NEED ALL THESE MULTIPOLES? KPOLE='&
     &             ,KPOLE
          WRITE(MW6,*)                                                  &
     &             '*** DO YOU REALLY NEED ALL THESE MULTIPOLES? KPOLE='&
     &             ,KPOLE
          IF(WP.LE.8)THEN
            WRITE(MW0,*)                                                &
     &      '*** REDUCING KPOLE TO A SAFE VALUE (AVOID OVERFLOW) KPOLE='&
     &      ,KPOL1
            WRITE(MW6,*)                                                &
     &      '*** REDUCING KPOLE TO A SAFE VALUE (AVOID OVERFLOW) KPOLE='&
     &      ,KPOL1
            KPOLE=KPOL1
          ENDIF
        ENDIF
!
        IF(MENGB.GE.-1)THEN
          IF(KPOLE.LT.-100)THEN
            KPOLE=6
            IF(MENGB.GE.0)KPOLE=KPOL1       !NOW RESTRICT BORN IN ALGEB2
          ENDIF
          KPOL0=MAX(IZERO,KPOL0)
          IF(IDW*KPOLM.GE.100)KPOLM=1
          MPRINT=MAX(IZERO,MPRINT)
        ENDIF
!
        IF(MPRINT.EQ.-2.AND.(BFOT.OR.RUN.EQ.'DR'.OR.RUN.EQ.'YLD'))THEN
          IF(RAD.EQ.'  ')THEN
            KPOLE=MAX(IONE,KPOLE)                          !SWITCH-ON E1
            IF(KPOL0.LT.-100)KPOL0=-1                      !SWITCH-ON E1
          ELSEIF(RAD.EQ.'NO')THEN
            WRITE(MW6,*)" ***ATTENTION: YOU HAVE SET RUN.EQ.'",RUN,     &
     &                  "' BUT ALSO RAD.EQ.'",RAD,                      &
     &                  "', WHICH DOESN'T MAKE MUCH SENSE..."
            WRITE(MW0,*)'***ATTENTION: YOU HAVE SET A RUN/RAD ',        &
     &                  'COMBINATION WHICH DOES NOT MAKE MUCH SENSE...'
            GO TO 1200
          ENDIF
        ENDIF
!
        IF(RAD.EQ.'E1'.OR.RAD.EQ.'YES')KPOLE=MAX(IONE,KPOLE)
        IF(RAD.EQ.'E2')KPOLE=MAX(ITWO,KPOLE)
        IF(RAD.EQ.'E3')KPOLE=MAX(ITHREE,KPOLE)
        IF(RAD.EQ.'E4')KPOLE=MAX(IFOUR,KPOLE)
        IF(KPOLM.GE.100)KPOLM=KPOLE-1
        MPOLE=2*KPOLE        !KPOLE=EK
        MPOL00=2*KPOL0
        MPOLM=2*KPOLM        !KPOLM=MK
!        IF(MBP1MX.LT.0.AND.MBP2MX.GT.0)MBP1MX=0
!        IF(MPOLM.LE.2.AND.MBP1MX.EQ.0.AND.MBP2MX.EQ.0)MBP1MX=-1
!        write(mw0,*)mbp1m,mbp2mx,kpolm
        MBP1MX=2*MBP1MX
        MBP2MX=2*MBP2MX
        MEKVMX=2*MEKVMX
        IF(KPOLE.EQ.1)MPRINT=MAX(-IONE,MPRINT)
        IF(KPOLE.GT.1)MPRINT=MAX(IZERO,MPRINT)
        QCUT=INT(ICHAR(QLIT(QCUT)),QP)            !OLD M1+BP CUT
!
! SET AUGER SWITCH
!
        IF(AUGER.NE.'YES'.AND.AUGER.NE.'NO'.AND.AUGER.NE.'  ')THEN
          WRITE(MW6,*)'*** UNRECOGNIZED AUGER OPTION: "',AUGER,'"'
          WRITE(MW0,*)'*** UNRECOGNIZED AUGER OPTION'
          GO TO 1200
        ENDIF
!
        IF(RUN.EQ.'PI'.OR.RUN.EQ.'RR')THEN
          IF(AUGER.EQ.'YES')THEN
            WRITE(MW6,*)                                                &
     &                '*** CAUTION: YOU HAVE REQUESTED BOTH PI & AUGERS'
            WRITE(MW6,*)                                                &
     &            '*** TAKE CARE TO USE A SUITABLE ENERGY MESH FOR BOTH'
            WRITE(MW0,*)                                                &
     &                '*** CAUTION: YOU HAVE REQUESTED BOTH PI & AUGERS'
            WRITE(MW0,*)                                                &
     &            '*** TAKE CARE TO USE A SUITABLE ENERGY MESH FOR BOTH'
!            BAUGER=.TRUE.                                  !OLD DEFAULT
          ELSE
            BAUGER=.FALSE.                                  !NEW DEFAULT
          ENDIF
        ELSE
          BAUGER=AUGER.NE.'NO'
        ENDIF
!
! SET "DW" SWITCHES
!
        IF(IDW.NE.0)THEN
          BPASS=.FALSE.                           !NEED DC ARRAY WRITTEN
          RUN='  '
          IF(FACTL.GT.DONE.AND.FACTL.LT.D1PT26)LFACT=NINT(100*FACTL,SP)
          IF(FACTJ.GT.DONE.AND.FACTJ.LT.D1PT26)JFACT=NINT(200*FACTJ,SP)
          IF(MXCCF.GT.0)THEN
            WRITE(MW6,*)' ***ATTENTION: YOU HAVE SPECIFIED CORRELATION '&
     &                  ,                                               &
     &       'CONFIGS FOR DIRECT EXCITATION: ATTEMPTING TO IGNORE THEM!'
            WRITE(MW0,*)' ***ATTENTION: YOU HAVE SPECIFIED CORRELATION '&
     &                  ,                                               &
     &       'CONFIGS FOR DIRECT EXCITATION{ ATTEMPTING TO IGNORE THEM!'
          ENDIF
          IF(NMETA.LE.0)THEN
            IF(BTHRSH)THEN
              NMETA=JAXTM           !all for Augers
            ELSE
              NMETA=1               !defaults to ground term
            ENDIF
          ENDIF
          IF(NMETAJ.eq.0)THEN
            IF(BTHRSH)THEN
              NMETAJ=JAXLV-1        !all for Augers
            ELSE
              NMETAJ=JAXLV+1        !defaults to levels of ground term
            ENDIF
          ENDIF
          if(nmetaj.gt.0)then       !omit 2fs between excited terms
            nmetag0=-1              !that only s.o. mix with metastables
          else                      !include all allowed by a.m. selectn
            nmetag0=0
            nmetaj=-nmetaj
          endif
          ISCALR=-ABS(ISCALR)       !SWITCH-OFF OPTMZN OF SLATER SCALING
        ELSE
          nmetag0=0                 !unused
          IF(BDR.OR.MXCCF.GT.0)THEN
            NMETA=0
            NMETAJ=0
          ELSE
            IF(NMETA.LT.0)NMETA=0
            IF(NMETAJ.LT.0)NMETAJ=JAXLV+1
          ENDIF
        ENDIF
!
!        NMETA=MAX(NMETA,0)
!        NMETA=MIN(NMETA,MAXTM)
        IF(ABS(MODD).GT.1)NMETAJ=0
!
        IF(TARGET.EQ.'OLD')THEN
          NMETA=-NMETA
          NMETAJ=-NMETAJ
        ELSEIF(TARGET.NE.'NEW'.AND.TARGET.NE.'   ')THEN
          WRITE(MW6,*)'*** UNRECOGNIZED TARGET OPTION: "',TARGET,'"'
          WRITE(MW0,*)'*** UNRECOGNIZED TARGET OPTION'
          GO TO 1200
        ENDIF
!
! INITIALIZE FOR USE OF ADF00 GROUND CONFIG BY SR.CONFG0, SR.CONFG
!
        IF(CODE.EQ.'A.S.'.AND.MXCONF.LE.0.and.icfg.ge.0)THEN
!
          IF(NELEC.LE.0)THEN
            WRITE(MW6,*)                                                &
     &                '*** MUST SET NUMBER OF TARGET ELECTRONS (NELEC) '&
     &                ,'IF NO CONFIGS INPUT (MXCONF.LE.0) ***'
            WRITE(MW0,*)                                                &
     &                '*** MUST SET NUMBER OF TARGET ELECTRONS (NELEC) '&
     &                ,'IF NO CONFIGS INPUT (MXCONF.LE.0) ***'
            GO TO 1200
          ENDIF
!
          ICFG=0
          IF(MXCONF.LT.0.OR.EXCITE.GT.DZERO)THEN    !AUTO GENERATE A SET
            ICFG=1
            IF(NSL0.GE.0)THEN
              WRITE(MW0,*)                                              &
     & "IT IS *** STRONGLY RECOMMENDED *** THAT CUP='CAR' IS USED HERE!"
            ENDIF
          ENDIF
!
          BADF00=.TRUE.
          MXCONFH=MXCONF                              !HOLD
          MXCONF=1                                    !OBTAIN FROM ADF00
!
          IF(NZION.EQ.0)THEN     !CAN ONLY ASSUME STANDARD ORDER FILLING
            IF(NELEC.GT.18)THEN
              WRITE(MW6,*)                                              &
     &         '*** ASSUMING GROUND CONFIG IS STANDARD ORDERED FILLED. '&
     &         ,'MUST SET NZION (IN SMINIM) IF NOT!! ***'
              WRITE(MW0,*)                                              &
     &         '*** ASSUMING GROUND CONFIG IS STANDARD ORDERED FILLED. '&
     &         ,'MUST SET NZION (IN SMINIM) IF NOT!! ***'
            ENDIF
            JHZ=0
            JZ=JHZ+1
          ELSE
            NZ=ABS(NZION)
            IF(NZ.GT.JZX)THEN
              WRITE(MW6,*)'*** NZION .GT. TABULATED ADF00 DATA:',NZ,JZX
              WRITE(MW0,*)'*** NZION .GT. TABULATED ADF00 DATA:',NZ,JZX
              GO TO 1200
            ENDIF
            JHZ=QCFGX(0,0,NZ)       !NO OF STAGES OF ELEMENT NOT IN S.O.
            JZ=NZ-NELEC+1
          ENDIF
!
          IF(JZ.LE.JHZ)THEN
            KLEN=QCFGX(0,JZ,NZ)
            ALLOCATE(QCFG(0:KLEN))
            DO K=0,KLEN
              QCFG(K)=QCFGX(K,JZ,NZ)               !COPY-IN GROUND CONFG
            ENDDO
          ELSE
            JH0=QCFG0(0,0)                   !NO OF S.O. STAGES ARCHIVED
            JH=JH0-NELEC+1                     !H-LIKE IN THE LAST POSTN
            KLEN=QCFG0(0,JH)
            ALLOCATE(QCFG(0:KLEN))
            DO K=0,KLEN
              QCFG(K)=QCFG0(K,JH)                  !COPY-IN GROUND CONFG
            ENDDO
          ENDIF
!
          K1=0
          K2=0
          K=0
          DO N=1,10                               !FIND FIRST OPEN SHELL
            DO L=0,N-1
              K=K+1
              IF(K.GT.KLEN)GO TO 320
              KOCC=4*L+2
              IF(QCFG(K).NE.KOCC)THEN
                K2=K-1
                K1=1
                GO TO 320
              ENDIF
            ENDDO
          ENDDO
  320     CONTINUE
          DO K=KLEN,1,-1                     !FIND LAST OCCUPIED ORBITAL
            IF(QCFG(K).GT.0)THEN
              KLEN=K
              GO TO 340
            ENDIF
          ENDDO
  340     CONTINUE
!
          MXVORB=KLEN-K2
!
          OPEN(MSC00,FORM='FORMATTED',STATUS='SCRATCH')       !NOT UNIT5
!
          IF(ICFG.EQ.1)THEN
!
            IF(NXTRA.LE.0.OR.LXTRA.LT.0.AND.NXCITE.GT.0.OR.LXCITE.GT.0) &
     &         THEN
              MAXN=0
              MAXL=0
              DO K=1,MXVORB
                J=QCFG(K2+K)
                IF(J.GT.0)THEN
                  CALL SO2NL(K2+K,N,L)
                  MAXN=MAX(MAXN,N)
                  MAXL=MAX(MAXL,L)
                ENDIF
              ENDDO
              IF(LXTRA.LT.0.AND.LXCITE.GT.0)                            &
     &           LXTRA=min(MAXL+LXCITE,ithree)
              IF(NXTRA.LE.0.AND.(NXCITE.GT.0.OR.LXTRA.GE.0))NXTRA=MAXN+ &
     &           NXCITE
            ENDIF
!
            IF(NXCORE.LT.K2.AND.NXCORE.GE.0)THEN          !OPEN-UP
              K2=NXCORE
              MXVORB=KLEN-K2
            ENDIF
!
            ALLOCATE(MNAL(MXVORB),MXAL(MXVORB))
!
            DO K=1,MXVORB
              J=QCFG(K2+K)
              CALL SO2NL(K2+K,N,L)
!              write(mw0,*)j,k2+k,n,l
              KOCC=4*L+2
              IF(J.EQ.0.AND.L.GT.LXTRA)THEN            !DON'T PROMOTE TO
                MNAL(K)=0
                MXAL(K)=0
              ELSE
                MNAL(K)=MAX(J-NXPROM,IZERO)
                MXAL(K)=MIN(J+NXPROM,KOCC)
              ENDIF
            ENDDO
            WRITE(MSC00,*)(MNAL(K),K=1,MXVORB)
            WRITE(MSC00,*)(MXAL(K),K=1,MXVORB)
            WRITE(MSC00,*)(QCFG(K),K=K2+1,KLEN),NXPROM
            DEALLOCATE(MNAL,MXAL)
          ELSE
            WRITE(MSC00,*)(QCFG(K),K=K2+1,KLEN)
          ENDIF
          REWIND(MSC00)
!
          MXVORB=-MXVORB                        !.LT. TO FLAG S.O. QN,QL
!
          DEALLOCATE(QCFG)
!
        ELSE
!
! SET K2.LT.0 TO READ ALL NL DEFN'S BUT ONLY VALENCE OCCUPATION NOS.
!
          IF(KORB1.GT.0)K1=KORB1
          IF(KORB2.NE.0)K2=KORB2
          IF(KCOR1.GT.0)K1=KCOR1
          IF(KCOR2.NE.0)K2=KCOR2
          K1=ABS(K1)
!
        ENDIF
! misc
        iw=abs(6*(mod(iw,iseven)/6))
        iwp=abs(6*(mod(iwp,iseven)/6))
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! END OF MAIN BNAME READS
!
!-----------------------------------------------------------------------
!
      MA=K1                                   !TRANSFER CLOSED-SHELLS TO
      MB=K2                                   !NRBAL1 AND DROP BASIC USE
!
      KCUTP0=KCUTP
      IF(KCUTP.EQ.-9999)THEN
        KCUTP=KCUT
      ELSEIF(KCUT.NE.KCUTP)THEN
        WRITE(MW6,*)' ***ATTENTION: YOU HAVE SPECIFIED KCUTP .NE. KCUT:'&
     &              ,KCUTP,KCUT,' I HOPE YOU KNOW WHAT YOU ARE DOING!'
        WRITE(MW0,*)                                                    &
     &            ' ***ATTENTION: YOU HAVE SPECIFIED KCUTP .NE. KCUT...'
      ENDIF
!
      KCUTX=KCUT                                !<0 KEEP DW CORR.-CORR.
      KCUT=ABS(KCUT)
      KCUTP=ABS(KCUTP)                          !ONLY SIGN OF KCUT FLAGS
      KCUTCC=ABS(KCUTCC)                        !ONLY SIGN OF KCUT FLAGS
!
      IF((KCUT+KCUTP+KCUTCC)*KUTLS.LT.0)THEN
        WRITE(MW6,*)' ***ATTENTION: YOU HAVE FLAGGED CORRELATION',      &
     &              ' CONFIGS AND SINGLE CONFIG MIXING...'
        WRITE(MW0,*)                                                    &
     &             ' ***ATTENTION: YOU HAVE SPECIFIED KCUT AND KUTLS...'
      ENDIF
!
      IF(KPOLE.LT.-100)MPOLE=4                  !2K-POLE
      IF(KPOL0.LT.-100)MPOL00=2
      IF(MDEL.GT.0)MDEL=1                       !JAC-DIAG
!
      IF(XDR.EQ.'X'.OR.XDR.EQ.'P')THEN          !XDR IS HISTORIC
        BDR=.TRUE.
        IDR=1
      ENDIF
      IF(XDR.EQ.'F'.OR.XDR.EQ.'P')BFOT=.TRUE.
!
!      MTEST=MPRINT
!      IF(BFOT.AND.MTEST.EQ.0)MPRINT=-1
!      IF(BFOT.AND.MTEST.EQ.-5)MPRINT=-6
      NPRINT=MPRINT
      MPRINT=MOD(MPRINT,IFIVE)
      MPRNT0=MPRINT
      MOD0=MODD
      BREL=CUP.EQ.'ICR'.OR.CUP.EQ.'LSR'                 !CAR->LSR BY NOW
      BREL=BREL.OR.NPRINT.LT.-4                         !HISTORIC...
      IF(.NOT.BREL.AND.ABS(NZION).GT.30)THEN
        WRITE(MW6,*)                                                    &
     &      'SR.ALGEB0: RECOMMEND USING CUP=CAR/LSR/ICR FOR NZION.GT.30'
        WRITE(MW0,*)                                                    &
     &      'SR.ALGEB0: RECOMMEND USING CUP=CAR/LSR/ICR FOR NZION.GT.30'
      ENDIF
!
!-----------------------------------------------------------------------
!                                              !SHOULD BE SET IN SRADCON
! SET PHASE CONVENTION
!  DEFAULT: CONDON & SHORTLEY. FANO NOT CODED FOR 2FS
!
      BFANO=MLIT0(1).EQ.'FANO'
      IF(BFANO)THEN
        IF(KUTSS.NE.-1.AND.ABS(MODD).LE.1)THEN !2-FS NOT CODED FOR FANO
          WRITE(MW6,*)'SR.ALGEB0: CANNOT USE FANO PHASE WITH 2-BODY F-S'
          WRITE(MW0,*)'SR.ALGEB0: CANNOT USE FANO PHASE WITH 2-BODY F-S'
          GO TO 1200
        ENDIF
        IF(IDW.NE.0)THEN                        !DW NOT CODED FOR FANO
          WRITE(MW6,*)                                                  &
     &      'SR.ALGEB0: CANNOT USE FANO PHASE WITH DW DIRECT EXCITATION'
          WRITE(MW0,*)                                                  &
     &      'SR.ALGEB0: CANNOT USE FANO PHASE WITH DW DIRECT EXCITATION'
          GO TO 1200
        ENDIF
        WRITE(MW6,10030)
      ENDIF
      IF(BNAME)THEN                            !NOW OVERWRITE WITH TITLE
        MLIT0(1)=MLIT(1)
        MLIT0(2)=MLIT(2)
      ENDIF
!
!-----------------------------------------------------------------------
!
! RESET KUTOO=-1 TO 0, I.E. -1 SWITCHES-OFF 2NFS
      IF(KUTOO.LE.-1)KUTOO=0
! ALIGN WITH FAC
      IF(IFAC.GT.0)THEN
        IF(KUTOO.EQ.0.AND.NSL0.GT.0)THEN
          WRITE(MW6,*)                                                  &
     &         '*** ATTENTION: NON-STANDARD FAC OPTION ALLOWED, KUTOO=0'
          WRITE(MW0,*)                                                  &
     &         '*** ATTENTION: NON-STANDARD FAC OPTION ALLOWED, KUTOO=0'
        ENDIF
      ELSEIF(IFAC.EQ.0)THEN                                   !SWITCH-ON
        IF(KUTOO.EQ.0.AND.NSL0.GE.0)KUTOO=1
      ENDIF
!
! RESET KUTSS=0 TO -1 TO SUPPRESS SS LEGACY OF RE-MAPPING 0 TO 1 AS THE
! GROUND CONFG CAN CHANGE WHEN CARRYING-OUT BOUND-CONTINUUM CALCULATION
! EVEN FOR BOUND-BOUND IT CAUSES SR.SPOR0 TO BE BY-PASSED  & WHICH PRE-
! MAPS ONE-BODY INTERACTIONS FOR SPEED, ALBEIT AT INCREASED MEMORY.
! IF MEMORY IS AN ISSUE THEN THE PROBLEM IS LIKELY SO LARGE THAT THE
! INCREASED CPU TIME IS AN ISSUE. THE USER CAN ALWAYS SET KUTSS=1 FOR
! BACKWEARDS COMPATIBILITY, AND WHICH BYPASSES SR.SPOR0 AGAIN.
! PRINT A WARNING TO THIS EFFECT.
!
      IF(KUTSS.EQ.0)THEN
        WRITE(MW0,*)                                                    &
     & ' *** ATTENTION: KUTSS=0 SS LEGACY INTERNAL RE-MAP TO =1 NOW OFF'
        WRITE(MW0,*)                                                    &
     &   '                SET KUTSS=1 TO RECOVER 2-FS FOR GROUND CONFIG'
        WRITE(MW0,*)                                                    &
     &   ' *** ATTENTION: RE-SETTING KUTSS=-1, NO 2-BODY FINE-STRUCTURE'
        WRITE(MW6,*)                                                    &
     & ' *** ATTENTION: KUTSS=0 SS LEGACY INTERNAL RE-MAP TO =1 NOW OFF'
        WRITE(MW6,*)                                                    &
     &   '                SET KUTSS=1 TO RECOVER 2-FS FOR GROUND CONFIG'
        WRITE(MW6,*)                                                    &
     &   ' *** ATTENTION: RE-SETTING KUTSS=-1, NO 2-BODY FINE-STRUCTURE'
        KUTSS=-1
      ENDIF
!
      IF(KUTSS.EQ.-9)THEN
        WRITE(MW0,*)' *** ATTENTION: ',                                 &
     &          'KUTSS=-9 NO LONGER FLAGS ALL CONFIGS, SET KUTSS=-MAXCF'
        WRITE(MW6,*)' *** ATTENTION: ',                                 &
     &          'KUTSS=-9 NO LONGER FLAGS ALL CONFIGS, SET KUTSS=-MAXCF'
      ENDIF
!
      IF(KUTSO.EQ.-1.AND.KUTSS.LT.-1)THEN        !WARN USER
        WRITE(MW0,*)                                                    &
     &' *** WARNING: TWO-BODY FINE-STRUCTURE IS NOW RESTRICTED TO BEING'
        WRITE(MW0,*)                                                    &
     & '        *WITHIN* A CONFIGURATION AS KUTSO=-1 OVERRIDES KUTSS<-1'
        WRITE(MW6,*)                                                    &
     &' *** WARNING: TWO-BODY FINE-STRUCTURE IS NOW RESTRICTED TO BEING'&
     &,' *WITHIN* A CONFIGURATION AS KUTSO=-1 OVERRIDES KUTSS<-1'
      ENDIF
!
!***+AND-OPTIONS INTERCHANGED 23/11/91 TO ALLOW KUTSO WITHIN A
      KUTSO=-KUTSO
!***  CONFIGURATION ONLY FOR .GT. 9 CONFIGS WITH I2 FORMAT.
!
!
!-----------------------------------------------------------------------
!
! END SET-UP BASED-ON USER INPUT
!
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!
! NOW SET-UP ORBITALS AND CONFIGURATIONS
!
!-----------------------------------------------------------------------
!
! SET-UP A BUFFER ARRAY NEL(IAXGR,IAXCF) FOR ALL POSSIBLE CONFIGS.
! ONCE WE HAVE THEM THEN NEL IS RE-ALLOCATED TO ACTUAL USAGE.
! THE BUFFER CAN BE QUITE LARGE SINCE NO ALGEBRA HAS YET BEEN ALLOCATED.
! BUT WE CANNOT "ALLOW" FOR BOTH MAXGR AND MAXCF BEING THEIR LARGEST
! POSSIBLE AT THE SAME TIME  - WHICH CAN NEVER OCCUR - BUT WE WANT
! TO ALLOW SUCH A MAXGR TO BE SET IN THE PARAM FILE.
! ALL OTHER ARRAYS ARE EITHER ALLOCATED TO ACTUAL USAGE OR ARE
! LINEAR IN MAXGR, I.E. HARD TO INFLATE.
! N.B. MAXCF IS FULLY RE-ALLOCATABLE NOW FOR AS INPUT. BUT SS EISSNER
! NOTATION USER TYPED CONFIGS STILL NEED IAXCF SET LARGE ENOUGH TO
! TAKE ALL THE USER CAN TYPE...
!
      IF(IEQ0.LT.0)THEN                  !RELAXED ORBITALS
        IAXGR=5000                         !=(UNIQUE MAXGR)*MAXCF
        IAXCF=1000                         !SO CAN LIMIT INITIAL IAXCF
      ELSEIF(NSL0.LT.0)THEN                !CA MAXCF CAN BE LARGE
        IAXGR=1000                         !BUT CAN LIMIT IAXGR
        IAXCF=46340
      ELSE                                 !LS/BP UNIQUE ORBITAL BASIS
        IAXGR=250                          !SO CAN LIMIT IAXGR
        IAXCF=5000                         !AND CAN LIMIT INITIAL IAXCF
      ENDIF
!      IF(MAXCF.GT.0)IAXCF=MIN(MAXCF,IAXCF) !FOR TEST PURPOSES ONLY!
!
      ALLOCATE(NEL(IAXGR,IAXCF),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.ALGEB0: ALLOCATION FAILS FOR NEL'
        NF=0
        GO TO 900
      ENDIF
!
      ALLOCATE(ICFGP(IAXCF),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.ALGEB0: ALLOCATION FAILS FOR ICFGP'
        NF=0
        GO TO 900
      ENDIF
!
      ALLOCATE(IEQ(0:IAXGR),IGRCF(IAXGR),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.ALGEB0: ALLOCATION FAILS FOR IEQ,IGRCF'
        NF=0
        GO TO 900
      ENDIF
!
      IEQ(0)=IEQ0
!
      ALLOCATE(QL(IAXGR),QN(IAXGR),DEY(IAXGR),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.ALGEB0: ALLOCATION FAILS FOR QL,QN,DEY'
        NF=0
        GO TO 900
      ENDIF
!
!-----------------------------------------------------------------------
!
      IF(CODE.EQ.'A.S.')THEN
!
! initialize so we can check later for any undefined nel - remove now
!        do j=1,iaxcf
!          do i=1,iaxgr
!            nel(i,j)=-1
!          enddo
!        enddo
!
        NF=1                                        !SO CAN FLAG ERROR
!
        CALL CONFG0(RUN,ICFG,MXVORB,MXCONF,MXCCF,KCUTCC,NXTRA,LXTRA,    &
     &              LCONT,LCON0,KCUT0,IFILL)
!
        IF(NF.LE.0)GO TO 800
        NF=0                                        !NOT USED
!
        IF(BADF00)CLOSE(MSC00)
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! DECODE NUMBER OF VALENCE ELECTRONS FROM FIRST CONFIGURATION.
!
      IF(CODE.EQ.'S.S.')THEN
        MPOL00=ABS(MPOL00)                           !REMOVE ANY FLAG
        MAXEL=IWRK2(1)
        DO I=2,KG
          IF(IWRK2(I).LE.50)GO TO 400
          MAXEL=IWRK2(I)-50+MAXEL
        ENDDO
      ELSE                                          !'A.S.'
        MAXEL=0
        I0=ABS(MB)+1                                !K2
        DO I=I0,MXORB
          MAXEL=MAXEL+NEL(I,1)
        ENDDO
      ENDIF
!
  400 CONTINUE
!
! LEGACY CODE MADE SPACE FOR CONTINUUM ELECTRON, CASE EIE.
! ALLOCATION (AND PASSING FILE) MEAN THIS IS NOLONGER NECESSARY.
!      IF(IDW.NE.0)MAXEL=MAXEL+1
!
! FLAG IF THERE WAS NOT ENOUGH BUFFER SPACE TO READ-IN CONFIGS.
!
  500 IF(CODE.EQ.'S.S.')THEN
        IF(MLIT(1).NE.'    ')WRITE(MW6,10010)MLIT0
        IF(KGG.GT.IXD08)THEN
          WRITE(MW6,10060)IXD08,KGG
          GO TO 1200                                !RETURN
        ENDIF
      ENDIF
!
! END READ (AND PROCESSING OF A.S.) CONFIG INPUT
!
!-----------------------------------------------------------------------
!
! MCFSS .GT. 0 NUMBERS ARE READ-IN (FREE-FORMATTED) FOR WHICH TWO-BODY
! FINE-STRUCTURE OF SR.RES ARE TO APPLY - THIS IS HISTORIC (UNUSED NOW).
! CASE S.S. THEY FOLLOW AFTER THE ORBITAL REDEFINITION LINE.
! CASE A.S. THEY FOLLOW AFTER THE CONFIGS (& BEFORE ANY NAST/S/P/J).
! THESE ARE IN ADDITION TO THOSE SPECIFIED BY *KUTSS*.
! NO INTERACTIONS BETWEEN TWO SETS UNLESS SPECIFIED IN BOTH.
!
      IF(MCFSS.GT.0)THEN
        ALLOCATE(KCFS0(MCFSS))               !LOCAL
        READ(MR5,*)(KCFS0(I),I=1,MCFSS)       !BOTH S.S. FREE-FORMAT NOW
      ENDIF
!
!-----------------------------------------------------------------------
!
! READ NASTS SUB-SHELL SPECS (SAME FOR IDW.EQ.0 AND. IDW.NE.0),
! OR, NASTS.LT.0, FLAG USE OF RANGE OF 2S+1,L GIVEN BY
! MINSTS,MAXSTS,MINLTS,MAXLTS READ IN NAMELIST,
! FOR SELECTION OF TERMS FROM AN OPEN SPECTATOR SUB-SHELL.
! APPLIES TO *ALL* CONFIGS WITH THE SUB-SHELL:
!
!  IO IS THE SUB-SHELL ORBITAL NUMBER
!  IQ   "     "    "   OCCUPATION "
!  IS, IL DEFINE THE 2S+1, L SYMMETRY REQUIRED
!  (IF IS=0 AND NASTS.GT.0 THEN RANGE IS APPLIED, ELSE RANGE IGNORED.)
!
! *** NOT IN RESTART, SO DO NOT CHANGE IF USING MSTART=2.
!
      IF(NASTS.NE.0)THEN
        NASTS0=ABS(NASTS)
        ALLOCATE(NESSH(NASTS0))
      ENDIF
      IF(NASTS.GT.0)THEN
        DO I=1,NASTS
          READ(MR5,*)IO,IQ,IS,IL            !,IP - PARITY UNNECESSARY
          NESSH(I)=100000*IO+1000*IQ+10*IS+IL
          IF(IS.EQ.0)IL=0                 !WILL USE RANGE
          IF(IS.LT.0)IS=-IS               !ASSUME ATTEMPT TO FLAG PARITY
          IF(IL.GT.9)THEN
            WRITE(MW6,*)'CURRENTLY, NASTS CANNOT SELECT TARGET L.GT.9..'
            WRITE(MW0,*)'CURRENTLY, NASTS CANNOT SELECT TARGET L.GT.9..'
            GO TO 1200                             !RETURN
          ENDIF
        ENDDO
      ELSEIF(NASTS.LT.0)THEN       !USER SHOULD SET MIN/LAX S,L ELSE ALL
        DO I=1,-NASTS
          READ(MR5,*)IO,IQ
          NESSH(I)=100000*IO+1000*IQ
        ENDDO
      ENDIF
!
!-----------------------------------------------------------------------
!
! READ NAST/P SELECTED (2S+1) L P
! OR, NAST/P.LT.0, FLAG USE OF RANGE OF 2S+1,L GIVEN BY
! MINST/P,MAXST/P,MINLT/P,MAXLT/P READ IN NAMELIST,
! FOR PARENT (NASTP) OR FULL CF (NAST).
!
! FOR PARENTS, NASTP SPECIFIES THE NO. OF SETS OF DATA TO FOLLOW,
! WHICH CONSISTS OF A CF NO. AND A LOCAL NASTP VALUE, FOLLOWED BY
! THE 2S+1,L,P PARENT TERMS.
! *** IF A CONFIG IS NOT LISTED THEN *ALL* OF ITS TERMS ARE INCLUDED.
!
! FOR FULL CF, 2S+1,L,P ARE GLOBAL I.E. THE SAME FOR ALL CFS, SO JUST
! THESE ARE REQUIRED.
!
! (N.B. SPIN RE-LABELLED AS MINSP, MAXSP AT END OF THIS SUBROUTINE, FOR
! /NRBLS/, TO AVOID CONFLICT WITH HISTORIC MAXST SLATER STATE VARIABLE.)
! IN ADDITION, WHEN LOOPING OVER RYDBERG ORBITAL WITH A.M. LNEW
! CAN RESTRICT ***TOTAL*** L-VALUES WITH LRANGE.
!
! *** ONLY NEED READ *DISTINCT* SYMMETRIES, I.E. MAXSL POSSIBLE
!
! *** NOT IN RESTART, SO DO NOT CHANGE IF USING MSTART=2.
!
! *** CASE IDW.GT.0 (EIE,EII) THEN (V28.X):
!
! INAST ONLY, ONLY CONTROLS LSP SCATTERING SYMMETRIES.
!
! NAST/P STILL REFER TO N-ELECTRON TARGET ONLY NOW - NO RE-MAP!
!
! INAST<=0 "MUST" STILL ALLOW HISTORIC USE OF MINST,MAXST,MINLT,MAXLT
! TO SET RANGE OF SCATTERING SYMMETRIES, THEN RARELY USED MIN/MAXS/L/TP
! REFER TO TARGET, THUS, NO TARGET PARENT SELECTION BY RANGE AVAILABLE.
!
! FOR COMPLETENESS, ALLOW IMINST,IMAXST,IMINLT,IMAXLT TO SPECIFY THE
! RANGE OF SCATTERING SYMMETRIES, THEN MIN/MAXS/L/T/P REFER TO TARGET
! AND ITS PARENT SYMMETRY RANGES.
!
! N.B. ALWAYS HELD ALL THREE POSSIBILITIES INTERNALLY, BUT IT WAS ONLY
! POSSIBLE TO READ/USE A PAIR (NASTP, NAST OR NAST, INAST.)
!
! NASTJ>0 READS 2J P, NASTJ<=0 SELECTS BY RANGE MINJT,MAXJT.
! THERE IS NO SELECTION BY PARENT J.
!
! INASTJ ONLY, ONLY CONTROLS JP SCATTERING SYMMETRIES.
!
! NASTJ STILL REFERS TO N-ELECTRON TARGET ONLY NOW - NO RE-MAP!
!
! INASTJ<=0 "MUST" STILL ALLOW HISTORIC USE OF MINJT,MAXJT
! TO SET RANGE OF SCATTERING SYMMETRIES, THEN DW ONLY USES MINJTP,MAXJTP
! TO REFER TO TARGET.
!
! FOR COMPLETENESS, ALLOW IMINJT,IMAXJT TO SPECIFY THE RANGE OF
! SCATTERING SYMMETRIES, THEN MINJT,MAXJT REFER TO TARGET
! SYMMETRY RANGE.
!
! *** NOT IN DUMP FILE, SO DO NOT CHANGE IF A RESTART IS IMPLEMENTED.
!
!-----------------------------------------------------------------------
!
      IF(IDW.NE.0)THEN
!
        IF(NAST.GT.0.AND.NASTP.GT.0)THEN           !FOR INFO
          WRITE(MW6,10190)INAST,NAST,NASTP
          WRITE(MW0,*)'***N.B. INAST, NAST, NASTP REFER TO SCATTERING,',&
     &                ' TARGET AND PARENT SYMMETRIES - NO RE-MAPS'
        ENDIF
!
        IF(ABS(MODD).LE.1)THEN                     !IC
          IF(NASTJ.GT.0)THEN                       !FOR INFO
            WRITE(MW6,10200)INASTJ,NASTJ
            WRITE(MW0,*)'***N.B. INASTJ, NASTJ REFER TO SCATTERING',    &
     &                ' AND TARGET SYMMETRIES - NO RE-MAPS (OR PARENTS)'
          ENDIF
        ENDIF
!
      ELSE                        !RESTRICT USE TO SCATTERING SYMMETRIES
        INAST=0
        INASTJ=0
      ENDIF
!
      ILMAX=0
!
! FIRST LOOP OVER FOR PARENT TERMS (TARGET PARENT FOR IDW.NE.0)
!
      JAXSL=0
      IF(NASTP.GT.0)THEN
!        IF(IDW.EQ.0)THEN
        IF(CODE.EQ.'S.S.')THEN                  !AS KMAX UNKNOWN STILL
          IXD10=IXD08/21+1
          IXD10=IXD10*5
          JAXCF=MAX(IXD10,MXD10)                !BUT USER HAS TO TYPE-IN
        ELSE                                    !A.S. WE KNOW
          JAXCF=KMAX
        ENDIF
!
        NN=NASTP
        JAXSL=0
        DO I=1,NASTP
          READ(MR5,*)IPCF,NPCF                  !CF SPECIFIC
          NN=NN+NPCF
          JAXSL=MAX(JAXSL,NPCF)
          DO N=1,NPCF
            READ(MR5,*)IS,IL,IP
          ENDDO
        ENDDO
        DO I=1,NN
          BACKSPACE(MR5)                         !SAFE?
        ENDDO
!
! EX-COMMON/NRBLSP/
        ALLOCATE(LSPIP(JAXSL,JAXCF),NLSPIP(JAXCF))
!
        DO I=1,JAXCF                            !INITIALIZE
          NLSPIP(I)=0
        ENDDO
        DO I=1,NASTP
          READ(MR5,*)IPCF,NPCF                  !CF SPECIFIC
          IF(IPCF.LE.0.OR.IPCF.GT.KMAX)THEN     !CAN CHECK A.S. ONLY
            WRITE(MW6,*)' *** ILLEGAL CONFIGURATION NO.:',IPCF
            WRITE(MW0,*)' *** ILLEGAL CONFIGURATION NO.'
            GO TO 1200
          ENDIF
          IF(IPCF.LE.JAXCF)THEN
            DO N=1,NPCF
              READ(MR5,*)IS,IL,IP
              IF(N.LE.JAXSL)LSPIP(N,IPCF)=10000*IS+10*IL+IP
              ILMAX=MAX(ILMAX,IL)
            ENDDO
            NLSPIP(IPCF)=NPCF
          ELSE                                  !CASE S.S. ONLY
            WRITE(MW6,*)'NASTP: S.S. CASE SKIPPED FOR IPCF,NPCF=',IPCF, &
     &                  NPCF
            WRITE(MW6,*)'*** USE A.S. ***'
            WRITE(MW0,*)'NASTP: S.S. CASE SKIPPED *** USE A.S. ***'
            DO N=1,NPCF
              READ(MR5,*)IS,IL,IP
            ENDDO
          ENDIF
        ENDDO
        JAXSL=0
!        ENDIF
      ENDIF
!
! NOW FOR FULL TARGET CF TERMS
!
      IAXSL=0
      IF(NAST.GT.0)THEN
        IAXSL=MAX(JAXSL,NAST)
!
! EX-COMMON/NRBLS/
        ALLOCATE(LSPI(IAXSL),NLSPI(IAXSL))
!
!        NS=0                                              !ALL E-STATES
        IFLAG=0
        DO I=1,NAST
          READ(MR5,*)IS,IL,IP
          IF(IS.LT.0)THEN
            IS=-IS
            READ(MR5,*)NS
            IF(NS.LT.0)NS=0                                  !FOR SAFETY
            IFLAG=1
          ELSE
            NS=0
          ENDIF
          IF(I.LE.IAXSL)THEN
            IL=ABS(IL)
            IP=ABS(IP)
            IP=MOD(IP,ITWO)
            IF(IS.NE.0)THEN
              LSPI(I)=10000*IS+10*IL+IP
              NLSPI(I)=NS
            ELSE
              LSPI(I)=IL                                      !ASSUME CA
            ENDIF
          ENDIF
          ILMAX=MAX(ILMAX,IL)
        ENDDO
        IF(IFLAG.GT.0.AND.QN(MXORB).GE.90)THEN                !CONTINUUM
          WRITE(MW0,*)                                                  &
     &              '***WARNING, SR.ALGEB0: RESTRICTING TERMS TO LOWEST'&
     &              ,                                                   &
     &   ' NO. IN SYMMETRY GROUP LIKELY LEADS TO NON-DEGENRATE CHANNELS'
          WRITE(MW6,*)                                                  &
     &              '***WARNING, SR.ALGEB0: RESTRICTING TERMS TO LOWEST'&
     &              ,                                                   &
     &   ' NO. IN SYMMETRY GROUP LIKELY LEADS TO NON-DEGENRATE CHANNELS'
        ENDIF
      ELSEIF(NAST.LT.0)THEN
        IF(BLOOP.AND.LRANGE.GE.0)THEN
          MINLT=LNEW-LRANGE
          MAXLT=LNEW+LRANGE
        ENDIF
      ENDIF
      IAXSL=MAX(JAXSL,IAXSL)
      IF(IAXSL.GT.MAXSL)THEN
        IF(MAXSL.GT.0)WRITE(MW6,10130)IAXSL,MAXSL
      ENDIF
!
! NOW SCATTERING SYMMETRIES
! (READ THEM IF USER SPECIFIES, EVEN IF IDW.EQ.0 - IGNORE THEN.)
!
      IF(INAST.GT.0)THEN
        IAXSL=MAX(IAXSL,INAST)
        ALLOCATE(LSPIB(INAST))    !LSPIB(INAST) IF ->LSPI(I) - NOT USED
!
        DO I=1,INAST
          READ(MR5,*)IS,IL,IP
          LSPIB(I)=10000*IS+10*IL+IP
          ILMAX=MAX(ILMAX,IL)
        ENDDO
      ENDIF
!
      IF(IDW.NE.0)THEN          !BACK-UP THEN COPY-IN MIN/MAX FOR TARGET
!
        NASTB=INAST             !NO RE-MAP (OF NAST/P) FOR SCATTERING
!
        IF(IMAXLT.GE.IMINLT)THEN
                                !EXPLICIT SCATTERING SYMMETRY SETTINGS
          MINLTB=IMINLT
          MAXLTB=IMAXLT
          MINSTB=IMINST
          MAXSTB=IMAXST
        ELSE                    !BUT ALLOW RE-MAP OF HISTORIC RANGES
! SCATTERING
          MINLTB=MINLT
          MAXLTB=MAXLT
          MINSTB=MINST
          MAXSTB=MAXST
! TARGET
          MINLT=MINLTP
          MAXLT=MAXLTP
          MINST=MINSTP
          MAXST=MAXSTP
! TARGET PARENT (CAN ONLY RESTRICT VIA NASTP.GT.0)
          MINSTP=0
          MAXSTP=2000
          MINLTP=0
          MAXLTP=2000
        ENDIF
!
        IF(NASTB.LE.0)THEN
          IF(MINLTB.LT.0)MINLTB=0
          IF(MAXLTB.LT.0)THEN
            IF(INASTJ.GT.0)THEN
              WRITE(MW6,*)'*** HINT: CASE INASTJ.GT.0 MAYBE FASTER IF', &
     &                    ' YOU SET MAXLT EXPLICITLY'
              WRITE(MW0,*)'*** HINT: CASE INASTJ.GT.0 MAYBE FASTER IF', &
     &                    ' YOU SET MAXLT EXPLICITLY'
            ENDIF
            MAXLTB=30
          ENDIF
          IF(MAXLTB.LT.250)ILMAX=MAX(ILMAX,MAXLTB)
        ENDIF
!
      ENDIF
!
! DITTO BUT EXTEND TO LEVELS JP (2*J, P=0,1)
!
      IF(ABS(MODD).LE.1)THEN                     !IC
        IJMAX=0
!
        IF(NASTJP.GT.0)THEN    !THERE ARE NO JP PARENTS IN LSJP COUPLING
          WRITE(MW6,*)'*** ATTENTION: THERE IS NO PARENT JP SELECTION'
          WRITE(MW0,*)'*** ATTENTION: THERE IS NO PARENT JP SELECTION'
          NASTJP=0
        ENDIF
!
! FULL TARGET CF LEVELS
!
        IAXJG=0
        IF(NASTJ.GT.0)THEN
          IAXJG=NASTJ
!
! EX-COMMON/NRBJ/
          ALLOCATE(JPI(IAXJG),NJPI(IAXJG))
!
!          NS=0                                            !ALL E-STATES
          IFLAG=0
          DO I=1,NASTJ
            READ(MR5,*)IL,IP
            IF(IL.LT.0.OR.IP.LT.0)THEN
              IL=ABS(IL)
              IP=ABS(IP)
              READ(MR5,*)NS
              IF(NS.LT.0)NS=0                                !FOR SAFETY
              IFLAG=1
            ELSE
              NS=0
            ENDIF
            IP=MOD(IP,ITWO)
            IF(I.LE.IAXJG)THEN
              JPI(I)=10*IL+IP
              NJPI(I)=NS
            ENDIF
            IJMAX=MAX(IJMAX,IL)
          ENDDO
          IF(IFLAG.GT.0.AND.QN(MXORB).GE.90)THEN              !CONTINUUM
            WRITE(MW0,*)                                                &
     &              '***WARNING, SR.ALGEB0: RESTRICTING TERMS TO LOWEST'&
     &              ,                                                   &
     &   ' NO. IN SYMMETRY GROUP LIKELY LEADS TO NON-DEGENRATE CHANNELS'
            WRITE(MW6,*)                                                &
     &              '***WARNING, SR.ALGEB0: RESTRICTING TERMS TO LOWEST'&
     &              ,                                                   &
     &   ' NO. IN SYMMETRY GROUP LIKELY LEADS TO NON-DEGENRATE CHANNELS'
          ENDIF
        ENDIF
        IF(IAXJG.GT.MAXJG)THEN
          IF(MAXJG.GT.0)WRITE(MW6,10140)IAXJG
        ENDIF
!
! NOW SCATTERING SYMMETRIES
! (READ THEM IF USER SPECIFIES, EVEN IF IDW.EQ.0 - IGNORE THEN.)
!
        IF(INASTJ.GT.0)THEN
          IAXJG=MAX(IAXJG,INASTJ)
          ALLOCATE(JPIB(INASTJ))   !JPIB(INASTJ) IF ->JPI(I) - NOT USED
!
          DO I=1,INASTJ
            READ(MR5,*)IL,IP
            JPIB(I)=10*IL+IP
            IJMAX=MAX(IJMAX,IL)
          ENDDO
        ENDIF
!
        IF(IDW.NE.0)THEN        !BACK-UP THEN COPY-IN MIN/MAX FOR TARGET
!
          NASTJB=INASTJ
!
          IF(IMAXJT.GE.IMINJT)THEN
                                  !EXPLICIT SCATTERING SYMMETRY SETTINGS
            MINJTB=IMINJT
            MAXJTB=IMAXJT
          ELSE                    !BUT ALLOW RE-MAP OF HISTORIC RANGES
! SCATTERING
            MINJTB=MINJT
            MAXJTB=MAXJT
! TARGET
            MINJT=MINJTP
            MAXJT=MAXJTP
! PARENT - THERE IS NONE
          ENDIF
!
          IF(NASTJB.LE.0)THEN
            IF(NASTB.GT.0)THEN
              WRITE(MW6,*)'***ERROR: YOU MUST SPECIFY INASTJ JP ',      &
     &        'IF YOU SPECIFY INAST LSP SYMMETRIES ELSE MADNESS ENSUES!'
              WRITE(MW0,*)'***ERROR: MUST SPECIFY INASTJ IF YOU ',      &
     &                    'SPECIFY INAST'
              GO TO 1200                                !RETURN
            ENDIF
            IF(MINJTB.LT.0)THEN
              MINJTB=2*MINLTB
              IF(MAXSTB.LT.100)THEN
                MINJTB=MINJTB+MIN(MINJTB,MAXSTB-1)
              ELSE
                MINJTB=MINJTB+MIN(MINJTB,12_SP)         !SO BEST SPECIFY
              ENDIF
            ENDIF
            IF(MAXJTB.LT.0)THEN
              MAXJTB=2*MAXLTB
              IF(MAXSTB.LT.100)THEN
                MAXJTB=MAXJTB-MAXSTB+1
              ELSE
                MAXJTB=MAXJTB-12                        !SO BEST SPECIFY
              ENDIF
            ENDIF
            IF(MAXJTB.LT.500)IJMAX=MAX(IJMAX,MAXJTB)
          ENDIF
        ENDIF
!
        IJMAX=IJMAX/2
        ILMAX=MAX(ILMAX,IJMAX)
      ENDIF
!
!***
      MINSP=MINST                              !RE-LABEL FOR /NRBLS/ TO
      MAXSP=MAXST                              !AVOID SLATER-STATE MAXST
!***
!
!-----------------------------------------------------------------------
!
      MXDFS0=4*(ILMAX+10)                      !RE-CHECK FACTORIAL ARRAY
      IXDFS0=MIN(IXDFS3,IXDFS6)
      IF(MXDFS0.GT.IXDFS0)THEN
        WRITE(MW6,10120)MXDFS0,IXDFS0,XP                       !FOR INFO
!        WRITE(MW0,*)                     !NOW USE RECURSION SO NO ABORT
!     &         'ALGEB0: FACTORIAL ARRAY TOO SHORT - INCREASE PRECSN XP'
!        GO TO 1000                                    !RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
! READ AND PROCESS DRR NAMELIST INPUT
!
!***********************************************************************
!
! ORBITAL INPUT DATA (IF XDR.NE.' ' OR RUN.EQ.'DR','RR','RE','PE')
! FOR RYDBERG VALENCE ELECTRON (DEFINED BY INPUT N IN RANGE 80-89)
! TO BE LOOPED OVER NL:
!
! N INCREMENTED BY 1 AT A TIME FROM NMIN TO NMAX.
!
! NSW=N-VALUE FOR SWITCH TO APPROXIMATING BOUND ORBITAL BY CONTINUUM,
!     WHERE NSW=(L*L)/4+NS0  AND L IS THE A.M. (NS0 DEFAULTS TO 15).
!     N.B. THIS APPROXIMATION SHOULD BE TESTED-OUT CAREFULLY. FOR HIGHER
!     RESIDUAL CHARGES LMAX WILL INCREASE BUT IT SHOULD PROVE POSSIBLE
!     TO REDUCE NSW TO E.G. L+NS0  WHERE NS0=20 SAY.
!
! NRAD=N-VALUE FOR SWITCH TO NEGLECTING RADIATION BY VALENCE ELECTRON.
!
! JND>0 ADDITIONAL N-VALUES TO BE READ-IN IN ASCENDING ORDER AND SHOULD
!     DIFFER BY AT LEAST 2 SINCE AN ADDITIONAL POINT IS INSERTED
!     BETWEEN EACH INPUT POINT SUCH THAT STEP LENGTH FOR SIMPSON RULE
!     SUM OVER N HAS STEP LENGTH=N1**(-2)-N2**(-2)=N2**(-2)-N3**(-2)
!     FOR TRANSFORMATION U=N**(-2).
! JND<=-99, USES LOG SPACED N-VALUES FROM NDR1=NMAX+1 TO NDR2=999
!     DEFINED BY: NDR1*RATN**J FOR J=0...JMAX I.E. NDR2=NDR1*RATN**JMAX,
!     WITH RATN=1.2 DEFAULT. THEN RESETS JND.
! -99<JND<0 USES -JND VALUES LOG SPACED AS ABOVE, BUT READ NDR2 AS PER>0
!     I.E. JND DEFINES RATN. IF USER SETS RATN>0 THEN JND IS IGNORED
!     AND OPERATION IS AS <=-99 BUT WITH THE RESTRICTED NDR2.
!    =0, NO ADDITIONAL N.
!
! DEFAULTS:
!     NMIN=MAX TARGET N+1
!     NMAX=24
!     JND=-99, SETS-UP ITS OWN MESH FROM NMAX+1 TO N=999
!     RATN=-1.2 (ONLY AVAILABLE VIA NAMELIST)
!     NS0=15 (DR) 20 (RR)
!     NRAD=1000  (NO DROP)
!
!  LMAX .GE. LMIN (.GE.0)  LOOPS OVER L FOR A SINGLE VALENCE ELECTRON.
!     DEFAULT, NO LOOP - USES THE THE ACTUAL L-VALUE OF THE VALENCE
!     ORBITAL(S). THIS ENABLES N-LOOPING WITH MULTIPLE VALENCE L-ORBS.
!
!  LCON=NO. OF CONTINUUM ORBITALS, THEIR A.M. DETERMINED BY PROGRAM.
!     DEFAULT=2*LA+1, WHERE LA IS THE MAX CORE/TARGET ONE-ELECTRON A.M.
!
!***********************************************************************
!
      JND=-1
      IF(IDR.NE.0)THEN                      !IDR<-BDR ALLOW RYD W/O CONT
        LORIG=-1
        LINC=1
        NSX=35
        NSW=-1
        RATN=-1.2D0
        NBOUND=500
        IF(BNAME)THEN
          NMIN=-999
          NMAX=24
          if(bfot)then
            ns0=21
          else
            NS0=15
          endif
          IF(.NOT.BDR)NSW=9999           !DEFAULT TO NO ZERO CONT APPROX
          NRAD=1000
          JND=-99
          NMESH=-1973
          LMIN=-1
!          LMAX=-1
!          LCON=-1
!
          REWIND(MR5)                  !CASE USER NAMELISTS OUT OF ORDER
!
          READ(MR5,DRR,END=1100,ERR=1100)  ! <----------------- NAMELIST
!
          IF(NMESH.NE.-1973)THEN
            IF(JND.NE.-99)THEN
              WRITE(MW6,*)                                              &
     &         '*** SR.ALGEB0: WARNING, YOU HAVE SET BOTH NMESH AND JND'&
     &         ,NMESH,JND
              WRITE(MW6,*)                                              &
     &           '*** SR.ALGEB0: USING HISTORIC JND VALUE IN PREFERENCE'&
     &           ,JND
              WRITE(MW0,*)                                              &
     &         '*** SR.ALGEB0: WARNING, YOU HAVE SET BOTH NMESH AND JND'
              WRITE(MW0,*)                                              &
     &           '*** SR.ALGEB0: USING HISTORIC JND VALUE IN PREFERENCE'
            ELSE
              JND=NMESH
            ENDIF
          ENDIF
          IF(JND.LT.0.AND.NMAX.GT.25)THEN
            WRITE(MW6,*)                                                &
     &        '*** SR.ALGEB0: ATTENTION, AS WILL ADD N-VALUES UP TO 999'
            WRITE(MW6,*)                                                &
     &             '*** SR.ALGEB0: SET JND/NMESH=0 TO END AT YOUR NMAX='&
     &             ,NMAX
            WRITE(MW0,*)                                                &
     &        '*** SR.ALGEB0: ATTENTION, AS WILL ADD N-VALUES UP TO 999'
            WRITE(MW0,*)                                                &
     &        '*** SR.ALGEB0: SET JND/NMESH=0 TO END AT YOUR INPUT NMAX'
          ENDIF
!
        ELSE
!
          READ(MR5,10020)NMIN,NMAX,NS0,NRAD,JND,LMIN,LMAX,LCON
!
        ENDIF
!
        IF(CODE.EQ.'S.S.')THEN       !AS DON'T HAVE CONFIGS YET
          IF(NMIN.LE.0)THEN
            WRITE(MW6,*)                                                &
     &                "***SR.ALGEB0: ERROR, MUST DEFINE NMIN FOR 'S.S.'"
            WRITE(MW0,*)                                                &
     &                "***SR.ALGEB0: ERROR, MUST DEFINE NMIN FOR 'S.S.'"
            GO TO 1200
          ELSE
            KMX=-KMAX
          ENDIF
        ELSE
          KMX=KMAX
        ENDIF
!
        NMIN0=NMIN
        NMIN=0
        I0=ABS(MB)+1                 !K2
        DO K=1,KMX                  !AS DON'T HAVE DEY DEFINED YET...
          DO I=I0,MXORB
            IF(NEL(I,K).GT.0.AND.QN(I).LT.60)                           &
     &         NMIN=MAX(NMIN,INT(QN(I),SP))
          ENDDO
        ENDDO
        NMIN=NMIN+1                  !SAFE NMIN
        IF(NMIN0.GT.0)THEN
          IF(NMIN0.LT.NMIN)THEN      !UNSAFE NMIN
            WRITE(MW6,*)'***SR.ALGEB0: YOU HAVE SET NMIN.LE.A CORE-N...'
            WRITE(MW0,*)'***SR.ALGEB0: YOU HAVE SET NMIN.LE.A CORE-N...'
          ELSE
            NMIN=NMIN0               !USER'S LARGER
          ENDIF
        ENDIF
!          write(mw6,*)'nmin=',nmin
!
        NMIN=MAX(NMIN,LMIN+1)
        NTEST=NMAX
!
        IF(NS0.LT.1)NS0=15
        IF(NSX.LT.1)NSX=35
        IF(NRAD.LT.1)NRAD=1000
        IF(JND.EQ.0)GO TO 700
!
        JND0=JND
        IF(JND0.GT.0)THEN
          IXNDR=2*JND+1
        ELSE
          IF(NMAX.LT.NMIN)NMAX=NMIN
          NDR1=NMAX+1
          JND=-JND
          IF(JND.GE.99)THEN
            RATN=ABS(RATN)
            NDR2=999
          ELSE
            READ(MR5,*)NDR2
            IF(NDR2.LT.NDR1)NDR2=999
          ENDIF
          IF(NDR2.LT.NDR1)THEN
            JND=0
            GO TO 650
          ENDIF
          IF(RATN.GT.DZERO)THEN
            T2=NDR2
            T1=NDR1
            T=(LOG(T2)-LOG(T1))/LOG(RATN)
!            write(mw6,*)t
            JND=NINT(T,SP)
          ENDIF
          JND=MAX(JND,ITWO)
          IXNDR=JND
        ENDIF
!
! EX-COMMON/NRBDR/
        ALLOCATE(NDR(IXNDR),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB0: ALLOCATION FAILS FOR NDR'
          NF=0
          GO TO 900
        ENDIF
!
        IF(JND0.GT.0)THEN
          READ(MR5,*)(NDR(2*J-1),J=1,JND)
        ELSE
          TJ=JND-1
          TJ=DONE/TJ
          T=NDR2
          T=T/NDR1
          RATN=T**TJ
          NDR(1)=NDR1
          NDR(2)=NINT(NDR1*RATN,SP)
          DO J=3,JND
            TN=NDR(J-1)*RATN
            NDR(J)=NINT(TN,SP)
            IF(NDR(J).LE.NDR(J-1))THEN
              WRITE(MW6,*)'N-MESH TOO DENSE, DECREASE JND=',JND,        &
     &                    ' OR INCREASE NDR(JND)=',NDR2
              WRITE(MW0,*)'N-MESH TOO DENSE!'
              GO TO 1200
            ENDIF
            IF(NDR(J-1).GT.150)THEN
              T=NDR(J-1)
              T=T/10
              N=NINT(T,SP)
              NDR(J-1)=10*N
            ELSEIF(NDR(J-1).GT.60)THEN
              T=NDR(J-1)
              T=T/5
              N=NINT(T,SP)
              NDR(J-1)=5*N
            ENDIF
          ENDDO
          NDR(JND)=NDR2
          GO TO 650
        ENDIF
!
        IF(NMAX.LT.0.OR.NMAX.LT.NMIN)GO TO 550
        IF(NDR(1).EQ.NMAX+1)GO TO 550
!        if(nmin.gt.0)go to 550                !debug, no extra n-values
!
! TRY AND CORRECT USER MIS-ALIGNMENT OF START OF N-MESH WITH END OF SEQ.
!
        WRITE(MW6,*)                                                    &
     &      '*** SR.ALGEB0: ATTEMPT TO CORRECT USER MIS-MATCH OF START '&
     &      ,'OF N-MESH WITH END OF SEQUENTIAL',NMAX,NDR(1)
        WRITE(MW0,*)                                                    &
     &      '*** SR.ALGEB0: ATTEMPT TO CORRECT USER MIS-MATCH OF START '&
     &      ,'OF N-MESH WITH END OF SEQUENTIAL',NMAX,NDR(1)
!
        IF(NDR(1).GT.NMAX+1)THEN  !ADD NMAX+1 SO MIS-MATCH NOT TOO LARGE
          DO J=JND,1,-1
            J2=J+J
            NDR(J2+1)=NDR(J2-1)
          ENDDO
          JND=JND+1
          NDR(1)=NMAX+1              !ASSUMES MIS-MATCH NOT TOO LARGE...
        ELSEIF(NDR(1).LT.NMAX+1)THEN                  !NEED TO DROP SOME
          DO J=1,JND
            J2=J+J
            IF(NDR(J2-1).GT.NMAX+1)THEN
              J2=1
              NDR(J2)=NMAX+1
              DO K=J,JND
                J2=J2+2
                K2=K+K
                NDR(J2)=NDR(K2-1)
              ENDDO
              JND=1+J2/2
              GO TO 550
            ENDIF
          ENDDO
        ENDIF
!
  550   IF(JND.LT.2)GO TO 600
        J22=JND
!
        DO J=2,J22
          J2=J+J
          IF(NDR(J2-1).LE.NDR(J2-3)+1)THEN
            JND=JND-1
            IF(JND.LT.J)GO TO 600
            DO I=J,JND
              J2=J+J
              NDR(J2-1)=NDR(J2+1)
            ENDDO
          ENDIF
        ENDDO
!
  600   IF(JND.GT.1)THEN
          DO J=2,JND
            J1=J+J-3
            J2=J1+2
            T1=NDR(J1)
            T2=NDR(J2)
            T=DONE/(SQRT(DHALF/(T1*T1)+DHALF/(T2*T2)))+DHALF
            NDR(J1+1)=INT(T,SP)
          ENDDO
          JND=JND+JND-1
        ENDIF
!
  650   NTEST=NDR(JND)
!
  700   N=NTEST
!
        IF(NBOUND.GT.500)THEN
          WRITE(MW6,*)'*** WARNING! YOU HAVE INCREASED THE MAX POSSIBLE'&
     &                ,                                                 &
     &               ' TRUE BOUND N BEYOND THE SAFEISH DEFAULT (500) TO'&
     &               ,NBOUND
          WRITE(MW0,*)'*** WARNING! YOU HAVE INCREASED THE MAX POSSIBLE'&
     &                ,                                                 &
     &               ' TRUE BOUND N BEYOND THE SAFEISH DEFAULT (500) TO'&
     &               ,NBOUND
        ENDIF
        IF(N.GT.NBOUND.AND.N.LT.NSW)THEN !CHECK TRUE BOUND NOT TOO LARGE
          IF(NSW.EQ.9999)THEN
            WRITE(MW6,*)'*** TRUE BOUND N TOO LARGE, SET RUN.NE." ":',N
            WRITE(MW0,*)'*** TRUE BOUND N TOO LARGE, SET RUN.NE." ":',N
          ELSEIF(NSW.GT.NBOUND)THEN
            WRITE(MW6,*)'*** TRUE BOUND N TOO LARGE, REDUCE NSW:',NSW
            WRITE(MW0,*)'*** TRUE BOUND N TOO LARGE, REDUCE NSW:',NSW
          ELSE
            WRITE(MW6,*)'*** TRUE BOUND N TOO LARGE, REDUCE:',N
            WRITE(MW0,*)'*** TRUE BOUND N TOO LARGE, REDUCE:',N
          ENDIF
          GO TO 1200
        ENDIF
!
!        write(mw6,*)nmin,nmax,ratn,jnd,':',(ndr(j),j=1,jnd)
!par!                                                               !par
!par        if(nprocperl.gt.1.and.iam.eq.0)then  !n-mesh for adasdr !par
!par          open(mw34,file='n-mesh.dat',status='replace')         !par
!par          do j=nmin,nmax                                        !par
!par            write(mw34,*)j                                      !par
!par          enddo                                                 !par
!par          do j=1,jnd                                            !par
!par            write(mw34,*)ndr(j)                                 !par
!par          enddo                                                 !par
!par          close(mw34,status='keep')                             !par
!par          iunit(mw34)=-1                                        !par
!par        endif                                                   !par
!par!                                                               !par
!par        if(linc.ne.1)then                                       !par
!par          write(mw6,*)                                          !par&
!par     &     'LINC must equal 1 (default) for parallel operation' !par
!par          if(iam.eq.0)write(mw0,*)                              !par&
!par     &     'LINC must equal 1 (default) for parallel operation' !par
!par          go to 5500                                            !par
!par        endif                                                   !par
!par!                                                               !par
!par        mst5=mod(mstrt0,irl5)                                   !par
!par        if(mst5.lt.5)then                                       !par
!par          lproc=nproc                                           !par
!par          mapiam=0             !ensure as parallel by l here    !par
!par        elseif(lproc.le.0)then                                  !par
!par          lproc=0                                               !par
!par          jam=-1                                                !par
!par 5000     jam=jam+1                                             !par
!par          j1=jam/10                                             !par
!par          j2=jam-(10*(jam/10))                                  !par
!par          name0=num(j1)//num(j2)                                !par
!par          name='RESTART'//name0                                 !par
!par          inquire(file=name,exist=bex)                          !par
!par          if(bex)go to 5000                                     !par
!par          lproc=jam                                             !par
!par!        else          !assume user knows what she is doing     !par
!par        endif                                                   !par
!par!                                                               !par
!par        lrangp=lmax-lmin+1                                      !par
!par!                                                               !par
!par        if(lproc.gt.lrangp)then                                 !par
!par          write(mw6,*)'Too many processors for specified '      !par&
!par     &             ,'l-range, use nproc=',lrangp                !par
!par          if(iam.eq.0)write(mw0,*)                              !par&
!par     &               'Too many processors for specified l-range'!par
!par          go to 5500                                            !par
!par        endif                                                   !par
!par!                                                               !par
!par        lperproc=lrangp/lproc                                   !par
!par        lxtra=lrangp-lperproc*lproc                             !par
!par!                                                               !par
!par        if(mapiam.le.0)then      !nprocperl, inc. 1             !par
!par!                                                               !par
!par          nprocperl=nproc/lproc                                 !par
!par!                                                               !par
!par          if(lproc*nprocperl.ne.nproc)then                      !par
!par            write(mw6,*)'nproc=',nproc,' must be an integer '   !par&
!par     &            ,'multiple of the',lproc,' RESTART files'     !par
!par            if(iam.eq.0)write(mw0,*)                            !par&
!par     &                 'Too many n-processors for lproc set-up' !par
!par            go to 5500                                          !par
!par          endif                                                 !par
!par!                                                               !par
!par          liam=iam/nprocperl                                    !par
!par          jiam=mod(iam,nprocperl)                               !par
!par!                                                               !par
!par        else                    !one nl-per proc                !par
!par!                                                               !par
!par          i=-1                                                  !par
!par          do l=0,lproc-1                                        !par
!par            j=-1                                                !par
!par            l0=lmin+l*lperproc+min(lxtra,l)                     !par
!par            n0=max(nmin,l0+1)                                   !par
!par            do n=n0,nmax                                        !par
!par              i=i+1                                             !par
!par              j=j+1                                             !par
!par              if(iam.eq.i)then                                  !par
!par                liam=l                    !RESTART file index   !par
!par                niam=n                                          !par
!par                jiam=j          !output file index label only   !par
!par              endif                                             !par
!par            enddo                                               !par
!par!                                                               !par
!par            if(j.lt.0)then                                      !par
!par              write(mw6,*)'*** need nmax of at least:',n0       !par
!par              if(iam.eq.0)write(mw0,*)                          !par&
!par     &                   '*** need nmax of at least:',n0        !par
!par              go to 5500                                        !par
!par            endif                                               !par
!par!                                                               !par
!par            do nd=1,jnd                                         !par
!par              i=i+1                                             !par
!par              j=j+1                                             !par
!par              if(iam.eq.i)then                                  !par
!par                liam=l                                          !par
!par                niam=-ndr(nd)  !minus flags 2nd n-loop (unused) !par
!par                jiam=j                                          !par
!par              endif                                             !par
!par            enddo                                               !par
!par          enddo                                                 !par
!par!                                                               !par
!par          i=i+1                              !align             !par
!par          if(i.ne.nproc)then                                    !par
!par            write(mw6,*)"nproc does not match no. nl's =",i     !par
!par            if(iam.eq.0)write(mw0,*)"nproc does not match nl's" !par
!par            go to 5500                                          !par
!par          endif                                                 !par
!par!                                                               !par
!par          nprocperl=999                      !flag              !par
!par!                                                               !par
!par        endif                                                   !par
!par!                                                               !par
!par        lmin=lmin+liam*lperproc+min(lxtra,liam)                 !par
!par        nmin=max(nmin,lmin+1)                                   !par
!par        lmax=lmin+lperproc-1                                    !par
!par        if(liam.lt.lxtra)lmax=lmax+1                            !par
!par!                                                               !par
!par!        write(mw0,*)iam,liam,lmin,lmax                         !par
!
        BLOOP=LMIN.LE.LMAX.AND.LMIN.GT.-1
        IF(BLOOP)THEN
          LNEW=LMIN+LSUM*LINC
        ELSE
          LNEW=999                                      !FOR N-LOOP ONLY
        ENDIF
        IF(LORIG.LT.0)LORIG=LMIN                    !NEEDED FOR PARALLEL
!
        IF(LCON.LT.0.AND.LCONT.GT.0)LCON=LCONT
        IF(LCON.LT.1)LCON=3
        IF(LCONT.GT.0.AND.LCONT.NE.LCON)THEN
          WRITE(MW6,10180)LCON,LCONT
          LCON=LCONT
        ENDIF
!
        MXDFS0=4*(LMAX+LCON+10)                !RE-CHECK FACTORIAL ARRAY
        IF(MXDFS0.GT.IXDFS0)THEN
          WRITE(MW6,10120)MXDFS0,IXDFS0,XP                     !FOR INFO
!        WRITE(MW0,*)                     !NOW USE RECURSION SO NO ABORT
!     &         'ALGEB0: FACTORIAL ARRAY TOO SHORT - INCREASE PRECSN XP'
!        GO TO 1000                                    !RETURN
        ENDIF
!
!par      elseif(idw.eq.0.and.iam.eq.0)then                         !par
!par      write(mw0,*)'***STRUCTURE RUN HAS *NOT* BEEN PARALLELIZED'!par
!par      write(mw0,*)'***EACH PROCESSOR IS RUNNING A DUPLICATE JOB'!par
      ELSE
        IF(BFOT.AND.LCON.LT.1)LCON=3                     !FOR S.S. IXD24
      ENDIF
!
! SET FOR A NON L-LOOPING RUN
!
      IF(.NOT.BLOOP)LMAX=-1
!
!-----------------------------------------------------------------------
!
! CASE 'S.S.' DECODE CONFIGURATIONS AND PERFORM SOME INITIALIZATIONS.
! CASE 'A.S.' ASSIGN ANY RYDBERG/CONTINUUM ORBITAL ANGULAR MOMENTUM.
! BOTH: OPTIONALLY SET RELAXED ORBITALS.
!
!-----------------------------------------------------------------------
!
      NF=MAXEL                             !INITIALIZE TO CHECK CF INPUT
!
! LEGACY CODE MADE SPACE FOR CONTINUUM ELECTRON, CASE EIE.
!      IF(IDW.NE.0)NF=NF-1
!
      CALL CONFG1
!
      IF(NF.LE.0)GO TO 800       !PROBLEM WITH CONFIG INPUT (BLF=.TRUE.)
!
      KUTLS=MIN(KUTLS,KMAX)                                 !ALIGN KUTLS
!
! GET MAX TARGET L
!
      QLMAX=0
      DO I=1,MXORB
        QLMAX=MAX(QLMAX,QL(I))
      ENDDO
      ILMAX=INT(QLMAX/2,SP)
!
      MXDFS0=4*(ILMAX+10)                      !RE-CHECK FACTORIAL ARRAY
      IXDFS0=MIN(IXDFS3,IXDFS6)
      IF(MXDFS0.GT.IXDFS0)THEN
        WRITE(MW6,10120)MXDFS0,IXDFS0,XP                       !FOR INFO
!        WRITE(MW0,*)                     !NOW USE RECURSION SO NO ABORT
!     &         'ALGEB0: FACTORIAL ARRAY TOO SHORT - INCREASE PRECSN XP'
!        GO TO 1000                                    !RETURN
      ENDIF
!
! RE-MAP HISTORIC "KUTSS" FLAG
!
      IF(NSL0.GE.0)THEN
! EX-COMMON/NRBAL3/
        ALLOCATE(KCFSS(KMAX),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB0: ALLOCATION FAILS FOR KCFSS'
          NF=0
          GO TO 800
        ENDIF
!
        DO I=1,KMAX
          KCFSS(I)=0
        ENDDO
        IF(MCFSS.GT.0)THEN
          DO I=1,MCFSS
            J=KCFS0(I)
            IF(J.LE.KMAX)THEN
              KCFSS(J)=1
            ELSE
              WRITE(MW0,*)'*** SR.ALGEB0: MCFSS ILLEGAL CONFIG NO.',J
              WRITE(MW6,*)'*** SR.ALGEB0: MCFSS ILLEGAL CONFIG NO.',J
              NF=-1
              GO TO 800
            ENDIF
          ENDDO
        ENDIF
      ENDIF
      IF(MCFSS.GT.0)DEALLOCATE(KCFS0)             !MAYBE READ IN CA...
!
!-----------------------------------------------------------------------
!
! NOW WE HAVE FINAL "MAXGR" AND "MAXCF" SO CAN REDUCE BUFFER FOR NEL:
!
      IF(IAXGR.NE.MXORB.OR.IAXCF.NE.KMAX)THEN
!
        CALL RE_ALLOC2(NEL,IONE,IAXGR,IONE,IAXCF,MXORB,KMAX,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'SR.ALGEB0: RE-ALLOCATION FAILS FOR NEL'
          NF=0
          GO TO 800
        ENDIF
!
      ENDIF
!
! SIMILARLY FOR ICFGP
!
      IF(IAXCF.NE.KMAX)THEN
!
        CALL RE_ALLOC(ICFGP,IONE,IAXCF,KMAX,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'SR.ALGEB0: RE-ALLOCATION FAILS FOR ICFGP'
          NF=0
          GO TO 800
        ENDIF
!
      ENDIF
!
! SIMILARLY FOR IEQ,IGRCF & QL,QN,DEY
!
      IF(IAXGR.NE.MXORB)THEN
!
        CALL RE_ALLOC(IEQ,IZERO,IAXGR,MXORB,IERR)
        CALL RE_ALLOC(IGRCF,IONE,IAXGR,MXORB,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'SR.ALGEB0: RE-ALLOCATION FAILS FOR IEQ,IGRCF'
          NF=0
          GO TO 800
        ENDIF
!
        CALL RE_ALLOC(QL,IONE,IAXGR,MXORB,IERR)
        CALL RE_ALLOC(QN,IONE,IAXGR,MXORB,IERR)
        CALL RE_ALLOC(DEY,IONE,IAXGR,MXORB,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'SR.ALGEB0: RE-ALLOCATION FAILS FOR QN,QL,DEY'
          NF=0
          GO TO 800
        ENDIF
!
      ENDIF
!
! HISTORICALLY, DO NOT REFERENCE IAXGR, IAXCF FURTHERMORE.
! RATHER USE MXORB, KMAX, BUT THIS MAY CHANGE, SO:
!
      IAXGR=MXORB
      IAXCF=KMAX
!
!-----------------------------------------------------------------------
!
  800 IF(KCUTP0.EQ.-9999)THEN                                   !TIDY-UP
        KCUTP0=KCUTP
        KCUTP=0
      ENDIF
!
!-----------------------------------------------------------------------
!
  900 IF(ALLOCATED(IWRK1))THEN
        DEALLOCATE(IWRK1,IWRK2,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB0: DE-ALLOCATION FAILS FOR IWRK1,IWRK2'
          NF=0
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
 1000 WRITE(MW6,10240)
      WRITE(MW0,*)'*** SR.ALGEB0: ERROR READING NAMELIST SALGEB!' !FATAL
      GO TO 1200
!
 1100 WRITE(MW6,10250)
      WRITE(MW0,*)'*** SR.ALGEB0: ERROR READING NAMELIST DRR!'    !FATAL
!par!                                                               !par
!par 5500 continue                                                  !par
!
 1200 NF=-1
      GO TO 800
!
!-----------------------------------------------------------------------
!
10010 FORMAT(///' ',2A4)
10020 FORMAT(8I5)
10030 FORMAT(//' ***** FANO PHASE CONVENTION IN USE *****'/)
10040 FORMAT(4I2,A1,21(I2,A1),2A4)
10050 FORMAT(9X,21(I2,A1))
10060 FORMAT(///'SR.ALGEB0: YOU ARE TRYING TO READ MORE CONFIGURATION ',&
     &       'INPUT THAN THE BUFFER CAN HOLD-'/11X,                     &
     &       'AS BUFFER THE PROGRAM USES',                              &
     &       ' THE ARRAYS OF SIZE  *MXD08=',I6,'.'/11X,                 &
     &       'EACH C CARD,AND THE ',                                    &
     &       'TERMINATOR, REQUIRE 21 LOCATIONS.'/11X,                   &
     &       'CASE SKIPPED. PUNCH MORE',                                &
     &       ' CONFIGURATIONS ON A CARD, OR AUGMENT MXD08 TO',I6/11X,   &
     &       '***LIKELY MAXCF TOO SMALL***')
10070 FORMAT(' *** ERROR: ILLEGAL INPUT N-VALUE=',I5,' .LE. 0 FOUND!')
10080 FORMAT(' *** ERROR: USER INPUT N-VALUE=',I5,'  FOUND. EXPLICIT ', &
     &       ' N-VALUES.GE. 70 ARE RESERVED FOR FLAGS ETC.'/4X,         &
     &       'INSTEAD, FLAG AS A RYDBERG ORBITAL AND SET DESIRED N(L) ',&
     &       'VALUE IN NAMELIST &DRR - SEE WRITEUP FOR DETAILS.')
10090 FORMAT(' *** ERROR: USER INPUT N-VALUE=',I5,' FLAGS AN EXTERNAL ',&
     &       'ORBITAL BUT NO radwin FILE FOUND!')
10100 FORMAT(' *** USER INPUT N-VALUE=',I5,                             &
     &       ' IS A RESERVED FLAG. I HOPE ',                            &
     &       'YOU KNOW WHAT YOU ARE DOING!')
10110 FORMAT(' *** ERROR: ILLEGAL INPUT L-VALUE=',I5,                   &
     &       ' IS GREATER THAN INPUT N-VALUE=',I5)
10120 FORMAT(/' *** ALGEB0: FACTORIAL ARRAY TOO SHORT,',I5,             &
     &       '.GT. IXDFS=',I5,' WITH CURRENT WORD PRECISION XP=',I3,    &
     &       '; 3J- AND 6J-COEFFS ARE DETERMINED BY RECURSION')
10130 FORMAT('*** SR.ALGEB0: ALLOCATION INCREASES NUMBER OF GROUPS ',   &
     &       ' IAXSL =',I3,' .GT. MAXSL=',I3)
10140 FORMAT(//'  *** INCREASE MAXJG IN PARAMETER STATEMENTS TO',I4)
10150 FORMAT(20A4)
10160 FORMAT(////1X,105('-')//1X,20A4//1X,105('-')//)
10170 FORMAT(' *** INPUT CODE ERROR: CURRENTLY ONLY S.S. AND A.S. ARE', &
     &       ' ALLOWED WHILE YOUR INPUT IS "',A4,'"')
10180 FORMAT(' *** NOTE: LCON HAS BEEN OVERWRITTEN BY EARLIER',         &
     &       ' DEFINITION:',2I3)
10190 FORMAT(/' *** N.B. INAST, NAST, NASTP NOW REFER ALWAYS TO',       &
     &' SCATTERING, TARGET AND (TARGET) PARENT SYMMETRIES - NO RE-MAPS:'&
     &,3I5)
10200 FORMAT(/' *** N.B. INASTJ, NASTJ NOW REFER ALWAYS TO ',           &
     &     'SCATTERING AND TARGET SYMMETRIES - NO RE-MAPS (OR PARENTS):'&
     &     ,2I5)
10210 FORMAT(/' *** COMMENT: HISTORIC DIMENSION CHECK MODD IS OBSOLETE-'&
     &       ,' ONLY 10% FASTER, AND IT SIGNIFICANTLY OVERESTIMATED'/13X&
     &       ,'SOME',                                                   &
     &       ' DIMENSIONS. A FAST, ACCURATE, BUT *PARTIAL* DIMENSION',  &
     &       ' TEST HAS BEEN IMPLEMENTED INSTEAD.'/7X,                  &
     &       'NOTE: NZION=0 EXITS',                                     &
     &       ' AT THE END OF A FULL ALGEBRA RUN.'//)
10220 FORMAT(/"*** THERE IS NO DIMENSION CHECK FOR RUN='DE'",           &
     &       ' - REDUNDANT NOW ALL ARRAYS ALLOCATABLE'/3X,              &
     &       ' REMOVE THE "SRADCON" NAMELIST TO EXIT',                  &
     &       ' AT THE END OF THE COLLISION ALGEBRA.'//)
10230 FORMAT(//1X,'THANK-YOU FOR CHOOSING AUTOSTRUCTURE (AS) AS YOUR ', &
     &       'ATOMIC CODE!'//5X,                                        &
     &       'AS IS A GENERAL DISTORTED-WAVE (DW) CODE'//5X,            &
     &       'PLEASE SET THE DESIRED RUN OPTION FROM THE LIST BELOW:'// &
     &       5X,'RUN="  " FOR ATOMIC STRUCTURE (DEFAULT)'/5X,           &
     &       'RUN="DR" FOR DIELECTRONIC RECOMBINATION'/5X,              &
     &       'RUN="RR" FOR RADIATIVE RECOMBINATION'/5X,                 &
     &       'RUN="PI" FOR PHOTOIONIZATION'/5X,                         &
     &       'RUN="PE" FOR PHOTOEXCITATION-AUTOIONIZATION'/5X,          &
     &       'RUN="DE" FOR DIRECT EXCITATION'/5X,                       &
     &       'RUN="RE" FOR RESONANT EXCITATION'/5X,                     &
     &       'RUN="DI" FOR DIRECT IONIZATION (NOT YET AVAILABLE)'//     &
     &       ' HAVE A GREAT DAY!'/)
10240 FORMAT(' *** SR.ALGEB0: ERROR READING NAMELIST SALGEB!'/4X,       &
     &       'IF PRESENT, CHECK FOR ILLEGAL OR MISTYPED VARIABLE NAMES')
10250 FORMAT(' *** SR.ALGEB0: ERROR READING NAMELIST DRR!'/4X,          &
     &       'IF PRESENT, CHECK FOR ILLEGAL OR MISTYPED VARIABLE NAMES')
!
      END SUBROUTINE ALGEB0
!
!                             *******************
!
      SUBROUTINE ALGEB1(QLML,QLMS,QBML,QBMS,JYI,JYF,IAXST,MAXEL)
!
!-----------------------------------------------------------------------
!
!  SR.ALGEB1 DEALS WITH THE PROBLEMS DESCRIBED IN SECTION 3.1 OF E+N
!  IT CALCULATES SLATER-STATES AND VECTOR COUPLING COEFFICIENTS (VCC)
!  FOR THE KMAX INPUT CONFIGURATIONS (FROM THE CODED INPUT IN QBML+QBMS
!  WHICH IS DECODED IN CONFG1).
!
!  OUTPUT:  FOR ANY OF THE KMAX CONFIGURATIONS KF: 1-QCP(KF)=PARITY,
!  SLST'S  NL'S AS QCG(I,KF),I=1,NF=GROUP NUMBER K OF I'TH ELECTRON
!  THE OTHER QUANTUM NUMBERS ARE IN SECTIONS J=JYI(KF)...JYF(KF) OF
!  QLMS,QLML(I,J)=2* LITTLE MS,ML OF I'TH ELECTRON IN SLST J;
!  QBMS,QBML(J)=2* TOTAL MS,ML OF SLST J (=SUM OVER LITTLE M'S).
!  TERMS  QTGS,QTGL(I),I=NTG(KF-1)+1,NTG(KF)=2*S,2*L
!  (QMCS,QMCL=2*SMAX,2*LMAX OF ALL THE NTG(KMAX) TERMS);
!  DC(JTGD(KF)+J)=VCC OF J'TH SLST TO TERM I, WITH I,J LIMITS ABOVE
!
!  IT IS CALLED BY:
!    SR.ALGEB
!
!  IT CALLS:
!    SR.DIMUSE
!    FN.QBINOM
!    SR.RE_ALLOC
!    SR.VCG
!    SR.VCU
!
!-----------------------------------------------------------------------
!
      USE COMMON_ALGEB,  ONLY: MPRINT
      USE COMMON_ALGEB,  ONLY: MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD     &
     &                        ,KFBUFF
!!      COMMON /BASIC/NF,KY,KG,JA,JB,JSP1,MSST,MGAP(5)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KY=>IBSK2,KG=>IBSK3,JA=>IBSK4,JB=>IBSK5            &
     &              ,JSP1=>IBSK6,MSST=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9  &
     &              ,IBSK10=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY,QCGS
      USE COMMON_DC,     ONLY: BFAST,DC,IDC,IXIDC
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_QTG,    ONLY: MTGD,NTT,NTG,JTGD,QTGS,QTGL,QTGD         &
     &                        ,NFI,NFK,NFQ
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL1, ONLY: NFS,KF,NB,JAS,JBS,KSI,KSF,NTGA,NTGB
      USE COMMON_NRBAL2, ONLY: MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBDR,  ONLY: MAXNV
      USE COMMON_NRBDW,  ONLY: IDW,btop
      USE COMMON_NRBGCF, ONLY: KGCF,NKSL,KSLX
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,NASTJ                           &
     &                        ,MINJT,MAXJT,NEIGENJ
      USE COMMON_NRBKUT, ONLY: KCUTX,LSKUT,NASTK
      USE COMMON_NRBKUTP,ONLY: KCUTP0,KCUTP,LSKUTP,NASTKP
      USE COMMON_NRBLIM, ONLY: ECNTRB,ITANAL,BANAL
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,NAST                          &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBLSP, ONLY: LSPIP,NLSPIP,NASTP                       &
     &                        ,MINSTP,MAXSTP,MINLTP,MAXLTP
      USE COMMON_NRBPNT, ONLY: NTGP,NTGS,NTP1,NTP2
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      CHARACTER(LEN=7) LABT
!
      INTEGER(EP) M8
!
      INTEGER(SP) QBINOM                       !DO NOT USE SHORT INTEGER
!
      ALLOCATABLE :: LL(:),KSUB(:),KMAP(:),IWT(:),DS(:)
!
      DIMENSION  QLMS(MAXEL,*),QBMS(*),QLML(MAXEL,*),QBML(*)            &
     &          ,JYI(*),JYF(*)
!
!-----------------------------------------------------------------------
!
      BFAST=DC(0).LT.DZERO                 !ELSE OPT MEMORY
!
      MAXNV=1
!
! EX-COMMON/QTG/
      ALLOCATE(JTGD(0:IAXCT),QTGS(IAXCT),QTGL(IAXCT),QTGD(IAXCT),       &
     &         NFI(IAXCT),NFK(IAXCT),NFQ(IAXCT),NTG(0:KMAX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB1: ALLOCATION FAILS FOR  JTGD,QTGX,NFX'
        NF=0
        GO TO 400
      ENDIF
!
! EX-COMMON/NRBAL1/
      ALLOCATE(MSTAT(KMAX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB1: ALLOCATION FAILS FOR MSTAT'
        NF=0
        GO TO 400
      ENDIF
!
! EX-COMMON/NRBGCF/
      ALLOCATE(KGCF(0:KMAX),NKSL(KSLX,KMAX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB1: ALLOCATION FAILS FOR KGCF,NKSL'
        NF=0
        GO TO 400
      ENDIF
!
! EX-COMMON/NRBKUT/
      IF(KCUT.GT.0)THEN
        ALLOCATE(LSKUT(IAXCT),STAT=IERR)        !AS DON'T KNOW IAXLS YET
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB1: ALLOCATION FAILS FOR LSKUT'
          NF=0
          GO TO 400
        ENDIF
      ENDIF
!
! EX-COMMON/NRBKUTP/
      IF(KCUTP0.GT.0)THEN
        ALLOCATE(LSKUTP(IAXCT),STAT=IERR)       !AS DON'T KNOW IAXLS YET
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB1: ALLOCATION FAILS FOR LSKUTP'
          NF=0
          GO TO 400
        ENDIF
      ENDIF
!
! EX-COMMON/NRBPNT/
      ALLOCATE(NTGP(IAXCT),NTGS(IAXCT),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB1: ALLOCATION FAILS FOR NTGP,NTGS'
        NF=0
        GO TO 400
      ENDIF
!
! EX-COMMON/NRBVCX/ (NOW IN MODULE EX-COMMON/DBD2) ONLY IN ALGEB1 BRANCH
      ALLOCATE(QCGS(NF))                                        !SMALL
!
! LOCAL
      ALLOCATE(LL(NF),KSUB(0:MXORB),KMAP(MXORB),IWT(MXORB))
!
      IF(KCUT*KCUT.LT.KCUT*KMAX)THEN
        IF(MODD.EQ.0)THEN
          MODD=-1
          WRITE(MW6,10190)
        ENDIF
      ENDIF
!
      IF(KUTDSK.LT.10000)THEN       !MAY SWITCH, THEN CHECK PRELOAD TEST
        KFBUFF=KUTDSK                !BUFFER BY CF, SMALL MEM BUT SLOWER
      ELSE
        WRITE(MW0,*)"***ATTENTION, SR.ALGEB1: KUTDSK.GE.10000 BUFFERS", &
     &       " ALL CF'S IN GROUPS, THEN RESETS KUTDSK=MOD(KUTDSK,10000)"
        WRITE(MW6,*)"***ATTENTION, SR.ALGEB1: KUTDSK.GE.10000 BUFFERS", &
     &       " ALL CF'S IN GROUPS, THEN RESETS KUTDSK=MOD(KUTDSK,10000)"
        KFBUFF=KMAX          !BUFFER ALL CF'S IN GROUP(S), IF MEM ALLOWS
        KUTDSK=KUTDSK-10000
      ENDIF
!
      BPRINT=MPRINT.GE.0.OR.                                            &
     &       (MPRINT.LE.-1.and.IDW.EQ.0.and.qn(mxorb).lt.80)
      BLP2=MPRINT.GE.2
      BLP1=MPRINT.GE.1
!      BLP0=MPRINT.EQ.0
      BLF=.FALSE.
!
! NOW COMPUTE IN SR.VCU/VCG SLATERSTATES (SLST) OF CONFIGURATIONS
! KF=1..KMAX, RESULTING TERMS SL  AND VECTOR COUPLING COEFFICIENTS (VCC)
! WHICH MAY ALSO BE STORED ON DISKDC;
! INPUT  NEL(K,KF)
!
      MTGD=0
      JB=1
      QBMS(JB)=0                !LEGACY, NOT CURRENTLY USED
      QBML(JB)=0                !LEGACY, NOT CURRENTLY USED
      NTG(0)=0
      JTGD(0)=0
      KGCF(0)=0
!
      NASTKP=0                  !INIT. PARENT SYMMETRY SELECTION
      NASTK=0                   !INIT. SYMMETRY SELECTION
      QCSX=0                    !INITIALIZE GLOBAL MAX S
      QCLX=0                    !INITIALIZE GLOBAL MAX L
!
      MOD0=MODD                 !HOLD ORIGINAL INFO
      KCUT0=KCUT
      KCUTP00=KCUTP
      NAST0=NAST
      NASTP0=NASTP
      NASTJ0=NASTJ
      ITANL0=ITANAL
      idw0=idw
!
!      ttvcu=0.
!      ttvcg=0.
!
! LOOP OVER CFS
!
      DO KF=1,KMAX
!
        IF(KF.EQ.KCUT+1.AND.KCUT.NE.0)WRITE(MW6,10170)
        IF(KF.EQ.MAX(IZERO,KUTLS)+1)WRITE(MW6,10180)
!
        IF(ITANL0.NE.0)REWIND(MRW31)
        ITANAL=-ABS(ITANL0)
        BANAL(KF)=.FALSE.
        BDISK=KF.GT.KUTDSK                            !USE DISKDC
        BKMAP=NASTP0.EQ.0.AND.KCUTP00.EQ.0.AND.BDISK.AND..NOT.BLP1
                                                      !ARB CUP ORD
!*********                      !temp, since need to map new s.s. order
        bkmap=.false.           !as matching kf-kg interact pairs uses
!*********                      !the cf order defined by qcg
        KGCF(KF)=0
!
        NE1=0        !WILL ONLY APPLY KCUTP IF OUTER SS HAS 1 OR 2 ELECS
        BNGE80=.FALSE.
        KSUB0=MXORB
        DO K=MXORB,1,-1         !NL-SUBSHELL RESOLUTION
          N=NEL(K,KF)
          IF(N.GT.0)THEN
            IF(NE1.EQ.0)NE1=N                    !AS QCG NOT YET DEFINED
            IF(.NOT.BNGE80)BNGE80=QN(K).GE.80            !RYD OR CONT CF
            KSUB(KSUB0)=K
            KSUB0=KSUB0-1
            IF(MXORB-KSUB0.EQ.KSUBCF+1)GO TO 50      !NO MORE RESOLUTION
          ENDIF
        ENDDO
!
   50   CONTINUE
!                               !APPLY KCUT/KCUTP TO PARENTS
        BPARNT=.FALSE.
        IF(BNGE80)THEN          !THEN TO PARENT RYD/CONT CF, USES KCUT
          BPARNT=.TRUE.
          KCUTP0=KCUT0
!test          kcut=0
!*********
          bkmap=.false.         !temp, since need to map new pos for nf
!*********
        ELSEIF(NE1.LE.2)THEN    !APPLY KCUTP TO REMAINING PARENT TERMS
          BPARNT=.TRUE.         !.FALSE. FORCES OFF FOR NON-RYD BOUND
          KCUTP0=KCUTP00        !ONLY APPLY IF KCUTP SET
        ENDIF
!
        KSUB(KSUB0)=0
        K0=-1
        DO K=KSUB0,MXORB
          K0=K0+1
          KSUB(K0)=KSUB(K)
!          write(mw0,*)kf,k0,ksub(k0)
        ENDDO
        KSUB0=K0
!
        IF(BKMAP)THEN
          DO KS=1,KSUB0
            IWT0=1
            KSI=KSUB(KS-1)+1    !KSI,KSF DEFINES SUBSHELL RANGE
            KSF=KSUB(KS)
            DO K=KSI,KSF
              NRJ=NEL(K,KF)
              LRJ=2*QL(K)+2
              IF(NRJ.GT.0)IWT0=IWT0*QBINOM(LRJ,NRJ)
            ENDDO
            DO KSI=1,KS-1
              IF(IWT0.LT.IWT(KMAP(KSI)))THEN
                DO KSF=KS-1,KSI,-1
                  KMAP(KSF+1)=KMAP(KSF)
                ENDDO
                GO TO 60
              ENDIF
            ENDDO
            KSI=KS
   60       IWT(KS)=IWT0
            KMAP(KSI)=KS
          ENDDO
!          do ks=1,ksub0
!            write(mw0,*)ks,kmap(ks),iwt(kmap(ks))
!          enddo
        ELSE
          DO KS=1,KSUB0
            KMAP(KS)=KS
          ENDDO
        ENDIF
!
        IF(IDW.NE.0)MODD=0
        IF(KSUB0.GT.1)THEN      !NEED ALL M_X AND MUST NOT SELECT YET
          MODD=0
          KCUT=0
          NAST=0
          NASTJ=0
          idw=0
        ENDIF
!
        IF(BPARNT.AND.KSUB0.EQ.2)THEN
          KCUTP=KCUTP0          !MUST SELECT PARENT IN VCU, VCG TOO LATE
          NASTP=NASTP0
          IF(BNGE80)ITANAL=ABS(ITANAL)               !VCU NOT YET CODED
        ELSE
          KCUTP=0               !MAYBE SELECT PARENT IN VCG
          NASTP=0
        ENDIF
!
        NF=0
        QCP(KF)=0               !INITIALIZE FOR PARITY
        NTGA=NTG(KF-1)
        MSST=2                  !INIT. NO. OF SS USED BY VCU FOR KF ONLY
        LABT='PARENTS'
        IAXDF1=0                !LOCAL COUNTER FOR THE CF
!
! LOOP OVER SUBCONFIGURATIONS
!
!        tvcg=0.
!        tvcu=0.
!
        DO KS0=1,KSUB0
!
          KS=KMAP(KS0)
          KSI=KSUB(KS-1)+1      !KSI,KSF DEFINES SUBSHELL RANGE FOR VCU
          KSF=KSUB(KS)
          JBS=JB
!
!          call nrb_time(timei)
!
          CALL VCU(QLML,QLMS,QBML,QBMS,IAXST,MAXEL)
!
          IF(NFS.LE.0)GO TO 400
          IF(NB.LT.0)GO TO 100  !DIMENSION FAILURE, BAIL OUT
!
          IAXDF1=MAX(IAXDF1,IAXDF)                           !MAX FOR CF
!
!          call nrb_time(timef)
!          tvcu=tvcu+timef-timei
!          write(71,*)'vcu',timef-timei
!          call flush(71)
!
!
          IF(KS0.EQ.KSUB0)THEN  !NOW RESTRICT M_X AND SELECT
            idw=idw0
            JSP1=0
            IF(IDW.EQ.0)THEN
              MODD=MOD0
            ELSE
              IF(ABS(MOD0).LE.1)JSP1=1
            ENDIF
            KCUT=KCUT0
            NAST=NAST0
            NASTJ=NASTJ0
            IAXST=-IAXST                                    !FLAG BFINAL
            IF(.NOT.BNGE80)ITANAL=ABS(ITANAL)
          ENDIF
          IF(BPARNT.AND.KS0.EQ.KSUB0-1)THEN                 !KS=KS0 HERE
            KCUTP=KCUTP0
            NASTP=NASTP0
            IF(BNGE80)ITANAL=ABS(ITANAL)
          ENDIF
!
!          call nrb_time(timei)
!
!
          CALL VCG(QLML,QLMS,QBML,QBMS,IAXST,MAXEL)
!
          IF(NF.LE.0)GO TO 400
!
!          call nrb_time(timef)
!          tvcg=tvcg+timef-timei
!          write(71,*)'vcg',timef-timei
!          call flush(71)
!
          KCUTP=0
          NASTP=0
!
          IF(BLP2.AND.NB.EQ.0)THEN                        !WRITE PARENTS
            NFW=NF-NFS
            WRITE(MW6,10060)KF,NB,                                      &
     &                      (QN(QCG(I,KF)),QL(QCG(I,KF))/2,I=1,NFW)
            WRITE(MW6,10030)NTP1,LABT,                                  &
     &                      (NFI(I)+1,NFK(I)/2,NFQ(I),I=1,NTP1)
            WRITE(MW6,10050)KS,NB,(QN(QCGS(I)),QL(QCGS(I))/2,I=1,NFS)
            I1=NTP2-NTP1
            I2=NTP1+1
            WRITE(MW6,10030)I1,LABT,(NFI(I)+1,NFK(I)/2,NFQ(I),I=I2,NTP2)
            IF(KS0.GT.1)THEN                                !KS=KS0 HERE
              NT=NTG(KF-1)
              M=NTG(KF)
              NK=M-NT                        !NO. OF TERMS SELECTED
              I=NT
              DO N=1,NK
                I=I+1
                J=NTGP(I)-NT
                L=NTGS(I)-NT
                WRITE(MW6,10110)I,N,QTGS(I)+1,QTGL(I)/2,QTGD(I),J,NFI(J)&
     &                          +1,NFK(J)/2,NFQ(J),L-NTP1,NFI(L)+1,     &
     &                          NFK(L)/2,NFQ(L)
              ENDDO
            ENDIF
          ENDIF
!
          BLT=NB.GT.0           !ACCURACY FAILURE (DIMENSION IF NB.LT.0)
          IF(NB.NE.0)GO TO 100  !BAIL OUT OF SUBCONFIGURATION LOOP
!
        ENDDO                   !END LOOP OVER SUBCONFIGURATIONS
!                               --------------------------------
        KGCF(KF)=KGCF(KF)+KGCF(KF-1)
!
!        write(71,*)'cf=',kf,' vcu time=',tvcu
!        write(71,*)'cf=',kf,' vcg time=',tvcg
!        ttvcu=ttvcu+tvcu
!        ttvcg=ttvcg+tvcg
!        call flush(71)
!
! UPDATE GLOBAL MAX S,L (MAY HAVE BEEN INPUT VIA QCS0,QCL0 IN /MQVC/)
!
        QCSX=MAX(QCSX,QCS0)
        QCLX=MAX(QCLX,QCL0)
!
! WRITE-OUT DETAILS, TERM INFO ETC
!
  100   MODD=MOD0                                    !CASE IDW.GT.0
        NASTP=NASTP0
        ITANAL=ITANL0
!
        DO I=1,NF
          K=QCG(I,KF)
          IF(QN(K).LT.80.AND.QN(K).GT.MAXNV.AND.KCUT*KCUT.GE.KCUT*KF)   &
     &       MAXNV=MOD(INT(QN(K),SP),I70)                          !I60?
          QLMS(I,1)=QN(K)
          LL(I)=QL(K)/2
          QLML(I,1)=QL(K)
        ENDDO
!
! NB.LT.0: STORAGE EXCEEDED;  NB.GT.0: ACCURACY OR PHASE FAILURE
! NB=0: SLATER STATES AND VCC PROPERLY COMPUTED BY VCU/VCE
!
!!  WRITE(MW6,30)KF,NB,(QN(QCG(I,KF)),QL(QCG(I,KF))/2,I=1,NF)
!
        M8=INT(NB,EP)
        IF(BDISK.AND.M8.EQ.0)M8=MDCF8
        WRITE(MW6,10060)KF,M8,(QLMS(I,1),LL(I),I=1,NF)
!
!        ND=NTGB-NTGA
!        IF(ND.EQ.0)GO TO 99
!
        MSTAT(KF)=MSST-1                          !FOR CONFIG KF HERE
!        write(mw0,*)msst-1
        MSST=JA-1+MSST-1                          !NOW GLOBAL
!
        NT=NTG(KF-1)
        M=NTG(KF)
        NK=M-NT                                   !NO. OF TERMS SELECTED
        IF(NK.EQ.0)GO TO 150                               !.AND.NB.EQ.0
!        ND=NK
        K=NT+1
!                       ,MSST
        WRITE(MW6,10020)JA,JB,IAXST,MTGD,IAXDC,IAXDF1,MODD
!
        IF(BLP1.AND.KSUB0.GT.1)THEN             !WRITE FINAL PARENTS
          LABT='FINAL  '
          WRITE(MW6,10030)NTP1,LABT,(NFI(I)+1,NFK(I)/2,NFQ(I),I=1,NTP1)
          LABT='PARENTS'
          I1=NTP2-NTP1
          I2=NTP1+1
          WRITE(MW6,10030)I1,LABT,(NFI(I)+1,NFK(I)/2,NFQ(I),I=I2,NTP2)
          I=NT
          DO N=1,NK
            I=I+1
            J=NTGP(I)-NT
            L=NTGS(I)-NT
            WRITE(MW6,10110)I,N,QTGS(I)+1,QTGL(I)/2,QTGD(I),J,NFI(J)+1, &
     &                      NFK(J)/2,NFQ(J),L-NTP1,NFI(L)+1,NFK(L)/2,   &
     &                      NFQ(L)
          ENDDO
        ENDIF
!
        LABT='TERMS  '
        IF(BPRINT)THEN
          WRITE(MW6,10030)NK,LABT,(QTGS(I)+1,QTGL(I)/2,QTGD(I),I=K,M)
                                                                   !ND
        ELSE
          WRITE(MW6,10030)NK,LABT                                  !ND
        ENDIF
!
        IF(NB.LT.0)GO TO 200
        IF(.NOT.BLP2)GO TO 150
!
        WRITE(MW6,10080)KF,(QLMS(I,1),QLML(I,1),I=1,NF)
        WRITE(MW6,10100)JB,NB,IAXST
!
        DO J=JA,JB
          L=QBMS(J)+QBML(J)
          WRITE(MW6,10090)J,QBML(J),QBMS(J),L,                          &
     &                    (QLML(I,J),QLMS(I,J),I=1,NF)
        ENDDO
!
        WRITE(MW6,10160)NK,(QTGS(I),QTGL(I),QTGD(I),I=K,M)          !ND
!
        IF(.NOT.BLT.AND..NOT.BDISK)THEN
!
!          N=NTG(KF)
          ALLOCATE(DS(I100))
!
          DO J=JA,JB
            L1=1+(NK-1)/I100
            I1=0
            DO L=1,L1
              I0=I1+1
              I1=MIN(NK,L*I100)
              N=0
              DO I=I0,I1
                N=N+1
                IF(BFAST)THEN
                  K=J+JTGD(I+NT)                 !relative start flagged
                  DS(N)=DC(K)
                ELSE
                  K1=JTGD(I-1+NT)+1                !absolute end flagged
                  K2=JTGD(I+NT)
                  DO K=K1,K2                            !FOR SMALL CASES
                    IF(IDC(K).EQ.J)THEN
                      DS(N)=DC(K)
                      GO TO 102
                    ENDIF
                  ENDDO
                  DS(N)=DZERO
  102             CONTINUE
                ENDIF
              ENDDO
              WRITE(MW6,10070)J,(DS(I),I=1,N)
            ENDDO
          ENDDO
          WRITE(MW6,10160)
!
          DEALLOCATE(DS)
!
        ENDIF
!
  150   JYI(KF)=JA
        JYF(KF)=JB
!
        IF(BLT)THEN
          BLF=.TRUE.
          IF(NB.LE.IAXDF)THEN
            WRITE(MW6,10140)
          ELSE
            WRITE(MW6,10150)
          ENDIF
        ENDIF
!
      ENDDO                      !END LOOP OVER CONFIGURATIONS
!                                -----------------------------
!
      NTT=NTG(KMAX)                       !TOTAL NO. OF TERMS
!
! REPLACE GLOBAL MAX S,L
!
      QCS0=QCSX
      QCL0=QCLX
!
!-----------------------------------------------------------------------
!
! RE-ALLOCATE IAXCT->NTT TO REMOVE BUFFER FROM
! JTGD,QTGS,QTGL,QTGD,NFI,NFK,NFQ (N.B. NTGP,NTGS NOT USED FURTHER)
! BUT IF BUFFER IS SMALL (ABSOLUTE OR RELATIVE, AS IT LIKELY IS)
! THEN IS IT WORTH THE OVERHEAD?
!
! N.B., ORIGINAL TERM COUNT (IAXTM) SWITCHED-OFF KCUT/P,NAST/P
! SO ACTUAL NTT.LE.IAXTM, MAYBE SUBSTATNTIALLY. RECALL, IAXTM WAS
! NOT USED FOR ALLOCATION, ONLY IAXCT WHICH WAS PER CONFIGURATION.
!
      IAXTM=NTT
      T=IAXCT
      T=T/(IAXTM+1)
      IF(T.GT.D3HALF.AND.IAXCT.GT.10000)THEN
!        write(mw0,*)'decreasing iaxct:',iaxct,iaxtm !run silently
        CALL RE_ALLOC(JTGD,IZERO,IAXCT,NTT,IERR1)
        CALL RE_ALLOC(QTGS,IONE,IAXCT,NTT,IERR2)
        CALL RE_ALLOC(QTGL,IONE,IAXCT,NTT,IERR3)
        CALL RE_ALLOC(QTGD,IONE,IAXCT,NTT,IERR4)
        CALL RE_ALLOC(NFI,IONE,IAXCT,NTT,IERR5)
        CALL RE_ALLOC(NFK,IONE,IAXCT,NTT+1,IERR6) !+1 for poss. bundling
        CALL RE_ALLOC(NFQ,IONE,IAXCT,NTT,IERR7)
        IF(ABS(IERR1)+ABS(IERR2)+ABS(IERR3)+ABS(IERR4)+ABS(IERR5)       &
     &     +ABS(IERR6)+ABS(IERR7).NE.0)THEN
          WRITE(MW0,*)'ALGEB1: RE-ALLOCATION FAILS FOR  JTGD,QTGX,NFX'
          NF=0
          GO TO 400
        ENDIF
        IAXCT=IAXTM
      ENDIF
!
!-----------------------------------------------------------------------
!
      IF(BDISK)THEN
!
        MDCFT8=MDCFT8+MDCF8               !pick-up final config
        IF(KUTDSK.LT.KFBUFF)THEN
!
          MDCBUF=IAXDC                    !SINCE UNKNOWN AHEAD OF TIME
          IF(MDCFT8.LE.IAXDC)THEN
            M=INT(MDCFT8,SP)
            MDCBUF=MIN(MDCBUF,MTGD+M)     !FOR ANY SUBSEQUENT ALLOCATE
          ENDIF
!
        ELSE
!
          MDCBUF=MDCBUF+MDCBUF+MTGD       !SINCE NEED TO HOLD TWO SLICES
          IF(mdcbuf.le.0)THEN             !.le.0 -> I*4 overflow
            WRITE(MW0,*)'*** SR.ALGEB1: TOO MANY VCCs FOR I*4'
            WRITE(MW6,*)'*** SR.ALGEB1: TOO MANY VCCs FOR I*4',         &
     &                  ', SET DEFAULT INTEGER SP=8 IN MODULE PRECSN'
            NF=-1
            GO TO 400
          ENDIF
!
          IF(MDCBUF.GT.IAXDC)THEN
!
            IXXX=MDCBUF
!
            WRITE(MW6,*)'*** ALGEB1: increasing MAXDC from ',IAXDC,     &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** ALGEB1: increasing MAXDC from ',IAXDC,     &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC(DC,IZERO,MTGD,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'ALGEB1: RE-ALLOCATION FAILS FOR DC'
              NF=0
              GO TO 400
            ENDIF
!
            IF(DC(0).GT.DZERO)THEN
!
              CALL RE_ALLOC(IDC,IONE,MTGD,IXXX,IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)'ALGEB1: RE-ALLOCATION FAILS FOR IDC'
                NF=0
                GO TO 400
              ENDIF
!
            ENDIF
!
            IAXDC=IXXX
!            MDCBUF=IAXDC
!
          ENDIF
!
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      MTGDMX=0
      CALL DIMUSE('MAXDC',MTGDMX)
      JBMX=0
      CALL DIMUSE('MXST0',JBMX)
!        write(mw6,*)'algeb1: jbmx=',jbmx
      MXCTM=0
      CALL DIMUSE('MAXCT',MXCTM)
      WRITE(MW6,10010)MXCTM,IAXCT,JBMX,IAXST,MTGDMX,IAXDC
      IF(BDISK)WRITE(MW6,10040)MDCFT8
!
      IM=NF*JBMX
!
      CALL DIMUSE('MXEST',IM)
!
!      write(71,*)'total vcu time=',ttvcu
!      write(71,*)'total vcg time=',ttvcg
!      call flush(71)
!      if(tvcg.gt.0)stop 'test algeb1'
!
      IF(NTT.EQ.0)GO TO 300
      IF(BLF)GO TO 300
!
      GO TO 400
!
  200 WRITE(MW6,10120)
  300 IF(NF.GT.0)NF=-1
  400 CONTINUE
      IF(NF.EQ.0)THEN
        WRITE(MW6,10130)
        WRITE(MW0,*)'***SR.ALGEB1: STORAGE EXCEEDED ***'
      ENDIF
!
!-----------------------------------------------------------------------
!
! LOCAL
      IF(ALLOCATED(LL))DEALLOCATE(LL,KSUB,KMAP,IWT)
!
! EX-COMMON/NRBKUT/                                ONLY IN ALGEB1 BRANCH
      IF(ALLOCATED(LSKUT))DEALLOCATE(LSKUT)
!
! EX-COMMON/NRBKUTP/                               ONLY IN ALGEB1 BRANCH
      IF(ALLOCATED(LSKUTP))DEALLOCATE(LSKUTP)
!
! EX-COMMON/NRBPNT/                                ONLY IN ALGEB1 BRANCH
      IF(ALLOCATED(NTGP))DEALLOCATE(NTGP,NTGS)
!
! EX-COMMON/NRBVCX/ (NOW IN MODULE EX-COMMON/DBD2) ONLY IN ALGEB1 BRANCH
      IF(ALLOCATED(QCGS))DEALLOCATE(QCGS)
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(//I8,'=BUFFER',3X,'MAXCT=',I8,';',4X,I10,'=JBF MXST0=',I10,&
     &       ';',17X,I10,'=MTGD, MAXDC=',I10,' BUFFER STORAGE USED')
10020 FORMAT(' SLATER-STATES STORED IN',I10,'=JA',I10,'=JB, MAXST=',I10,&
     &       '; VCC STORED UP TO',I10,'=MTGD, MAXDC=',I10,'; MAXDF=',I4,&
     &       '; MOD=',I2)
10030 FORMAT(I8,' SPECTROSCOPIC ',A7,' (2S+1 L DP):',9(2X,I3,I3,I3)     &
     &       /(43X,9(2X,I3,I3,I2)))
10040 FORMAT(/47X,"TOTAL NUMBER OF VCC'S STORED ON DISK:",I12/)
10050 FORMAT(//' SUBCONFIGURATION=',I4,',',I4,' ON DISK, (N-L)-',       &
     &       'COMBINATIONS  ',12(I4,I3))
10060 FORMAT(//' CONFIGURATION CF=',I4,',',I11,' ON DISK, (N-L)-',      &
     &       'COMBINATIONS  ',12(I4,I3)/64X,12(I4,I3))
10070 FORMAT(I4,16F8.4/(4X,16F8.4))
10080 FORMAT(/I4,'=CF 2ML 2MS 2MJ',1X,(14(I5,I3)))
10090 FORMAT(I6,I5,I4,I4,1X,(14(I5,I3)))
10100 FORMAT(I6,I6,I8)
10110 FORMAT(I5,I5,I4,I2,I3,2X,':',1X,I4,I4,I2,I3,2X,I4,I4,I2,I3)
10120 FORMAT(//" SR.ALGEB1: STORAGE EXCEEDED IN VCU - OR VCG - CALL"//  &
     &"'DISK'=-3 IF TOO MANY SLATER STATES ((JB').GT.MAXST), -2 IF TOO "&
     &,"MANY TERMS (SUM(ND).GT.MAXCT), -1 IF TOO MANY VCC ",            &
     &"(MTGD.GT.MAXDC)"//"  AUGMENT MXST0 (IN CASE -3),  AUGMENT  ",    &
     &"MAXTM (IN CASE -2),  AUGMENT  MAXDC (IN CASE -1)")
10130 FORMAT(//' **** SR.ALGEB1: STORAGE EXCEEDED - UNABLE TO ALLOCATE',&
     &       ' ANY MORE MEMORY - REDUCE SIZE OF PROBLEM ****'//)
10140 FORMAT(//' SR.ALGEB1: SR VCU HAS FAILED -IN PHASES OR ACCURACY'//)
10150 FORMAT(" SR.ALGEB1: WORKING ARRAYS D2,DU,DV,DS,DE,NDI TOO SMALL", &
     &       " ('DISK'.GT. MAXDF)")
10160 FORMAT(/I4,16(I3,I2,I3)/(4X,16(I3,I2,I3)))
10170 FORMAT(//" ATTENTION: THE FOLLOWING CF'S ARE MERE CORRELATION",   &
     &       " CONFIGURATIONS")
10180 FORMAT(//" ATTENTION: THE FOLLOWING CF'S ARE RESTRICTED TO",      &
     &       " CI-MIXING WITHIN EACH CONFIGURATION ONLY!")
10190 FORMAT(//' MOD=0 RESET TO -1, BECAUSE SR.VCU DOES NOT LIKE',      &
     &       ' CORRELATION CONFIGURATIONS IN THAT MODE.')
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE ALGEB1
!
!                             *******************
!
      SUBROUTINE ALGEB2(MAM,NAM,QLML,QLMS,QBML,QBMS,JYI,JYF,MAXEL)
!
!-----------------------------------------------------------------------
!
!  SR.ALGEB2 DEALS WITH THE PROBLEMS DESCRIBED IN SECTION 3.2 OF E&N:
!  IT CALCULATES THE PURELY ALGEBRAIC COEFFICIENTS FOR EACH NONVAN-
!  ISHING ENERGY MATRIX ELEMENT, ASSUMING ELECTROSTATIC INTERACTION;
!  ALSO, REDUCED ELECTRIC MULTIPOLE MATRIX ELEMENTS ARE COMPUTED.
!
!  IT IS CALLED BY:
!    SR.ALGEB
!
!  IT CALLS:
!    SR.DIMUSE
!    SR.DISKDC
!    SR.EKALG1
!    SR.EKALG2
!    SR.FLGL1
!    SR.FLGL2
!    SR.NRB_TIME
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!    FN.VCC
!
!  IT CONTAINS:
!    FN.MVC
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam                            !par
!
      USE COMMON_ALGEB,  ONLY: MPRINT
      USE COMMON_ALGEB,  ONLY: MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD     &
     &                        ,KFBUFF
      USE COMMON_ALGEB,  ONLY: BFOT
!!      COMMON /BASIC/NF,KF,KG,NC,ND,MB1,MB2,ND1,NDP1,ND2,NDP2,NGAP
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,NC=>IBSK4,ND=>IBSK5            &
     &              ,MB1=>IBSK6,MB2=>IBSK7,ND1=>IBSK8,NDP1=>IBSK9       &
     &              ,ND2=>IBSK10,NDP2=>IBSK11,IBSK12=>IBSK12
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_CFCT,   ONLY: VCA,VCB,MXLL,MAXLL0,MAXLL1,BVC,BDLBD
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DC,     ONLY: BFAST,DC,IDC,IXIDC
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL,NAD,N8,IWORD             &
     &                        ,MAXRK0,MAXRL0
      USE COMMON_DXRL,   ONLY: IRK,IRK0,IOS,IOS0
      USE COMMON_DXRLS,  ONLY: DRKS,DEKS,QRLS,NRKS,BFALLS               &
     &                        ,MXRKS0,MXRLS0
      USE COMMON_DXRLS,  ONLY: IRKS,IRKS0,IRLS,IRLS0
      USE COMMON_JSPOR,  ONLY: JAXLV
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_NSTS,   ONLY: NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT
      USE COMMON_QTG,    ONLY: MTGD,NXLL,NTT,NTG,JTGD,QTGS,QTGL,QTGD    &
     &                        ,NFI,NFK,NFQ,JAXTM
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      use common_misc,   only: iw,iwp,btime,btimex
!
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL2, ONLY: MDEL,MXORBR,MPOL00,MPOL0,MPOLE,MPOLX,CODE
      USE COMMON_NRBAL2, ONLY: MAXLAM0,MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBAL3, ONLY: MCFSS,KCFSS,KUTSS,KUTSO,QQCUT
      USE COMMON_NRBAL4, ONLY: MBP1MX,MBP2MX,MEKVMX,KUTM1,MPOLM,QCUT
      USE COMMON_NRBDW,  ONLY: IDW,btop
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG0,NMETAG,NMETGJ
      USE COMMON_NRBEKP, ONLY: NED
      USE COMMON_NRBGCF, ONLY: KGSL,KGCF,NKSL
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBIAD, ONLY: IADD
      USE COMMON_NRBKUT, ONLY: KCUTX,LSKUT,NASTK
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,NAST                          &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBLSP, ONLY: LSPIP,NLSPIP,NASTP                       &
     &                        ,MINSTP,MAXSTP,MINLTP,MAXLTP
      USE COMMON_NRBLSS, ONLY: NESSH,NASTS,MINSTS,MAXSTS,MINLTS,MAXLTS
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBRN2, ONLY: BINDB,MENGB
      USE COMMON_NRBVAL, ONLY: BRAD,BAUGER
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,IBUFF4
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (MXD20=100)                 !MAX EK-POLE (JUST FLAG NOW)
!
      PARAMETER (MG=-2)
!
      CHARACTER(LEN=4) MBLANK,MYRGE
!
      LOGICAL BEX,BEXJ                    !INQUIRE REQUIRES DEFAULT KIND
!
      DIMENSION MAM(*),NAM(*),JYI(*),JYF(*)                             &
     &         ,QLML(MAXEL,*),QBML(*),QLMS(MAXEL,*),QBMS(*)
!
      ALLOCATABLE :: BAM(:),BBM(:),B1B(:),B2B(:),KSTART(:,:)
      ALLOCATABLE :: JMG(:),DVC(:)
      allocatable :: ncc0(:),iorb(:)
!
      DATA MBLANK/'    '/
!
!-----------------------------------------------------------------------
!
! PACK CORE M_S AND M_L INTO M_L
!
      DO I=1,NW
        NNL(I,2)=(NNL(I,3)+1)/2+NNL(I,2)
      ENDDO
!
! PACK QLMS AND QLML INTO ONE ARRAY
!
      DO J=JYI(1),JYF(KMAX)
        DO I=1,NF
          QLML(I,J)=(QLMS(I,J)+QONE)/QTWO+QLML(I,J)
        ENDDO
      ENDDO
!
!-----------------------------------------------------------------------
!
! INITIALIZATIONS
!
!-----------------------------------------------------------------------
!
      BPRINT=MPRINT.GT.0.OR.MPRINT.EQ.0.AND.IDW.EQ.0
!
      BKUTLS=KUTLS.LT.0                          !.T. FOR SINGLE CF MIX
      KUTLS=MIN(KUTLS,KMAX)
!
      BAMBM=.FALSE.
!
      BFAST=DC(0).LT.DZERO                 !ELSE OPT MEMORY
!
      MOD2=MODD                  !CAN RE-SET TO TEST VARIOUS TOTAL ML,MS
!      mod2=1                     !MODD.LE.0 NOW
      BMOD2=(MOD2+1)/2.EQ.1      !SLOWER
!
      BKUTOO=KUTOO.NE.0
      BDLBD=ABS(MODD).LT.2.AND.KUTSS.NE.-1.OR.BKUTOO
!
! CAN MAKE BIG CASES MORE EFFICIENT IF WE NO LONGER ALLOW THIS - NRB
!
      IF(MPRINT.NE.MG.AND.MODD.GT.0)THEN
        WRITE(MW6,*)'***MOD.GT.0 WILL NO LONGER COMPUTE RADIATION'
        WRITE(MW6,*)'***SET MOD.LE.0 OR SWITCH-OFF RADIATION'
        WRITE(MW0,*)'***MOD.GT.0 WILL NO LONGER COMPUTE RADIATION'
        GO TO 2400
      ENDIF
!
! NEED MAX ORBITRAL L FOR VCC STORAGE AND BORN.
!
      MXLL=-1
      DO K=1,MXORB
        IF(DEY(K).NE.DZERO.AND.QL(K).GT.MXLL)MXLL=QL(K)
      ENDDO
!
      IF(MENGB.GE.0)THEN                  !CAN NOW RESTRICT MPOLE (BORN)
        MPOLE=MIN(MPOLE,2*MXLL)
        IF(MPOLM.GE.198)THEN                                    !DEFAULT
          MPOLM=MIN(ITEN,MPOLE-2)                        !FOR LARGE MXLL
        ELSE
          MPOLM=MIN(MPOLM,MPOLE+2)           !DON'T ALLOW USER TO GO MAD
          MPOLE=MAX(MPOLE,MPOLM+2)  !FIX FOR USER M_K WITH NO E_K+1 PAIR
!          MPOLM=MPOLE-2                     !ALLOW USER TO RESTRICT M_K
        ENDIF
      ELSE
        IF(MPOLM.GT.MPOLE-2)THEN
          MPOLE=MPOLM+2
          WRITE(MW0,*)'*** NOTE; INCREASING KPOLE TO',MPOLE/2,          &
     &                'BECAUSE YOUR INPUT KPOLM=',MPOLM/2
          WRITE(MW6,*)'*** NOTE; INCREASING KPOLE TO',MPOLE/2,          &
     &                'BECAUSE YOUR INPUT KPOLM=',MPOLM/2
        ENDIF
      ENDIF
!
! FOR MPRINT.GE.0 MPOLE HAS ALREADY BEEN SET (DEFAULT=4)
!
      IF(MPRINT.EQ.-1.OR.MPRINT.EQ.-4)MPOLE=2
      IF(MPRINT.EQ.MG)MPOLE=-1                                 !FOR INFO
      IF(MPOLE.GT.2*MXBLM)THEN
        IF(MXBLM.GT.0)THEN
          WRITE(MW6,10390)MPOLE/2,MXBLM
!          WRITE(MW0,955)MPOLE/2,MXBLM
        ENDIF
!        IXBLM=MPOLE/2               !NOT NEEDED UNTIL MINIM
      ENDIF
!
      IM=MAX(IONE,MPOLE/2)
!
      CALL DIMUSE('MXBLM',IM)
!
      MPOLX=MPOLE
      IF(MPOLX/2.GT.MXD20)THEN
        WRITE(MW6,*)                                                    &
     &            '*** ALGEB2: DO YOU REALLY NEED ALL THESE MULTIPOLES?'
        WRITE(MW0,*)                                                    &
     &            '*** ALGEB2: DO YOU REALLY NEED ALL THESE MULTIPOLES?'
!        WRITE(MW6,*)'*** IN NAMELIST SALGEB: reduce KPOLE from '
!     &                ,MPOLX/2,' to: ',MXD20
!        WRITE(MW0,*)'*** IN NAMELIST SALGEB: reduce KPOLE from '
!     &                ,MPOLX/2,' to: ',MXD20
!        GO TO 999
      ENDIF
!
      IF(MPOLX.GE.0)ALLOCATE(DVC(0:MPOLX/2))
!
!B      BBORN=MENGB.GE.0            !BORN CODING NOW USED MORE GENERALLY
!B      IF(BBORN)THEN
      MPOL0=MPOL00
      IF(MPOL0.GE.0)THEN            !BORN CODING NOW USED MORE GENERALLY
        MXORB2=(MXORB*(MXORB+1))/2
        LHM=MPOLE/4
        IF(BREL)LHM=LHM+1
      ELSE
        MXORB2=1
        LHM=0
      ENDIF
!
!-----------------------------------------------------------------------
!
! DETERMINE NUMBER OF SLP GROUPS (AND CHECK TERMS)
!
!-----------------------------------------------------------------------
!
      NCI=0            !T
      NSL0=0           !G
!
      QCL=QCL0         !L
!
  100 QCS=QCS0         !S
!
  200 KCP=0            !P
!
  300 NC=0             !T IN G
!
      DO K=1,KMAX                                 !LOOP OVER ALL CONFIGS
        IF(QCP(K).EQ.KCP)THEN
          NG=NTG(K-1)+1
          NT=NTG(K)
          QCSX=QTGS(NG)
          QCLX=QTGL(NG)
          K0=1
          ND0=0
!
          DO I=NG,NT
            IF(QTGL(I).NE.QCLX.OR.QTGS(I).NE.QCSX)THEN
              QCSX=QTGS(I)
              QCLX=QTGL(I)
              K0=K0+1
            ENDIF
            IF(QTGL(I).EQ.QCL.AND.QTGS(I).EQ.QCS)THEN
              NC=NC+1
              NCI=NCI+1
              ND=NSL0+1
              ND0=K0
!              if(bprint)WRITE(MW6,180)NCI,QCS+1,QCL/2,KCP/2,K,I,ND
            ELSE
              IF(QTGL(I).LT.QCL)GO TO 320                      !BAIL OUT
            ENDIF
          ENDDO
!
  320     CONTINUE
        ENDIF
      ENDDO
!
      IF(NC.GT.0)THEN
!        WRITE(MW6,197)ND,QCS+1,QCL/2,KCP/2,NC
        NSL0=ND                      !NO. SLP SYMMETRY GROUPS
      ENDIF
!
      KCP=KCP+2
      IF(KCP.LE.2)GO TO 300          !LOOP UP TO NEXT PARITY
!
      QCS=QCS-QTWO
      IF(QCS.GE.0)GO TO 200          !LOOP UP FOR NEXT SPIN
!
      QCL=QCL-QTWO
      IF(QCL.GE.0)GO TO 100          !LOOP UP FOR NEXT ORB A.M.
!
!                                    !END SLP SYMMETRY LOOPS
!
      if(nci.ne.ntt.or.nci.gt.iaxtm)then           !should not happen...
        write(mw0,*)nci,ntt,iaxtm                    !iaxtm=iaxct by now
        stop '***algeb2: mis-match in terms'
      endif
!
      IAXSL=NSL0
!
!-----------------------------------------------------------------------
!
! EX-COMMON/TERMS/
      ALLOCATE(NSL(NSL0),QSI(NSL0),QLI(NSL0),QPI(NSL0),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB2: ALLOCATION FAILS FOR NSL,QSI,QLI,QPI'
        NF=0
        RETURN
      ENDIF
!
! EX-COMMON/NRBDWM/
      ALLOCATE(NMETAG(0:NSL0),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB2: ALLOCATION FAILS FOR NMETAG'
        NF=0
        RETURN
      ENDIF
!
! EX-COMMON/NRBGRP/
      ALLOCATE(NGRPI(NSL0),NADG(NSL0),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB2: ALLOCATION FAILS FOR NGRPI,NADG'
        NF=0
        RETURN
      ENDIF
!
! EX-COMMON/NRBGCF/
      ALLOCATE(KGSL(KMAX,NSL0),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB2: ALLOCATION FAILS FOR KGSL'
        NF=0
        RETURN
      ENDIF
!
! EX-COMMON/NRBRN2/
      ALLOCATE(BINDB(MXORB2,0:LHM),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB2: ALLOCATION FAILS FOR  BINDB'
        NF=0
        RETURN
      ENDIF
!
! local, as recalculated in sr.diagon (ex-common/nrbtmp/)
      allocate(ncc0(mxorb),iorb(0:mxorb),stat=ierr)
!
      if(ierr.ne.0)then
        write(mw0,*)'algeb2: allocation fails for ncc0,iorb'
        nf=0
        return
      endif
!
!-----------------------------------------------------------------------
!
      NMETAG(0)=NMETAG0
      DO I=1,IAXSL
        NMETAG(I)=0
      ENDDO
!
      DO LH=0,LHM
        DO I=1,MXORB2
          BINDB(I,LH)=.FALSE.
        ENDDO
      ENDDO
!
      IF(NASTS.NE.0)THEN
        WRITE(MW6,10410)
        WRITE(MW6,10500)
        IF(NASTS.GT.0)THEN
          WRITE(MW6,10510)
          ISM=999
          DO I=1,NASTS
            IO=NESSH(I)/100000
            IS=NESSH(I)-IO*100000
            IQ=IS/1000
            IL=IS-IQ*1000
            IS=IL/10
            IL=IL-IS*10
            WRITE(MW6,10520)IO,IQ,IS,IL
            ISM=MIN(IS,ISM)
          ENDDO
          IF(ISM.EQ.0)WRITE(MW6,10540)MINSTS,MAXSTS,MINLTS,             &
     &                                min(99_SP,MAXLTS)
        ELSE
          WRITE(MW6,10530)
          DO I=1,-NASTS
            IO=NESSH(I)/100000
            IQ=(NESSH(I)-IO*100000)/1000
            WRITE(MW6,10520)IO,IQ
          ENDDO
          WRITE(MW6,10540)MINSTS,MAXSTS,MINLTS,min(99_SP,MAXLTS)
        ENDIF
        WRITE(MW6,10410)
      ENDIF
!
      IF(NASTP.NE.0)THEN
        WRITE(MW6,10410)
        WRITE(MW6,10460)
        IF(NASTP.GT.0)THEN
          DO IPCF=1,KMAX
            NPCF=NLSPIP(IPCF)
            IF(NPCF.GT.0)THEN
              WRITE(MW6,10480)IPCF
              WRITE(MW6,10430)
              DO I=1,NPCF
                IS=LSPIP(I,IPCF)/10000
                IP=LSPIP(I,IPCF)-IS*10000
                IL=IP/10
                IP=IP-IL*10
                WRITE(MW6,10440)I,IS,IL,IP
              ENDDO
            ENDIF
          ENDDO
        ELSE
          WRITE(MW6,10470)MINSTP,MAXSTP,MINLTP,min(99_SP,MAXLTP)
        ENDIF
        IF(NAST.EQ.0)THEN
          WRITE(MW6,10410)
        ELSE
          WRITE(MW6,*)' '
        ENDIF
      ENDIF
!
      IF(NAST.NE.0)THEN
        IF(NASTP.EQ.0)THEN
          WRITE(MW6,10410)
        ELSE
          WRITE(MW6,*)' '
        ENDIF
        WRITE(MW6,10420)
        IF(NAST.GT.0)THEN
          WRITE(MW6,10430)
          DO I=1,NAST
            IS=LSPI(I)/10000
            IP=LSPI(I)-IS*10000
            IL=IP/10
            IP=IP-IL*10
            WRITE(MW6,10440)I,IS,IL,IP
          ENDDO
        ELSE
          WRITE(MW6,10450)MINSP,MAXSP,MINLT,min(99_SP,MAXLT)
        ENDIF
        WRITE(MW6,10410)
      ENDIF
!
!-----------------------------------------------------------------------
!
! RETABULATE THE NCI=NTG(KMAX) TERMS CASL OF THE KMAX CONFIGURATIONS
! ACCORDING TO TOTAL S,L,KPC(=PARITY  0,2 FOR EVEN,ODD); ONE OBTAINS
! NSL0 BLOCKS OF LENGTH NSL(N), WITH QSI(N)=2S,QLI(N)=2L,QPI(N)=KP;
!
!-----------------------------------------------------------------------
!
      WRITE(MW6,10310)
!
      BLX=.FALSE.
      NCTOT=0
      NCI=0
      NSL0=0
      NN=0
      ISXDI=1
      IAXDI=1
      IAXUC=0
      IXAAI=0
!      lusum=0
!
      DO I=1,IAXSL
        DO K=1,KMAX
          KGSL(K,I)=0
        ENDDO
      ENDDO
!
! BEGIN SLP SYMMETRY LOOPS
!
      QCL=QCL0         !L
!
  400 QCS=QCS0         !S
!
  500 KCP=0            !P
!
  600 NC=0
      NCC=0
!
!      if(bkutls)then
      ncft0=0
      ncft=0
!      else
      do i=1,mxorb
        ncc0(i)=0
      enddo
      mx0=mxorb+1
!      endif
!
      DO K=1,KMAX                                 !LOOP OVER ALL CONFIGS
        IF(QCP(K).EQ.KCP)THEN
          II=QCG(NF,K)
          ii=ieq(ii)
          ncf=0
          NG=NTG(K-1)+1
          NT=NTG(K)
          QCSX=QTGS(NG)
          QCLX=QTGL(NG)
          K0=1
          ND0=0
!
          DO I=NG,NT
            IF(QTGL(I).NE.QCLX.OR.QTGS(I).NE.QCSX)THEN
              QCSX=QTGS(I)
              QCLX=QTGL(I)
              K0=K0+1
            ENDIF
            IF(QTGL(I).EQ.QCL.AND.QTGS(I).EQ.QCS)THEN
              ncf=ncf+1
              NCI=NCI+1
              BLP=NCI.GT.IAXTM
              IF(QN(II).GE.90)THEN
                NCC=NCC+1
                ncc0(ii)=ncc0(ii)+1
                mx0=min(mx0,ii)
              else
                NC=NC+1
              endif
              ND=NSL0+1
              ND0=K0
              if(bprint)WRITE(MW6,10110)NCI,QCS+1,QCL/2,KCP/2,K,I,ND
              IF(.NOT.BLP)THEN
                NFQ(NCI)=ND
                NFK(NCI)=K
                NFI(NCI)=I
              ENDIF
            ELSE
              IF(QTGL(I).LT.QCL)GO TO 620                      !BAIL OUT
            ENDIF
          ENDDO
!
  620     BVC=ND.GT.IAXSL
          IF(.NOT.BVC.AND.ND0.GT.0)KGSL(K,ND)=ND0   !GROUP NO. WITHIN CF
          if(bkutls)then
            nn=nn+((ncf+1)*ncf)/2
            ncft=ncft+ncf*ncf
            if(.not.bfot.and.qn(ii).lt.90)ncft0=ncft0+ncf*ncf
!        write(mw6,*)k,ncft0,ncft,qn(ii)
            isxdi=max(isxdi,ncf)
          endif
        ENDIF
      ENDDO
!
      IF(NC+ncc.GT.0)THEN
!
        if(bkutls)then
!
          nc=nc+ncc
!
          if(bfot)then                          !need c-c e-vectors
            nctot=nctot+ncft
          else                                  !only b-b
            iaxuc=max(iaxuc,nctot+ncft)         !need buffer
            nctot=nctot+ncft0                   !so can overwite c-c
          endif
!
        else
!
          NN=((NC+1)*NC)/2+NN
          isxdi=max(isxdi,nc)
          iorb(mx0-1)=nc*nc
!
          do i=mx0,mxorb
            n=ncc0(i)
            iorb(i)=iorb(i-1)+n*n
            if(n.gt.0)then
              nn=((n+1)*n)/2+nn
              isxdi=max(isxdi,n)
              nc=nc+n
            endif
          enddo
!
          if(bfot)then                          !need c-c e-vectors
            nctot=nctot+iorb(mxorb)
          else                                  !only b-b
            iaxuc=max(iaxuc,nctot+iorb(mxorb))  !need buffer
            nctot=nctot+iorb(mx0-1)             !so can overwite c-c
          endif
!
        endif
!        write(mw6,*)nc,nn,nctot
!
        WRITE(MW6,10220)ND,QCS+1,QCL/2,KCP/2,NC
!
        IAXDI=MAX(IAXDI,NC)
        IF(NC.GT.MAXDI)THEN
          IF(MAXDI.GT.0)WRITE(MW6,10210)
        ENDIF
!
        IF(BAUGER)THEN
          LU=NCC*(NC-NCC)
          IXAAI=MAX(LU,IXAAI)
          NN=NN+LU
!
!          lusum=lusum+lu
!          write(mw6,*)lu,nn
!          write(mw6,*)'lusum=',lusum
        ENDIF
!
        NSL0=ND
        IF(.NOT.BVC)THEN
          QLI(ND)=QCL
          QSI(ND)=QCS
          QPI(ND)=INT(KCP,QP)
          NSL(ND)=NC
          NGRPI(ND)=NCI-NC
        ENDIF
      ENDIF
!
      KCP=KCP+2
      IF(KCP.LE.2)GO TO 600          !LOOP UP TO NEXT PARITY
!
      QCS=QCS-QTWO
      IF(QCS.GE.0)GO TO 500          !LOOP UP FOR NEXT SPIN
!
      QCL=QCL-QTWO
      IF(QCL.GE.0)GO TO 400          !LOOP UP FOR NEXT ORB A.M.
!
!                                    !END SLP SYMMETRY LOOPS
      if(nci.ne.ntt.and..not.blp)then
        write(mw0,*)'sr.algeb2: mis-match between nci & ntt?',nci,ntt
      endif
!
      CALL DIMUSE('MAXTM',NCI)
      CALL DIMUSE('MAXSL',ND)
!
      IF(BLP)THEN
        IF(MAXTM.GT.0)WRITE(MW6,10060)IAXTM,MAXTM
      ENDIF
      IF(BVC)THEN
        IF(MAXSL.GT.0)WRITE(MW6,10070)IAXSL,MAXSL
      ENDIF
! temp
      if(blp.or.bvc)stop 'algeb2: not all groups/terms allocated...'
!
      IADD=NN
!
      CALL DIMUSE('MAXAD',IADD)
      IF(IADD.GT.MAXAD)THEN
        IF(MAXAD.GT.0)WRITE(MW6,10050)IADD,MAXAD
      ENDIF
!
! THESE 3 DIMENSIONS ARE FOR INFO ONLY. NOT NEEDED UNTIL DIAGON.
! NOTE: IF MODE=3 OR 4 IS SET IN MINIM THEN THE ACTUAL DIMENSIONS
! REQUIRED (ALLOCATED F95) WILL BE LARGER. THESE MODES ARE (SMALL)
! TEST CASES, NOT PRODUCTION RUNS, SO NOT LIKELY AN ISSUE. WOULD
! NEED USER TO SET MODE IN ALGEB, AND CODE DIAGON DIMENSION VARIATION.
!
      if(bfot)iaxuc=nctot
      WRITE(MW6,10230)ISXDI,IAXDI,MAXDI
      WRITE(MW6,10240)NCTOT,IAXUC,MAXUC
      WRITE(MW6,10250)IXAAI,MXAAI
!
      IF(NCTOT.GT.MAXUC)THEN
        IF(MAXUC.GT.0)WRITE(MW6,10260)
      ENDIF
!
      IF(IXAAI.GT.MXAAI)THEN
        IF(MXAAI.GT.0)WRITE(MW6,10280)IXAAI
      ENDIF
!
      IF(BLX)THEN                                    !NO LONGER POSSIBLE
        WRITE(MW6,10270)
        WRITE(MW0,*)'*** INCREASE MXAAI OR MAXDI'
        GO TO 2400
      ENDIF
!
! local (ex-common/nrbtmp/)
      deallocate(ncc0,iorb,stat=ierr)
!
      if(ierr.ne.0)then
        write(mw0,*)'algeb2: de-allocation fails for ncc0,iorb'
        nf=0
        return
      endif
!
!-----------------------------------------------------------------------
!
! SET METASTABLE LSP GROUPS BASED-ON PRE-EXISTING TERMS/LEVELS FILES
! SO AS TO RESTRICT UNNECESSARY BORN INTEGRAL EVALUATION ETC.
!
!-----------------------------------------------------------------------
!
      BEX=.FALSE.
      IF(NMETA.LT.0.AND..NOT.BVC)THEN
        NMETA=-NMETA
        INQUIRE(FILE='TERMS',EXIST=BEX)
        IF(BEX)THEN
          OPEN(MRW14,FILE='TERMS',STATUS='OLD')
          READ(MRW14,*,END=660)
          DO K=1,NSL0                            !ASSUME WE CAN RESTRICT
            NMETAG(K)=1
          ENDDO
          DO N=1,NMETA
            READ(MRW14,10370,END=660)ISP,LSP,IPP,NDUM,NDUM,DUM,MYRGE
            IF(MYRGE.NE.MBLANK)THEN                     !CANNOT RESTRICT
              DO K=1,NSL0
                NMETAG(K)=0
              ENDDO
              GO TO 660
            ENDIF
            IF(ISP.GT.0)THEN
              ISP=ISP-1
              LSP=LSP+LSP
              IPP=IPP+IPP
              DO K=1,NSL0
                IF(ISP.EQ.QSI(K).AND.LSP.EQ.QLI(K).AND.IPP.EQ.QPI(K))   &
     &             THEN
                  NMETAG(K)=0
                  GO TO 640
                ENDIF
              ENDDO
            ELSE
              GO TO 660
            ENDIF
  640     ENDDO
  660     CLOSE(MRW14)
          IUNIT(MRW14)=-1
!          write(mw6,*)'lsp groups'
!          do k=1,nsl0
!            write(mw6,*)k,nmetag(k)
!          enddo
        ELSE
          WRITE(MW6,10490)
          WRITE(MW0,10490)
        ENDIF
!w      ELSE
!w        IF(IDW.NE.0.AND.NMETA.GT.0)THEN
!w          WRITE(MW6,1121)
!w          WRITE(MW0,1121)
!w        ENDIF
      ENDIF
!
      IF(NMETAJ.LT.0.AND..NOT.BVC)THEN    !CATCH EK, ALGEB3 TOO LATE
        INQUIRE(FILE='LEVELS',EXIST=BEXJ)
        IF(BEXJ)THEN
          NMETJ0=NMETAJ
          NMETAJ=-NMETAJ
          OPEN(MRW15,FILE='LEVELS',STATUS='OLD')
          READ(MRW15,*,END=700)
          IF(.NOT.BEX)THEN    !ASSUME WE CAN RESTRICT, IF NOT ALREADY SO
            DO K=1,NSL0
              NMETAG(K)=1
            ENDDO
          ENDIF
          READ(MRW15,10380,END=700)JSP,IP0,IS0,LS0,ICF0,NDUM,DUM,MYRGE
          IS0=ABS(IS0)
          REWIND(MRW15)
          READ(MRW15,*,END=700)
          NMG=0
          ALLOCATE(JMG(NMETAJ))
          DO N=1,JAXLV
            READ(MRW15,10380,END=700)JSP,IPP,ISP,LSP,ICF,NDUM,DUM,MYRGE
            IF(MYRGE.NE.MBLANK)THEN                     !CANNOT RESTRICT
              DO K=1,NSL0
                NMETAG(K)=0
              ENDDO
              GO TO 700
            ENDIF
            JSP=JSP+1
            IF(ISP.LT.0)THEN
              JSP=-JSP
              ISP=-ISP
            ENDIF
            IF(ISP.GT.0)THEN
              IF(NMETAJ/JAXLV.GT.0)THEN
                IF(ISP.NE.IS0.OR.LSP.NE.LS0.OR.IPP.NE.IP0.OR.           &
     &             ICF.NE.ICF0)THEN
                  NMETAJ=N-1
                ELSE
                  ICF0=ICF
                  IS0=ISP
                  LS0=LSP
                  IP0=IPP
                ENDIF
              ENDIF
              DO M=1,NMG
                IF(JSP.EQ.JMG(M))GO TO 665
              ENDDO
              IF(N.LE.NMETAJ)THEN
                NMG=NMG+1
                JMG(NMG)=JSP
              ELSE
                GO TO 680
              ENDIF
  665         ISP=ISP-1
              LSP=LSP+LSP
              IPP=IPP+IPP
              DO K=1,NSL0
                IF(ISP.EQ.QSI(K).AND.LSP.EQ.QLI(K).AND.IPP.EQ.QPI(K))   &
     &             THEN
                  NMETAG(K)=0
                  GO TO 680
                ENDIF
              ENDDO
            ELSE
              GO TO 700
            ENDIF
  680     ENDDO
  700     CLOSE(MRW15)
          IUNIT(MRW15)=-1
          DEALLOCATE(JMG)
          NMETAJ=NMETJ0                                      !RE-INSTATE
!          write(mw6,*)'lsjp groups'
!          do k=1,nsl0
!            write(mw6,*)k,nmetag(k)
!          enddo
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
! FLAG EXISTENCE, OR NOT, OF ONE- OR TWO-BODY INTERACTIONS BETWEEN
! CONFIGURATION PAIRS
!
!-----------------------------------------------------------------------
!
! LOCAL
      IXD19=(KMAX*(KMAX+1))/2
!
      ALLOCATE(B2B(IXD19),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB2: ALLOCATION FAILS FOR B2B'
        NF=0
        RETURN
      ENDIF
!
      IF(KUTDSK.LT.KMAX)ALLOCATE(KSTART(KMAX,2))
!
      if(iunit(MR12).ne.0)then                               !for radwin
        n69=69
      else
!        n69=79                        !needs radwin present if external
        n69=69           !restrict to 60-9 normally, can extend to 79...
      endif
      n69=-n69                            !as likely superceded by kutls
!
!!      iflagc=0
      KK=0
      DO KF=1,KMAX                                        !BEGIN KF LOOP
!
        II=IEQ(QCG(NF,KF))
        KCF=0
        IF(QN(II).GE.90)KCF=II                                !CONTINUUM
        if(qn(ii).ge.60.and.qn(ii).le.n69)kcf=-ii           !omit ryd ci
!!        iflagc=max(iflagc,kcf)
!
        DO KG=1,KF                                        !BEGIN KG LOOP
          KK=KK+1
!
          B2B(KK)=.FALSE.
!
          II=IEQ(QCG(NF,KG))
          KCG=0
          IF(QN(II).GE.90)KCG=II
          if(qn(ii).ge.60.and.qn(ii).le.n69)kcg=-ii         !omit ryd ci
!
! OMIT CONT-CONT'
          IF(KCF.NE.KCG.AND.KCF*KCG.NE.0)GO TO 750     !DOES NOT CONTRIB
          IF(.NOT.BAUGER.AND.KCF.NE.KCG.AND.(KCF.GT.0.OR.KCG.GT.0))     &
     &       GO TO 750                                        !NO AUGERS
          if(kcf.ne.kcg.and.(kcf+kcg).lt.0)go to 750
!
! omit corr-corr'
          if(kcutx.gt.0.and.kf.ne.kg.and.kg.gt.kcut)go to 750
!!                     .and.kcf+kcg+iflagc.gt.0
!
! single cf mixing (but keeping b-c)
          if(kf.ne.kg.and.(kcf+kcg.eq.0.or.kcf*kcg.ne.0))then
            if(kf.gt.kutls)go to 750
            if(kg.gt.kutls)go to 750
          endif
!
! SKIP, IF CONFIG KF AND KG DIFFER IN MORE THAN TWO ELECTRONS
!
          DO I=1,NF
            QLML(I,1)=QCG(I,KG)
          ENDDO
!
          K=0
          DO I=1,NF
            DO L=1,NF
              IF(IEQ(QLML(L,1)).EQ.IEQ(QCG(I,KF)))THEN
                QLML(L,1)=0
                GO TO 720
              ENDIF
            ENDDO
            K=K+1
            IF(K.GT.2)GO TO 750  !KF-KG DIFFER BY MORE THAN 2 PAIRS
  720     ENDDO
!
!
! FLAG KF-KG NEEDED
!
          B2B(KK)=.TRUE.
!
  750   ENDDO                                   !END LOOP KG
!
      ENDDO                                     !END LOOP KF
!
!-----------------------------------------------------------------------
!
! CHECK BUFFERS FOR DC ARRAY IF DISKDC IN USE (CAN ALWAYS SELF-INTERACT)
!
!-----------------------------------------------------------------------
!
      MDCBUF2=0
      IF(KUTDSK.LT.KMAX)THEN
        IEND=MTGD                                            !FOR DISKDC
        MTGD1=MTGD+1
        CALL DISKDC(IUD,IONE,IZERO,IZERO,IZERO,IZERO,IZERO)
                                                         !REPOINT
!
        IF(KUTDSK.LT.KFBUFF)THEN
          DO K=1,NSL0
            MTGD1=MTGD+1                                        !RESTORE
            DO KF=KUTDSK+1,KFBUFF
              NGSYM=KGSL(KF,K)                            !POS WITHIN CF
              IF(NGSYM.GT.0)THEN
                ISTRT=MTGD1
!
                CALL DISKDC(IUD,ISTRT,IFIN,KF,NGSYM,IZERO,IZERO)
!
                MTGD1=IFIN+1
              ENDIF
            ENDDO
            IFIN=MTGD1-1
            MDCBUF2=MAX(MDCBUF2,IFIN)
          ENDDO
          IF(MDCBUF2.GT.MDCBUF)THEN
!
            if(MDCBUF.ne.IAXDC)stop 'algeb2: buffer index error...'
!
            IXXX=MDCBUF2
!
            WRITE(MW6,*)'*** ALGEB2: increasing MAXDC from ',IAXDC,     &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** ALGEB2: increasing MAXDC from ',IAXDC,     &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC(DC,IZERO,MTGD,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'ALGEB2: RE-ALLOCATION FAILS FOR DC',IERR
              NF=0
              GO TO 1700
            ENDIF
!
            IF(.NOT.BFAST)THEN
!
              CALL RE_ALLOC(IDC,IONE,MTGD,IXXX,IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)'ALGEB2: RE-ALLOCATION FAILS FOR IDC',IERR
                NF=0
                GO TO 1700
              ENDIF
!
            ENDIF
!
            IAXDC=IXXX
            MDCBUF=IAXDC
          ENDIF
          MDCBUF2=0
        ELSE
          MDCBUF2=MDCBUF
          DO K=KFBUFF+1,KMAX
            KSTART(K,1)=0
          ENDDO
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
      IF(MPRINT.LT.MG)THEN
        IF(.NOT.BKUTOO)WRITE(MW6,10080)MAXAD,MAXSL,MAXTM,MAXTM,IAXRK,   &
     &                                 IAXRL,IXDFS
        IF(BKUTOO)WRITE(MW6,10090)MAXAD,MAXSL,MAXTM,MAXTM,IAXRK,IAXRL,  &
     &                            IXDFS,KUTOO
        IF(MAXLAM.NE.MAXLAM0)WRITE(MW6,10100)MAXLAM
        WRITE(MW6,10020)IADD,NSL0,NCI,NCI,0,0
        WRITE(MW6,10550)MDCBUF2,MAXDC
      ENDIF
!
!-----------------------------------------------------------------------
!
! EX-COMMON/DXRL/
!
      IAXRK=MAX(MAXRK0,MAXRK,IAXRK)               !USE LARGEST PREVIOUS
!      IAXRK=MAX(MAXRK0,MAXRK)                     !RESET
      IAXRL=MAX(MAXRL0,MAXRL,IAXRL)               !USE LARGEST PREVIOUS
!      IAXRL=MAX(MAXRL0,MAXRL)                     !RESET
!
      ALLOCATE(DRK(IAXRK),QRL(5,IAXRL),NRK(IAXRK),NAD(0:IADD),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB2: ALLOCATION FAILS FOR  DRK,QRL,NRK,NAD'
        NF=0
        GO TO 1700
      ENDIF
!
! EX-COMMON/NRBNF1/
      IRKO=1
      IF(BKUTOO)IRKO=IAXRK                                        !MXRKO
      ALLOCATE(DEK(IRKO),BFALL(IRKO),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB2: ALLOCATION FAILS FOR  DEK, BFALL'
        NF=0
        GO TO 1700
      ENDIF
!
! EX-COMMON/DXRLS/
!
      IXRKS=MAX(MXRKS0,MXRKS,IXRKS)               !USE LARGEST PREVIOUS
!      IXRKS=MAX(MXRKS0,MXRKS)                     !RESET
      IXRLS=MAX(MXRLS0,MXRLS,IXRLS)               !USE LARGEST PREVIOUS
!      IXRLS=MAX(MXRLS0,MXRLS)                     !RESET
!
      IXROS=1
      IF(BKUTOO)IXROS=IXRKS                                       !MXROS
      ALLOCATE(DRKS(IXRKS),DEKS(IXROS),QRLS(5,IXRLS),NRKS(IXRKS),       &
     &         BFALLS(IXROS),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB2: ALLOCATION FAILS FOR  DRKS,DEKS,QRLS ETC'
        NF=0
        GO TO 1700
      ENDIF
!
! EX-COMMON/NSTS/
!
      IXXXX=MAX(IXRLS,IAXRL)
      IXD27=KMAX*KMAX
      ALLOCATE(NADS(-1:IXD27),NSTJ(IXRKS),NSTJD(IXRKS),IORIG(IXXXX),    &
     &         JORIG(IXRLS),JPLANT(IXRLS),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB2: ALLOCATION FAILS FOR NADS,NSTJ,IORIG ETC'
        NF=0
        GO TO 1700
      ENDIF
!
! LOCAL
      JMX=JYF(KMAX)
!
      ALLOCATE(BAM(JMX),BBM(JMX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB2: ALLOCATION FAILS FOR AM,BM'
        NF=0
        GO TO 1700
      ENDIF
      BAMBM=.TRUE.
!
!-----------------------------------------------------------------------
!
      IF(MPRINT.LT.MG)GO TO 1700              !EXIT TERM DIMENSION CHECK
!
!-----------------------------------------------------------------------
!
! CALCULATE SOME (PRODUCTS OF) CLEBSCH-GORDAN COEFFICIENTS:
!
! VCA=C(L1,L2,L,0,0,0)*C(L1,L2,KT,ML1,ML2,MLK)/(L+1)
! VCB=C(L1,L2,L,0,0,0)*C(L1,L2,KT+2,ML1,ML2,MLK)
!
      NXLL=-1
      BSKP=MPRINT+2.LT.MG                !NO SKIP NOW. OLD +0 -3,-4 SKIP
      IF(.NOT.BSKP)THEN
!
        NXLL=MXLL
        IXLL1=MXLL/ITWO+1
!
        IF(MAXLL.GE.0)THEN               !AS MAXLL IS NOW MAX L *PLUS* 1
          IAXLL=MAXLL
        ELSE
          IAXLL=MAXLL0
        ENDIF
        IAXLL=MIN(IXLL1,IAXLL,MAXLL1)
        BVC=IXLL1.LE.IAXLL
        IF(.NOT.BVC)MXLL=2*IAXLL-2
!
        IF(IAXLL.LE.0)GO TO 1100
!
        IXD31=IAXLL
        IXD32=IXD31*IXD31
!
        CALL DIMUSE('MAXLL',IXD31)
!
! EX-COMMON/CFCT/
        ALLOCATE(VCA(IXD32,IXD32,IXD31),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB2: ALLOCATION FAILS FOR VCA'
          NF=0
          GO TO 1700
        ENDIF
        IF(BDLBD)THEN
          ALLOCATE(VCB(IXD32,IXD32,IXD31),STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'ALGEB2: ALLOCATION FAILS FOR VCB'
            NF=0
            GO TO 1700
          ENDIF
        ENDIF
!
        M1=0
  800   M2=0
!
  850   MK=ABS(M1-M2)
!
  900   MKT=MK+2
        DVC0=VCC(M1,M2,MK,IZERO,IZERO,IZERO)
        ML1=-M1
!
  950   MB1=MVC(M1,ML1)
        ML2=-M2
!
 1000   MB2=MVC(M2,ML2)
        DA=DZERO
        DD=DZERO
        MLK=ML1+ML2
!
        IF(ABS(MLK).LE.MKT)THEN
          IF(BDLBD)DD=VCC(M1,M2,MKT,ML1,ML2,MLK)*DVC0
          IF(ABS(MLK).LE.MK)DA=(VCC(M1,M2,MK,ML1,ML2,MLK)/(MK+1))*DVC0
        ENDIF
!
        MLK=MK/4+1
        VCA(MB1,MB2,MLK)=DA
        IF(BDLBD)VCB(MB1,MB2,MLK)=DD
!
        ML2=ML2+2
        IF(ML2.LE.M2)GO TO 1000
!
        ML1=ML1+2
        IF(ML1.LE.M1)GO TO 950
!
        MK=MK+4
        IF(MK.LE.M1+M2)GO TO 900
!
        M2=M2+2
        IF(M2.LE.MXLL)GO TO 850
!
        M1=M1+2
        IF(M1.LE.MXLL)GO TO 800
      ENDIF
!
 1100 CONTINUE
!
!-----------------------------------------------------------------------
!
!   PREPARE TO CALCULATE THE ALGEBRA OF THE ENERGY MATRIX IN SL COUPLING
!   I.E., THE COEFFICIENTS A AND B, AS WELL AS FOR EK RADIATION
!   THIS SECTION SHOULD BE STUDIED TOGETHER WITH (COMMENTS IN) SR.FLGL
!   AND SR.EKALG
!
!-----------------------------------------------------------------------
!
      IF(.NOT.BKUTOO)WRITE(MW6,10080)MAXAD,MAXSL,MAXTM,MAXTM,IAXRK,     &
     &                               IAXRL,IXDFS
      IF(BKUTOO)WRITE(MW6,10090)MAXAD,MAXSL,MAXTM,MAXTM,IAXRK,IAXRL,    &
     &                          IXDFS,KUTOO
      IF(MAXLAM.NE.MAXLAM0)WRITE(MW6,10100)MAXLAM
!
! DRK(K),K=1,NAD(N=0) WILL BE THE COEFFICIENTS TO THE CLOSED SHELL
! CONFIGURATION C0-IT CONTRIBUTES TO ALL DIAGONAL <T!H!T>, EJN-EQ6
! CHOICE OF ML,MS ACCORDING TO TIME OPTIMUM AND STATES AVAILABLE
!
      IOS=0
      JOS=1
      IRK=0
      IRL=0
      NAD(0)=0
      BAM(1)=.FALSE.
!
      IF(NW.GT.0)THEN
        NCOR=-1
        KCF1=NFK(1)
        NADS(-1)=-1
        NADG(1)=0
      ELSE
        NCOR=0
        NADS(-1)=0
      ENDIF
!
      NCFMX=(KMAX*(KMAX+1))/2
!
      MXIRKS=0
      MXIRLS=0
      JOSS=1
!
      IF(BMOD2)THEN                                              !SLOWER
        QMS=INT(NF-(NF/2)*2,QP)
        QML=0
        WRITE(MW6,*)'SR.ALGEB2: FLGL USING NON-DEFAULT MS, ML:',QMS,QML
        WRITE(MW0,*)'SR.ALGEB2: FLGL USING NON-DEFAULT MS, ML:',QMS,QML
        DO J=JYI(1),JYF(KMAX)
          BAM(J)=QBML(J).NE.QML.OR.QBMS(J).NE.QMS
        ENDDO
        DO NCF=1,NCFMX
          NADS(NCF)=0
        ENDDO
      ENDIF
!
      BLP=MPRINT.GT.0
!
!*****************************
!
!  EXPAND THE NSL0 SLP GROUPS
!
!*****************************
!
      if(btime)then
        time1=dzero
        time2=dzero
      endif
!
      NCI=0
      DO K=1,NSL0                            !START LOOP OVER SLP GROUPS
!
        NC=NSL(K)
        IF(NCOR.GE.0)NADG(K)=NCOR
!
        if(btime)call nrb_time(timei)
!
        IF(.NOT.BMOD2)THEN                  !CHOOSE MIN SLATER STATE SET
          QMS=QSI(K)
          QML=QLI(K)
          QMP=QPI(K)
!
          DO NCF=1,NCFMX
            NADS(NCF)=0
          ENDDO
!                                                    !PRE-SELECT CONFIGS
          DO KK=1,KMAX
            IF(KGSL(KK,K).GT.0)THEN                !CF CONTRIBS TO GROUP
              DO J=JYI(KK),JYF(KK)
                BAM(J)=QBML(J).NE.QML.OR.QBMS(J).NE.QMS
              ENDDO
            ELSE
              K1=(KK*(KK-1))/2
              K2=K1+KK
              K1=K1+1
              DO NCF=K1,K2
                NADS(NCF)=-1
              ENDDO
              NCF=K2
              DO K0=KK+1,KMAX
                NCF=NCF+K0-1
                NADS(NCF)=-1
              ENDDO
            ENDIF
          ENDDO
          KK=0
          DO KF=1,KMAX
            DO KG=1,KF
              KK=KK+1
              IF(.NOT.B2B(KK))NADS(KK)=-1
            ENDDO
          ENDDO
          KONE=1
        ELSE
          KONE=K
        ENDIF
!
        IF(KONE.EQ.1)THEN               !UPDATE SLATER-STATE INTERACTION
!
          CALL FLGL1(KCF1,KMAX,NF,JYI,JYF,QLML,BAM,MAXEL)
!
          MXIRKS=MAX(MXIRKS,IRKS)
          MXIRLS=MAX(MXIRLS,IRLS)
          IF(IRLS.GT.IXRLS)JOSS=-1
          IF(IRKS.GT.IXRKS)JOSS=0
          IF(JOSS.LE.0)GO TO 1200          !DIMENSION EXCEEDED, BAIL OUT
          IF(NF.LE.0)GO TO 2400
!
          IF(BAM(1))THEN
            WRITE(MW6,10200)
            BAM(1)=.FALSE.
          ENDIF
!
        ENDIF
!
        if(btime)then
          call nrb_time(timef)
          time1=time1+timef-timei
        endif
!
        IF(KUTDSK.LT.KFBUFF)THEN
          MTGD1=MTGD+1                                          !RESTORE
          DO KF=KUTDSK+1,KFBUFF                   !LOAD NEW SL GROUP VCC
            KSTART(KF,1)=0
            NGSYM=KGSL(KF,K)                              !POS WITHIN CF
            IF(NGSYM.GT.0)THEN
              ISTRT=MTGD1
              KSTART(KF,1)=ISTRT
!
              CALL DISKDC(IUD,ISTRT,IFIN,KF,NGSYM,IONE,IZERO)
!
              MTGD1=IFIN+1
              IF(IFIN.LT.0)THEN           !FAILURE TO READ REQUIRED DATA
                NF=-1
                GO TO 2400
              ENDIF
            ENDIF
          ENDDO
          IFIN=MTGD1-1
          MDCBUF2=MAX(MDCBUF2,IFIN)
        ENDIF
!
        if(btime)call nrb_time(timei)
!
        istrt0=0
        KF0=0
 1150   DO ND1=1,NC                       !BEGIN LOOP OVER INITIAL TERMS
!
          ND=ND1+NCI
          KF=NFK(ND)
!
          ii=ieq(qcg(nf,kf))
          kcf=0
          if(qn(ii).ge.90)kcf=ii           !continuum
!
          IF(KF.GT.KUTDSK.AND.KF.NE.KF0)THEN
            ISTRT=KSTART(KF,1)
            IF(ISTRT.EQ.0)THEN                           !BUFFERED BY CF
              NGSYM=KGSL(KF,K)                            !POS WITHIN CF
              ISTRT=MTGD1
!
              CALL DISKDC(IUD,ISTRT,IEND,KF,NGSYM,IONE,IZERO)
!
              IF(IEND.LT.0)THEN           !FAILURE TO READ REQUIRED DATA
                NF=-1
                GO TO 2400
              ENDIF
            ENDIF
            ISTRT0=ISTRT-MTGD-1                     !I.E. ORIGINAL MTGD1
            KF0=KF
          ENDIF
!
          II=NFI(ND)
          IF(BFAST)THEN
            ND2=JTGD(II)+ISTRT0            !relative start flagged
          ELSE
            do j=jyi(kf),jyf(kf)
              mam(j)=0
            enddo
            k2=jtgd(ii)                    !absolute end flagged
            if(k2.lt.0)then                !bdisk first
              k2=-k2
              k1=mtgd
            else
              k1=jtgd(ii-1)                !start
              k1=abs(k1)                   !case bdisk second
            endif
            k1=k1+1+istrt0
            k2=k2+istrt0
            do k12=k1,k2
              j=idc(k12)
              mam(j)=k12
            enddo
          ENDIF
!
          istrt=0
          KG0=0
          DO NDP1=1,ND1                     !BEGIN LOOP OVER FINAL TERMS
!
            NG=NDP1+NCI
            KG=NFK(NG)
!
            jj=ieq(qcg(nf,kg))
            kcg=0
            if(qn(jj).ge.90)kcg=jj         !continuum
            if(kcf.ne.kcg.and.kcf*kcg.ne.0)go to 1180  !does not contrib
            btest=kcf.ne.kcg.and.(kcf.gt.0.or.kcg.gt.0)
            if(.not.bauger.and.btest)go to 1180        !no augers
!                                     single cf mixing (but keeping b-c)
            btest=kf.ne.kg.and.(kcf+kcg.eq.0.or.kcf*kcg.ne.0)
            if(bkutls.and.btest)go to 1180
!
            BEQCFS=KG.EQ.KF
            IF(BEQCFS)THEN
              IF(NCOR.LT.0)THEN
                KK=0
              ELSE
                KK=(KF*(KF+1))/2
              ENDIF
            ELSE
!              if(kf.lt.kg)stop 'flgl2: kf.lt.kg'
              KK=(KF*(KF-1))/2+KG
            ENDIF
!
            IRK0=IRK+1
            IF(NADS(KK).LE.NADS(KK-1))GO TO 1160   !CONFIGS INCOMPATIBLE
!                                                  !but ncor incremented
            IF(KG.GT.KUTDSK.AND.KG.NE.KG0)THEN
              ISTRT=KSTART(KG,1)
              IF(ISTRT.EQ.0)THEN                         !BUFFERED BY CF
                LGSYM=KGSL(KG,K)                          !POS WITHIN CF
                ISTRT=IEND+1                             !AS KF BUFFERED
!
                CALL DISKDC(IUD,ISTRT,IFIN,KG,LGSYM,IONE,IZERO)
!
                IF(IFIN.LT.0)THEN         !FAILURE TO READ REQUIRED DATA
                  NF=-1
                  GO TO 2400
                ENDIF
              ENDIF
              ISTRT=ISTRT-MTGD-1                    !I.E. ORIGINAL MTGD1
              KG0=KG
            ENDIF
!
            JJ=NFI(NG)
            IF(BFAST)THEN
              NDP2=JTGD(JJ)+ISTRT          !relative start flagged
            ELSE
              do j=jyi(kg),jyf(kg)
                nam(j)=0
              enddo
              k2=jtgd(jj)                  !absolute end flagged
              if(k2.lt.0)then              !bdisk first
                k2=-k2
                k1=mtgd
              else
                k1=jtgd(jj-1)              !start
                k1=abs(k1)                 !case bdisk second
              endif
              k1=k1+1+istrt
              k2=k2+istrt
              do k12=k1,k2
                j=idc(k12)
                nam(j)=k12
              enddo
            ENDIF
!
            CALL FLGL2(mam,nam,KK)
!
 1160       NCOR=NCOR+1
!
            IF(IRL.GT.IAXRL)JOS=-1
            IF(IRK.GT.IAXRK)JOS=0
            IF(JOS.LE.0)GO TO 1200         !DIMENSION EXCEEDED, BAIL OUT
            IF(NF.LE.0)GO TO 2400
!
            IF(BLP.AND.IRK.GE.IRK0)THEN
              IF(IRK-IRK0.NE.5)THEN
                WRITE(MW6,10020)NCOR,K,ND,NG,IRK,IRL,                   &
     &                          (NRK(I),DRK(I),I=IRK0,IRK)
              ELSE
                WRITE(MW6,10010)NCOR,K,ND,NG,IRK,IRL,                   &
     &                          (NRK(I),DRK(I),I=IRK0,IRK)
              ENDIF
              IF(BKUTOO)WRITE(MW6,10030)(NRK(I),DEK(I),I=IRK0,IRK)
              WRITE(MW6,10020)
            ENDIF
!
            NAD(NCOR)=IRK
            IF(NCOR.EQ.0)GO TO 1150     !THEN THAT WAS CLOSED-SHELL CORE
!
 1180     ENDDO                               !END LOOP OVER FINAL TERMS
!
        ENDDO                               !END LOOP OVER INITIAL TERMS
!
        if(btime)then
          call nrb_time(timef)
          time2=time2+timef-timei
        endif
!
        NCI=NCI+NC
!
      ENDDO                                    !END LOOP OVER SLP GROUPS
!
!       do i=1,irks
!         write(mw6,3333)i,nrks(i),nstj(i),nstjd(i),drks(i)
! 3333  format(i5,i3,2i5,f10.6)
!       enddo
!
      if(btime)then
!par        if(iam.ge.0)then                                        !par
!par          write(iwp,*)'proc',iam,' for algeb2:'                 !par
!par          write(iwp,*)'    flgl1 time=',nint(time1),'sec'       !par
!par          write(iwp,*)'    flgl2 time=',nint(time2),'sec'       !par
!par          call flush(iwp)                                       !par
!par        else                                                    !par
        write(iw,*)'flgl1 time=',nint(time1),'sec'
        write(iw,*)'flgl2 time=',nint(time2),'sec'
!          call flush(iw)
!par        endif                                                   !par
      endif
!
!
! RESULTS
! DRK(K),K=NAD(N-1)+1,NAD(N)=STRUCTURE COEFFICIENTS,
! AND NRK(K)=SLATER INTEGRAL ADRESSES L, OF THE N'TH ENERGY MATRIX
! ELEMENT; (T!H!T') IS N-NUMBERED IN REDUCED TRIANGULAR ORDER-COM-
! PARE THE FIRST THREE COLUMNS OF THE COEFFICIENT TABLE, IT REVEALS
! MOST FEATURES. THE FOUR ELECTRON ARGUMENTS (1,2,3..FOR 1S,2S,2P..)
! OF THE L'TH SLATER INTEGRAL ARE IN QRL(1-4,L), QRL(5,L)=2*LAMBDA.
! QRL(5,L)=-1 INDICATES A NONTRIVIAL, OFF-DIAGONAL ONE-BODY INTEGRAL
!
      MM=IRL+IRK-IRK0
      IF(BAM(1))WRITE(MW6,10190)MM
!
      IF(IADD.NE.NCOR)THEN
        WRITE(MW6,*)'SR.ALGEB2 GLOBAL INDEX ERROR:',IADD,NCOR
        NF=-1
        GO TO 2400
      ENDIF
!
 1200 CONTINUE
!
      CALL DIMUSE('MAXRK',IRK)
      CALL DIMUSE('MAXRL',IRL)
      CALL DIMUSE('MXRKS',MXIRKS)
      CALL DIMUSE('MXRLS',MXIRLS)
      IF(MDCBUF2.GT.0)CALL DIMUSE('MAXDC',MDCBUF2)
      IF(BKUTOO)THEN
        CALL DIMUSE('MXRKO',IRK)
        CALL DIMUSE('MXRLO',IRL)
        CALL DIMUSE('MXROS',MXIRKS)
      ENDIF
!
      IF(.NOT.BLP.OR.JOS.LE.0.OR.JOSS.LE.0)THEN
        WRITE(MW6,10020)NCOR,NSL0,ND,NG,IRK,IRL
        IF(JOS.LT.0)GO TO 2000
        IF(JOS.EQ.0)GO TO 1800
        WRITE(MW6,10040)IXRKS,IXRLS,MXIRKS,MXIRLS
        WRITE(MW6,10550)MDCBUF2,MAXDC
        IF(JOSS.LT.0)GO TO 2200
        IF(JOSS.EQ.0)GO TO 2300
        WRITE(MW6,10360)MPRINT
      ELSE
!
! PRINT SLATER INTEGRAL (ADRESS REFERENCE) LIST
!
        WRITE(MW6,10040)IXRKS,IXRLS,MXIRKS,MXIRLS
        WRITE(MW6,10550)MDCBUF2,MAXDC
        IF(IRL.GT.0)THEN
          IF(BKUTOO)WRITE(MW6,10300)KUTOO
          IF(.NOT.BKUTOO)WRITE(MW6,10290)
          DO L=1,IRL
            WRITE(MW6,10340)L,(QRL(I,L),I=1,5)
          ENDDO
        ENDIF
      ENDIF
!
      IF(ALLOCATED(B2B))THEN
        DEALLOCATE(B2B,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB2: DE-ALLOCATION FAILS FOR B2B'
          IF(NF.GT.0)NF=0
          GO TO 1700
        ENDIF
      ENDIF
!
!
!-----------------------------------------------------------------------
!
! WORK OUT REDUCED ELECTRIC 2K-MULTIPOLE MATRIX ELEMENTS
! OMIT EK RAD FOR C-C CONFIGURATIONS (AND B-C IF NO PHOTOIONIZATION)
!
!-----------------------------------------------------------------------
!
      IOS=IRK
      IF(MPRINT.EQ.MG)THEN                             !BAIL-OUT AS NONE
!
        WRITE(MW6,10400)
!
! EX-COMMON/NRBEKP/
        ALLOCATE(NED(2,1,1),STAT=IERR)
!
        NED(1,1,1)=-1
        NED(2,1,1)=-1
!
        GO TO 1600                                        !NORMAL RETURN
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      IF(BLP)WRITE(MW6,10320)
      IF(.NOT.BLP)WRITE(MW6,10330)
!
! EX-COMMON/NRBEKP/
      ALLOCATE(NED(2,NSL0,NTT),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB2: ALLOCATION FAILS FOR  NED'
        NF=0
        GO TO 1700
      ENDIF
!
! AS NOT ALL INIT BY SELECTION RULES
      DO K=1,NTT
        DO J=1,NSL0
          NED(1,J,K)=0
          NED(2,J,K)=0
        ENDDO
      ENDDO
!
! CHECK WORD LENGTH
!
      ITEST4=IBUFF4
      ITEST4=ITEST4+1
      IF(IWORD.EQ.4.AND.ITEST4.LT.IBUFF4)THEN
        MX=MPOLX
        MX=MX-MPOL0                                          !FLAGX
        MXPOL=MAX(IONE,MX/2+1)
        MXORB2=MXORBR*MXORBR
        N8=NCI
        N8=N8*MXORB2*MXPOL
        IF(N8.GT.IBUFF4)THEN
          WRITE(MW0,*)'ALGEB2:I*4/SP TOO SHORT FOR E_K RAD'
          WRITE(MW0,*)'ALGEB2:CHANGE SP TO I*8/EP IN MODULE COMMON_DXRL'
          WRITE(MW6,*)'ALGEB2:I*4/SP TOO SHORT FOR E_K RAD'
          WRITE(MW6,*)'ALGEB2:CHANGE SP TO I*8/EP IN MODULE COMMON_DXRL'
          NF=0
          GO TO 1700
        ENDIF
      ENDIF
!
! THIS IS MORE GENERAL (BINDB...)
!
      IF(SP.EQ.4.AND.MXORB.GT.65535)THEN   !MXORB*(MXORB+1)/2.GT.2**31-1
        WRITE(MW0,*)'ALGEB2: I*4/SP TOO SHORT FOR E_K RAD'
        WRITE(MW0,*)'ALGEB2: CHANGE SP TO I*8/EP IN MODULE PRECSN'
        WRITE(MW6,*)'ALGEB2: I*4/SP TOO SHORT FOR E_K RAD'
        WRITE(MW6,*)'ALGEB2: CHANGE SP TO I*8/EP IN MODULE PRECSN'
        NF=0
        GO TO 1700
      ENDIF
!
! FLAG EXISTENCE, OR NOT, OF ONE-BODY INTERACTIONS BETWEEN
! CONFIGURATION PAIRS
!
! LOCAL
      IXD19=(KMAX*(KMAX+1))/2
!
      ALLOCATE(B1B(IXD19),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB2: ALLOCATION FAILS FOR B1B'
        NF=0
        GO TO 1700
      ENDIF
!
      IFOTMX=0
      IF(BFOT)IFOTMX=1
      IFOTMN=0
      IF(.NOT.BRAD)IFOTMN=1
!
!!      iflagc=0
      KK=0
      DO KF=1,KMAX                                        !BEGIN KF LOOP
        II=QCG(NF,KF)
        IFOT1=0
        IF(QN(II).GE.90)IFOT1=1                               !CONTINUUM
!
        DO KG=1,KF                                        !BEGIN KG LOOP
          KK=KK+1
!
          B1B(KK)=.FALSE.
!
! OMIT CONT-CONT
          II=QCG(NF,KG)
          IFOT2=0
          IF(QN(II).GE.90)IFOT2=1
          IF((IFOT1+IFOT2).GT.IFOTMX)GO TO 1250        !DOES NOT CONTRIB
          IF((IFOT1+IFOT2).LT.IFOTMN)GO TO 1250        !DOES NOT CONTRIB
!
!!      iflagc=max(iflagc,ifot2)
! omit corr-corr'
          if(kcutx.gt.0.and.kf.ne.kg.and.kg.gt.kcut)go to 1250
!!                     .and.ifot1+ifot2+iflagc.gt.0.
!
! FIND NUMBER MK/2 OF ELECTRON PAIRS IN WHICH KF AND KG DIFFER
! AND THEN SEE IF THIS CF PAIR CONTRIBUTES
!
          IF(KF.NE.KG)THEN
            DO I=1,NF
              QLML(I,1)=QCG(I,KG)
            ENDDO
            m1=0
            MK=0
            DO I=1,NF
              DO L=1,NF
                IF(IEQ(QLML(L,1)).EQ.IEQ(QCG(I,KF)))THEN
                  QLML(L,1)=0
                  GO TO 1210
                ENDIF
              ENDDO
              MK=MK+1
              IF(MK.GT.1)GO TO 1250
                                   !KF-KG DIFFER BY MORE THAN 1 PAIR
              M1=I
 1210       ENDDO
            if(m1.eq.0)then
              write(mw0,*)'For CFs:',kf,kg
              stop 'algeb2: cfg match error m1=0'  !shoudn't be
            endif
            m2=0
            DO L=1,NF
              IF(QLML(L,1).NE.0)THEN
                M2=L
                GO TO 1220
              ENDIF
            ENDDO
            if(m2.eq.0)then
              write(mw0,*)'For CFs:',kf,kg
              stop 'algeb2: cfg match error m2=0'  !shoudn't be
            endif
 1220       M1=QCG(M1,KF)
            M2=QCG(M2,KG)
            M1=QL(M1)
            M2=QL(M2)
            IF(M1+M2.LT.MPOL0)GO TO 1250         !NO VALID MULTIPOLE
            IF(ABS(M1-M2).GT.MPOLE)GO TO 1250   !NO VALID MULTIPOLE
          ELSE
            M2=0
            DO I=1,NF
              M1=QCG(I,KG)
              M2=MAX(M2,INT(QL(M1),SP))
            ENDDO
            M1=M2
            IF(M1+M2.LT.MPOL0)GO TO 1250         !NO VALID MULTIPOLE
            if(mpol0.eq.mpole.and.mod(mpol0,ifour).ne.0)go to 1250  !odd
          ENDIF
!
! FLAG KF-KG NEEDED
!
          B1B(KK)=.TRUE.
!
 1250   ENDDO                                   !END LOOP KG
!
      ENDDO                                     !END LOOP KF
!
!-----------------------------------------------------------------------
!
! CHECK BUFFERS FOR DC ARRAY IF DISKDC IN USE
!
!-----------------------------------------------------------------------
!
      IF(KUTDSK.LT.KMAX)THEN
        IEND=MTGD                                            !FOR DISKDC
        MTGD1=MTGD+1
        CALL DISKDC(IUD,IONE,IZERO,IZERO,IZERO,IZERO,IZERO)
                                                         !REPOINT
!
        IF(KUTDSK.LT.KFBUFF)THEN
          MDCBUF2=0
          DO K=1,NSL0
            MTGD1=MTGD+1                                        !RESTORE
            DO KF=KUTDSK+1,KFBUFF
              NGSYM=KGSL(KF,K)                            !POS WITHIN CF
              IF(NGSYM.GT.0)THEN
!
                do kg=1,kmax
                  k1=max(kf,kg)
                  k2=min(kf,kg)
                  kk=(k1*(k1-1))/2+k2
                  if(b1b(kk))go to 1252                 !need this kf
                enddo
                go to 1260
!
 1252           ISTRT=MTGD1
!
                CALL DISKDC(IUD,ISTRT,IFIN,KF,NGSYM,IZERO,IZERO)
!
                MTGD1=IFIN+1
              ENDIF
 1260       ENDDO
            IFIN=MTGD1-1
            MDCBUF2=MAX(MDCBUF2,IFIN)
          ENDDO
          MDCBUF2=MDCBUF2+(MDCBUF2-mtgd)
                                        !MAY OVERESTIMATE FOR E1 BUT IC>
          IF(MDCBUF2.GT.MDCBUF)THEN
!
            if(MDCBUF.ne.IAXDC)stop 'algeb2: buffer index error...'
!
            IXXX=MDCBUF2
!
            WRITE(MW6,*)'*** ALGEB2: increasing MAXDC from ',IAXDC,     &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** ALGEB2: increasing MAXDC from ',IAXDC,     &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC(DC,IZERO,MTGD,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'ALGEB2: RE-ALLOCATION FAILS FOR DC',IERR
              NF=0
              GO TO 1700
            ENDIF
!
            IF(.NOT.BFAST)THEN
!
              CALL RE_ALLOC(IDC,IONE,MTGD,IXXX,IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)'ALGEB2: RE-ALLOCATION FAILS FOR IDC',IERR
                NF=0
                GO TO 1700
              ENDIF
!
            ENDIF
!
            IAXDC=IXXX
            MDCBUF=IAXDC
          ENDIF
          MDCBUF2=0
        ELSE
          DO I=1,2
            DO K=KFBUFF+1,KMAX
              KSTART(K,I)=0
            ENDDO
          ENDDO
        ENDIF
      ENDIF
!
!
!-----------------------------------------------------------------------
!
!   START CALCULATION OF THE ALGEBRA FOR ELECTRIC MULTIPOLES
!
!-----------------------------------------------------------------------
!
      MX000=-MXIRKS          !REMOVE "-" AND COMMENT-OUT NEXT 2 LINES TO
      MXIRKS=0               !SUPPRESS E_K SS STORAGE, UNLESS .GT. FOR H
      MXIRLS=0
!
      if(btime)then
        time1=dzero
        time2=dzero
      endif
!
      NCFMX=KMAX*KMAX                           !FOR INEQUIVALENT GROUPS
      MCI=0
      DO NC=1,NSL0                       !BEGIN LOOP OVER INITIAL GROUPS
        MC=NSL(NC)
!
        QML1=QLI(NC)                                !ENSURE NON-ZERO DVC
        QMS1=QSI(NC)
!
        IF(KUTDSK.LT.KFBUFF)THEN
          MTGD1=MTGD+1                                          !RESTORE
          DO KF=KUTDSK+1,KFBUFF                  !LOAD INITIAL GROUP VCC
            KSTART(KF,1)=0
            NGSYM=KGSL(KF,NC)                             !POS WITHIN CF
            IF(NGSYM.GT.0)THEN
!
              do kg=1,kmax
                k1=max(kf,kg)
                k2=min(kf,kg)
                kk=(k1*(k1-1))/2+k2
                if(b1b(kk))then
                  do nd=1,nc                                !check symms
                    lgsym=kgsl(kg,nd)
                    if(lgsym.gt.0)then
                      btest1=qsi(nd).eq.qsi(nc)
                      btest2=nmetag(nc)+nmetag(nd).le.1
                      if(btest1.and.btest2)then
                        mpi=qpi(nd)+qpi(nc)
                        mmin=max(mpol0,abs(INT(qli(nc)-qli(nd),SP)))
                        if(mod(mpi+mmin,ifour).ne.0)mmin=mmin+2
                        mmax=min(mpole,INT(qli(nc)+qli(nd),SP))
                        if(mod(mpi+mmax,ifour).ne.0)mmax=mmax-2
                        if(mmin.le.mmax)go to 1265     !we have a winner
                      endif
                    endif
                  enddo
                endif
              enddo
              kstart(kf,1)=mtgd1
                                !dummy, else alternate kf read triggered
              go to 1280            !no valid kf-kg so skip this kf read
!
 1265         ISTRT=MTGD1
              KSTART(KF,1)=ISTRT
!
!              write(mw6,*)'*** kf=',kf,' nc=',nc
!
              CALL DISKDC(IUD,ISTRT,IFIN,KF,NGSYM,IONE,IZERO)
!
              MTGD1=IFIN+1
              IF(IFIN.LT.0)THEN           !FAILURE TO READ REQUIRED DATA
                NF=-1
                GO TO 2400
              ENDIF
            ENDIF
 1280     ENDDO
          MHOLD=MTGD1
        ENDIF
!                                                    !PRE-SELECT CONFIGS
        DO KK=1,KMAX
          IF(KGSL(KK,NC).GT.0)THEN                 !CF CONTRIBS TO GROUP
            DO J=JYI(KK),JYF(KK)
              BAM(J)=QBML(J).NE.QML1.OR.QBMS(J).NE.QMS1
            ENDDO
          ENDIF
        ENDDO
!
        MCIP=0
        DO ND=1,NC                         !BEGIN LOOP OVER FINAL GROUPS
          MCP=NSL(ND)
!
          BEQGRP=NC.EQ.ND                                !WITHIN A GROUP
!
! PRE-SELECT SYMMETRIES...
!
          IF(QSI(ND).NE.QSI(NC).OR.NMETAG(NC)+NMETAG(ND).GT.1)THEN
            NED(1,ND,MCI+1)=0                        !AS HISTORIC UNINIT
            GO TO 1320
          ENDIF
!
          MMIN=MAX(MPOL0,ABS(INT(QLI(NC)-QLI(ND),SP)))
          IF(MOD(QPI(ND)+QPI(NC)+MMIN,IFOUR).NE.0)MMIN=MMIN+2
          MMAX=MIN(MPOLE,INT(QLI(NC)+QLI(ND),SP))
          IF(MOD(QPI(ND)+QPI(NC)+MMAX,IFOUR).NE.0)MMAX=MMAX-2
!
          IF(MMIN.GT.MMAX)THEN
            NED(1,ND,MCI+1)=0                        !AS HISTORIC UNINIT
            GO TO 1320
          ENDIF
!
          if(btime)call nrb_time(timei)
!
          QML2=QLI(ND)                              !ENSURE NON-ZERO DVC
          QMS2=QSI(ND)
!
          MB1=QLI(NC)
          MB2=QLI(ND)
          ML1=QML1
          ML2=-QML2
          MLK=ML1+ML2
!
          DO MK=MMIN,MMAX,4
            MM=MK/4
            DVC(MM)=VCC(MB1,MB2,MK,ML1,ML2,MLK)
!     &    *(-1)**(MB2+ML2)
            IF(DVC(MM).EQ.DZERO)then             !this should not happen
              write(mw6,*)'algeb2: dvc=0 - report to nrb'
              write(mw6,*)mb1/2,mb2/2,mk/2,'  ',ml1/2,ml2/2,mlk/2
              write(mw0,*)'algeb2: dvc=0 - report to nrb'
!              write(mw0,*)mb1/2,mb2/2,mk/2,'  ',ml1/2,ml2/2,mlk/2
            endif
          ENDDO
!
          BBM(1)=BEQGRP
          DO NCF=1,NCFMX                                     !INITIALIZE
            NADS(NCF)=0
          ENDDO
          IF(.NOT.BEQGRP)THEN                           !(RE-)SET FOR KF
            DO KK=1,KMAX
              IF(KGSL(KK,NC).LE.0)THEN              !CF DOES NOT CONTRIB
                K1=KMAX*(KK-1)
                K2=K1+KMAX
                K1=K1+1
                DO NCF=K1,K2
                  NADS(NCF)=-1
                ENDDO
              ENDIF
            ENDDO
            KK=0
            DO KF=1,KMAX
              DO KG=1,KF
                KK=KK+1
                IF(.NOT.B1B(KK))THEN
                  NCF=KMAX*(KF-1)+KG
                  NADS(NCF)=-1
                  NCF=KMAX*(KG-1)+KF
                  NADS(NCF)=-1
                ENDIF
              ENDDO
            ENDDO
          ELSE
            KK=0
            DO KF=1,KMAX
              DO KG=1,KF
                KK=KK+1
                IF(.NOT.B1B(KK))NADS(KK)=-1
              ENDDO
            ENDDO
          ENDIF
!                                                    !PRE-SELECT CONFIGS
          DO KK=1,KMAX
            IF(KGSL(KK,ND).GT.0)THEN               !CF CONTRIBS TO GROUP
              DO J=JYI(KK),JYF(KK)
                BBM(J)=QBML(J).NE.QML2.OR.QBMS(J).NE.QMS2
              ENDDO
            ELSE                                    !CF DOES NOT CONTRIB
              IF(.NOT.BEQGRP)THEN
                NCF=KK
                DO K0=1,KMAX
                  NADS(NCF)=-1
                  NCF=NCF+KMAX
                ENDDO
              ELSE
                K1=(KK*(KK-1))/2
                K2=K1+KK
                K1=K1+1
                DO NCF=K1,K2
                  NADS(NCF)=-1
                ENDDO
                NCF=K2
                DO K0=KK+1,KMAX
                  NCF=NCF+K0-1
                  NADS(NCF)=-1
                ENDDO
              ENDIF
            ENDIF
          ENDDO
!
!  DETERMINE SLATER STATE INTERACTIONS BETWEEN THESE GROUPS
!
          CALL EKALG1(KMAX,NF,MMIN,MMAX,DVC,BAM,BBM,QLML,JYI,JYF,MAXEL)
!
          if(btime)then
            call nrb_time(timef)
            time1=time1+timef-timei
          endif
!
          MXIRKS=MAX(MXIRKS,IRKS)
          IF(MXIRKS.GT.IXRKS)GO TO 2300    !DIMENSION EXCEEDED, BAIL OUT
          MXIRLS=MAX(MXIRLS,IRLS)
          IF(MXIRLS.GT.IXRLS)GO TO 2200    !DIMENSION EXCEEDED, BAIL OUT
          IF(NF.LE.0)GO TO 2400
!
          IF(IRKS.EQ.0)THEN                !THERE ARE NO INTERACTIONS
            NED(1,ND,MCI+1)=0                        !AS HISTORIC UNINIT
            GO TO 1320
          ENDIF
!
          IF(KUTDSK.LT.KFBUFF)THEN
            MTGD1=MHOLD                                         !RESTORE
            DO KG=KUTDSK+1,KFBUFF                  !LOAD FINAL GROUP VCC
              IF(BEQGRP)THEN
                KSTART(KG,2)=KSTART(KG,1)
              ELSE
                KSTART(KG,2)=0
                LGSYM=KGSL(KG,ND)                         !POS WITHIN CF
                IF(LGSYM.GT.0)THEN
!
                  do kf=1,kmax
                    kk=kmax*(kf-1)+kg
                    if(nads(kk).gt.nads(kk-1))go to 1282   !need this kg
                  enddo
                  go to 1290
!
 1282             ISTRT=MTGD1
                  KSTART(KG,2)=ISTRT
!
!              write(mw6,*)'--- kg=',kg,' nd=',nd
!
                  CALL DISKDC(IUD,ISTRT,IFIN,KG,LGSYM,IONE,IZERO)
!
                  MTGD1=IFIN+1
                  IF(IFIN.LT.0)THEN       !FAILURE TO READ REQUIRED DATA
                    NF=-1
                    GO TO 2400
                  ENDIF
                ENDIF
              ENDIF
 1290       ENDDO
            IFIN=MTGD1-1
            MDCBUF2=MAX(MDCBUF2,IFIN)
          ENDIF
!
          if(btime)call nrb_time(timei)
!
          istrt0=0
          KF0=0
          DO MD1=1,MC                     !BEGIN LOOP OVER INITIAL TERMS
!
            ND1=MD1+MCI
            NED(1,ND,ND1)=IOS+1
            NED(2,ND,ND1)=IOS
!
            KF=NFK(ND1)
!
            IF(KF.GT.KUTDSK.AND.KF.NE.KF0)THEN
              ISTRT=KSTART(KF,1)
              IF(ISTRT.EQ.0)THEN                         !BUFFERED BY CF
                NGSYM=KGSL(KF,NC)                         !POS WITHIN CF
                ISTRT=MTGD1
!
                CALL DISKDC(IUD,ISTRT,IEND,KF,NGSYM,IONE,IZERO)
!
                IF(IEND.LT.0)THEN         !FAILURE TO READ REQUIRED DATA
                  NF=-1
                  GO TO 2400
                ENDIF
              ENDIF
              ISTRT0=ISTRT-MTGD-1                   !I.E. ORIGINAL MTGD1
              KF0=KF
            ENDIF
!
            II=NFI(ND1)
            IF(BFAST)THEN
              ND2=JTGD(II)+ISTRT0          !relative start flagged
            ELSE
              do j=jyi(kf),jyf(kf)
                mam(j)=0
              enddo
              k2=jtgd(ii)                  !absolute end flagged
              if(k2.lt.0)then              !bdisk first
                k2=-k2
                k1=mtgd
              else
                k1=jtgd(ii-1)              !start
                k1=abs(k1)                !case bdisk second
              endif
              k1=k1+1+istrt0
              k2=k2+istrt0
              do k12=k1,k2
                j=idc(k12)
                mam(j)=k12
              enddo
            ENDIF
!
            istrt=0
            KG0=0
            DO MDP1=1,MCP                   !BEGIN LOOP OVER FINAL TERMS
!
              NDP1=MDP1+MCIP
              IF(NDP1.GT.ND1)GO TO 1300
              KG=NFK(NDP1)
!
              IF(BEQGRP)THEN                !KG.LE.KF HERE
                KK=(KF*(KF-1))/2+KG
              ELSE
                KK=(KF-1)*KMAX+KG
              ENDIF
!
              IF(NADS(KK).GT.NADS(KK-1))THEN
!
!          write(mw6,*)'kf=',kf,' kg=',kg
!
                IF(KG.GT.KUTDSK.AND.KG.NE.KG0)THEN
                  ISTRT=KSTART(KG,2)
                  IF(ISTRT.EQ.0)THEN                     !BUFFERED BY CF
                    LGSYM=KGSL(KG,ND)                     !POS WITHIN CF
                    ISTRT=IEND+1                         !AS KG BUFFERED
!
                    CALL DISKDC(IUD,ISTRT,IFIN,KG,LGSYM,IONE,IZERO)
!
                    IF(IFIN.LT.0)THEN     !FAILURE TO READ REQUIRED DATA
                      NF=-1
                      GO TO 2400
                    ENDIF
                  ENDIF
                  ISTRT=ISTRT-MTGD-1                !I.E. ORIGINAL MTGD1
                  KG0=KG
                ENDIF
!
                JJ=NFI(NDP1)
                IF(BFAST)THEN
                  NDP2=JTGD(JJ)+ISTRT      !relative start flagged
                ELSE
                  do j=jyi(kg),jyf(kg)
                    nam(j)=0
                  enddo
                  k2=jtgd(jj)              !absolute end flagged
                  if(k2.lt.0)then          !bdisk first
                    k2=-k2
                    k1=mtgd
                  else
                    k1=jtgd(jj-1)          !start
                    k1=abs(k1)            !case bdisk second
                  endif
                  k1=k1+1+istrt
                  k2=k2+istrt
                  do k12=k1,k2
                    j=idc(k12)
                    nam(j)=k12
                  enddo
                ENDIF
!
                CALL EKALG2(mam,nam,KK,DVC,JOS,IXY)
!
                IF(IXY.GT.0)GO TO 1900     !IXY.NE.0, DIMENSION EXCEEDED
                IF(IXY.LT.0)GO TO 2000
                IF(NF.LE.0)GO TO 2400
!
              ENDIF
!
            ENDDO                             !END LOOP OVER FINAL TERMS
 1300       NED(2,ND,ND1)=IOS
          ENDDO                             !END LOOP OVER INITIAL TERMS
!
          if(btime)then
            call nrb_time(timef)
            time2=time2+timef-timei
          endif
!
 1320     CONTINUE
!
          MCIP=MCIP+MCP
        ENDDO                                !END LOOP OVER FINAL GROUPS
        MCI=MCI+MC
      ENDDO                                !END LOOP OVER INITIAL GROUPS
!
!
!-----------------------------------------------------------------------
!
      IF(IOS.GE.IOS0)JOS=JOS-1
!
      CALL DIMUSE('MAXRK',IOS)
      IF(MXIRKS.GT.MX000)THEN
        CALL DIMUSE('MXRKS',MXIRKS)
        CALL DIMUSE('MXRLS',MXIRLS)
      ENDIF
      IF(MDCBUF2.GT.0)CALL DIMUSE('MAXDC',MDCBUF2)
!
      MPOLE0=MPOLE
      M0=0
      LHM0=LHM
      IF(BREL)THEN
        M0=2
        LHM=LHM-1
      ENDIF
      DO LH=LHM,0,-1
        I=0
        DO K=1,MXORB
          DO J=1,K
            I=I+1
            IF(BINDB(I,LH))THEN
              MP=ABS(QL(J)-QL(K))/2
              MP=MOD(MP,ITWO)
              M=4*LH+2-2*(1-MP)-M0
              MPOLE=MAX(M,MPOLE)
              IF(MP.EQ.1)GO TO 1400
            ENDIF
          ENDDO
        ENDDO
        IF(MPOLE.GE.0)GO TO 1400
      ENDDO
!
 1400 CONTINUE
!      write(mw0,*)mpole,nmulte
!
      IF(REAL(MPOLE,WP).GE.5*REAL(MPOLE0,WP)/7.OR.                      &
     &   MPOLE0*MXORB2.LT.I100000)GO TO 1500
!
      WRITE(MW6,*)'*** ALGEB2: decreasing KPOLE from ',MPOLE0/2,' to: ',&
     &            MPOLE/2
      WRITE(MW0,*)'*** ALGEB2: decreasing KPOLE from ',MPOLE0/2,' to: ',&
     &            MPOLE/2
!
      LHM=MPOLE/4
      IF(BREL)LHM=LHM+1
!
      CALL RE_ALLOC2(BINDB,IONE,MXORB2,IZERO,LHM0,MXORB2,LHM,IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB2: RE-ALLOCATION FAILS FOR BINDB...',IERR
        NF=0
        GO TO 1700
      ENDIF
!
 1500 IF(.NOT.BLP)THEN
        WRITE(MW6,10350)JOS,NCI,NCI,MPOLE/2,MPOLE/2,IOS
        IF(MXIRKS.GT.MX000)WRITE(MW6,10040)IXRKS,IXRLS,MXIRKS,MXIRLS
        WRITE(MW6,10550)MDCBUF2,MAXDC
        WRITE(MW6,10360)MPRINT
      ELSE
        IF(MXIRKS.GT.MX000)WRITE(MW6,10040)IXRKS,IXRLS,MXIRKS,MXIRLS
        WRITE(MW6,10550)MDCBUF2,MAXDC
      ENDIF
!
      if(btime)then
!par        if(iam.ge.0)then                                        !par
!par          write(iwp,*)'proc',iam,' for algeb2:'                 !par
!par          write(iwp,*)'    ekalg1 time=',nint(time1),'sec'      !par
!par          write(iwp,*)'    ekalg2 time=',nint(time2),'sec'      !par
!par          call flush(iwp)                                       !par
!par        else                                                    !par
        write(iw,*)'ekalg1 time=',nint(time1),'sec'
        write(iw,*)'ekalg2 time=',nint(time2),'sec'
!          call flush(iw)
!par        endif                                                   !par
      endif
!
!
!-----------------------------------------------------------------------
!
 1600 CONTINUE
!
! IF ACTUAL USAGE IS SUFFICIENTLY SMALLER THAN *INITIAL* ALLOCATION,
! THEN REDUCE USAGE TO ACTUAL - FOR SMALL CASES ON SMALL MEMORY MACHINES
!
      IXXX=(4*MAXRL)/5
      IF(IRL.LT.IXXX)THEN
!
!       WRITE(MW6,*)'*** ALGEB2: decreasing MAXRL from ',IAXRL,' to: '
!     &           ,IRL
!       WRITE(MW0,*)'*** ALGEB2: decreasing MAXRL from ',IAXRL,' to: '
!     &           ,IRL
!
        CALL RE_ALLOC2(QRL,IONE,IFIVE,IONE,IAXRL,IFIVE,IRL,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB2: RE-ALLOCATION FAILS FOR QRL...',IERR
          NF=0
          GO TO 1700
        ENDIF
!
        IAXRL=IRL
!
      ENDIF
!
      IXXX=(4*MAXRK)/5
      IF(IOS.LT.IXXX)THEN
!
!       WRITE(MW6,*)'*** ALGEB2: decreasing MAXRK from ',IAXRK,' to: '
!     &           ,IOS
!       WRITE(MW0,*)'*** ALGEB2: decreasing MAXRK from ',IAXRK,' to: '
!     &           ,IOS
!
        CALL RE_ALLOC(DRK,IONE,IAXRK,IOS,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB2: RE-ALLOCATION FAILS FOR DRK...',IERR
          NF=0
          GO TO 1700
        ENDIF
!
        IF(BKUTOO)THEN
!
          CALL RE_ALLOC(DEK,IONE,IAXRK,IOS,IERR)           !KEEP IN SYNC
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'ALGEB2: RE-ALLOCATION FAILS FOR DEK...',IERR
            NF=0
            GO TO 1700
          ENDIF
!
          CALL RE_ALLOC(BFALL,IONE,IAXRK,IOS,IERR)         !KEEP IN SYNC
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'ALGEB2: RE-ALLOCATION FAILS FOR BFALL...',IERR
            NF=0
            GO TO 1700
          ENDIF
!
        ENDIF
!
        CALL RE_ALLOC(NRK,IONE,IAXRK,IOS,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB2: RE-ALLOCATION FAILS FOR NRK...',IERR
          NF=0
          GO TO 1700
        ENDIF
!
        IAXRK=IOS
!
      ENDIF
!
!-----------------------------------------------------------------------
!
 1700 CONTINUE
!
! LOCAL
      IF(ALLOCATED(DVC))DEALLOCATE(DVC)
!
      IF(ALLOCATED(B1B))THEN
        DEALLOCATE(B1B,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB2: DE-ALLOCATION FAILS FOR B1B'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(B2B))THEN
        DEALLOCATE(B2B,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB2: DE-ALLOCATION FAILS FOR B2B'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(KSTART))DEALLOCATE(KSTART)
!
      IF(BAMBM)THEN
        DEALLOCATE(BAM,BBM,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB2: DE-ALLOCATION FAILS FOR AM,BM'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/CFCT/
      IF(ABS(MODD).GT.1.AND.ALLOCATED(VCA))THEN
        DEALLOCATE(VCA,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB2: DE-ALLOCATION FAILS FORVCA'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/DXRLS/
      IF(ALLOCATED(DRKS))THEN
        DEALLOCATE(DRKS,DEKS,QRLS,NRKS,BFALLS,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB2: DE-ALLOCATION FAILS FOR DRKS,DEKS, ETC'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NSTS/
      IF(ALLOCATED(NADS))THEN
        DEALLOCATE(NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB2: DE-ALLOCATION FAILS FOR NADS,NSTJ, ETC'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBLSP/                              ONLY IN ALGEB1,2 BRANCH
      IF(ALLOCATED(LSPIP))THEN
        DEALLOCATE(LSPIP,NLSPIP,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB2: DE-ALLOCATION FAILS FOR LSPIP,NLSPIP'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBLSS/                              ONLY IN ALGEB1,2 BRANCH
      IF(ALLOCATED(NESSH))THEN
        DEALLOCATE(NESSH)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB2: DE-ALLOCATION FAILS FOR NESSH'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN                        !<-------------------- NORMAL RETURN
!
!-----------------------------------------------------------------------
!
!     E R R O R   M E S S A G E S
!
 1800 WRITE(MW6,10120)
      MPOLE=-1
 1900 IF(MPOLE.GE.4)WRITE(MW6,10160)
      IF(MPOLE.EQ.2)WRITE(MW6,10140)
      IF(IRL.LE.IAXRL)GO TO 2100
 2000 WRITE(MW6,10170)
 2100 IF(MPRINT.EQ.MG-1)GO TO 1700
      GO TO 2400
 2200 WRITE(MW6,10180)
      GO TO 2400
 2300 WRITE(MW6,10130)
!
 2400 WRITE(MW6,10150)
      WRITE(MW0,*)'***SR.ALGEB2: STORAGE EXCEEDED ***'
      IF(NF.GT.0)NF=-1
      GO TO 1700
!
!-----------------------------------------------------------------------
!
10010 FORMAT(I9,I3,2I6,I9,I5,6(I6,F11.6))
10020 FORMAT(I9,I3,2I6,I9,I5,6(I6,F11.6)/(38X,6(I6,F11.6)))
10030 FORMAT((38X,6(I6,F11.6)))
10040 FORMAT(/' SLATER STATE INTERACTION STORAGE (MXRKS,MXRLS)',I9,I6,  &
     &       10X,'USED:',I9,I6)
10050 FORMAT(' SR.ALGEB2: ALLOCATION INCREASES NUMBER OF MATRIX ',      &
     &       ' ELEMENTS IADD =',I10,' .GT. MAXAD=',I10)
10060 FORMAT(' SR.ALGEB2: ALLOCATION INCREASES NUMBER OF TERMS ',       &
     &       ' IAXTM=',I7,' .GT. MAXTM=',I7)
10070 FORMAT(' SR.ALGEB2: ALLOCATION INCREASES NUMBER OF GROUPS ',      &
     &       ' IAXSL=',I3,' .GT. MAXSL=',I3)
10080 FORMAT(//' SLATER COEFFICIENTS  F(A,...)  FOR CONSTRUCTING   ',   &
     &'( T !  H  ! TP ) = SUM( F(A,...) * R(A,...) );   NCYC=0: COMMON '&
     &,'DIAGONAL CORE TERM'/I9,I3,2I6,I9,I5,' STORAGE RESTRICTIONS FOR',&
     &' (MAXAD,MAXSL,MAXTM,MAXTM,MAXRK,MAXRL), MXDFS=',                 &
     &I4/'     NCYC GR     T    TP      MNF  MNR',6(3X,'I(R)  F(A,...)')&
     &)
10090 FORMAT(//' SLATER COEFFICIENTS  F(A,...)  FOR CONSTRUCTING   ',   &
     &'( T !  H  ! TP ) = SUM( F(A,...) * R(A,...) );   NCYC=0: COMMON '&
     &,'DIAGONAL CORE TERM'/I9,I3,2I6,I9,I5,' STORAGE RESTRICTIONS FOR',&
     &' (MAXAD,MAXSL,MAXTM,MAXTM,MAXRK,MAXRL), MXDFS=',I4,5X,           &
     &'***** KUTOO=',I2,                                                &
     &' *****'/'     NCYC GR     T    TP      MNF  MNR',                &
     &6(3X,'I(R)  F(A,...)'))
10100 FORMAT(/' **** SLATER MULTIPOLE EXPANSION LIMITED TO LAMDA=',I5/)
10110 FORMAT(I5,3I4,25X,I3,I6,I3)
10120 FORMAT(/' SR.ALGEB2: *MAXRK TOO SMALL, ARRAYS DRK AND NRK ')
10130 FORMAT(/' SR.ALGEB2: *MXRKS TOO SMALL, ARRAYS DRKS AND NRKS ')
10140 FORMAT(/' SR.ALGEB2: *MAXRK TOO SMALL, ARRAYS DRK AND NRK;'/      &
     &   ' MAYBE SUFFICIENT IF NO RADIATIVE RATES (MPRINT=-2) REQUIRED.'&
     &   )
10150 FORMAT(//' **** SR.ALGEB2: STORAGE EXCEEDED - UNABLE TO ALLOCATE',&
     &       ' ANY MORE MEMORY - REDUCE SIZE OF PROBLEM ****'//)
10160 FORMAT(/' SR.ALGEB2: *MAXRK TOO SMALL, ARRAYS DRK AND NRK;'/' ',  &
     &    'MAYBE SUFFICIENT IF NO RADIATIVE RATES (MPRINT=-2) OR DIPOLE'&
     &    ,' ONLY (MPRINT=-1) REQUIRED')
10170 FORMAT(/' SR.ALGEB2: *MAXRL TOO SMALL, ARRAYS DRL AND QRL')
10180 FORMAT(/' SR.ALGEB2: *MXRLS TOO SMALL, ARRAYS DRLS AND QRLS')
10190 FORMAT(/28X,'WARNING: SHORTAGE OF BUFFER SPACE RESULTS IN ',      &
     &       'EXCESSIVE SCANNING'/28X,                                  &
     &       '*******  THIS CASE MAY BE FASTER IF',                     &
     &       ' YOU CHOOSE MAXRL .GT.',I6)
10200 FORMAT(/28X,'WARNING: SHORTAGE OF BUFFER SPACE RESULTS IN ',      &
     &       'EXCESSIVE SCANNING'/28X,                                  &
     &       '*******  THIS CASE MAY BE FASTER IF',                     &
     &       ' YOU CHOOSE TO INCREASE MAXRL')
10210 FORMAT(' NOTE: ALLOCATION IN SR.DIAGON WILL INCREASE SIZE OF',    &
     &       ' SL MATRIX MAXDI AS BELOW')
10220 FORMAT(' ',56X,'GROUP=',I3,4X,'2S+1=',I2,2X,'L=',I2,3X,'PI=',I2,  &
     &       4X,'NC=',I6//)
10230 FORMAT(/73X,'(',I6,')',I11,7X,'MAXDI=',I11)
10240 FORMAT(/68X,'(',I11,')',I11,7X,'MAXUC=',I11)
10250 FORMAT(/81X,I11,7X,'MXAAI=',I11)
10260 FORMAT(' NOTE: ALLOCATION IN SR.DIAGON WILL INCREASE NO. OF ',    &
     &     'MATRIX ELEMENTS MAXUC AS ABOVE, IF RADIATIVE RATES REQUIRED'&
     &     )
10270 FORMAT(/' SR.ALGEB2: INCREASE MXAAI OR MAXDI - SEE ABOVE')
10280 FORMAT(/' TOO MANY BOUND-FREE INTERACTIONS, EXPECT ',             &
     &       'ALLOCATION IN ','DIAGON, TO INCREASE MXAAI TO',I9)
10290 FORMAT(/' I(R)  R(  A,  B,   C,  D,  2LBD )=SLATER-INTEGRALS',7X, &
     &       'A,B,C,D=1,2,3,..15: 1S,2S,2P,..5G-ORBITAL',9X,            &
     &       'REFERENCE LIST')
10300 FORMAT(//' I(R)  R(  A,  B,   C,  D,  2LBD )=SLATER-INTEGRALS',   &
     &       ' AND ETA( A, B, C, D, 2LBD) REFERENCE LIST, KUTOO=',I2)
10310 FORMAT(//'    T 2S+1  L  (P-0/1 FOR EVEN/ODD)',8X,'CF    NT GR',  &
     &       20X,'**** TERM TABLE ****')
10320 FORMAT(' 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-MLP)/V(2K+1)')
10330 FORMAT('  IOSC     T    TP    B   D      MNF')
10340 FORMAT(I5,2X,2(I5,I4),I7,F13.5,2F19.5,6X,2I4,5X,'E',I1,I6)
10350 FORMAT(I6,I6,I6,I5,I4,I9)
10360 FORMAT(/' *** PRINTOUT OF COEFFICIENTS SUPPRESSED - MPRINT',      &
     &       '(MODULO 5)=',I2/)
10370 FORMAT(3I2,I5,I5,F18.6,3X,A4)
10380 FORMAT(2I2,2X,2I2,2I5,F18.8,3X,A4)
10390 FORMAT(//' SR.ALGEB2: ALLOCATION INCREASES MAX 2K-POLE ',         &
     &       'RADIATION IXBLM =',I3,' .GT. MXBLM =',I3)
10400 FORMAT(/' SR.ALGEB2: RADIATIVE CALCULATIONS SKIPPED'/12X,30('*'))
10410 FORMAT(//1X,136('-')//)
10420 FORMAT(' *** USER-SUPPLIED TERM SYMMETRY RESTRICTIONS:'//)
10430 FORMAT('    T 2S+1  L  (P-0/1 FOR EVEN/ODD)')
10440 FORMAT(1X,4I4)
10450 FORMAT(' MINST =',I2,3X,'MAXST =',I2,5X,'MINLT =',I2,3X,'MAXLT =',&
     &       I2)
10460 FORMAT(' *** USER-SUPPLIED PARENT TERM SYMMETRY RESTRICTIONS:'//)
10470 FORMAT(' MINSTP=',I2,3X,'MAXSTP=',I2,5X,'MINLTP=',I2,3X,'MAXLTP=',&
     &       I2)
10480 FORMAT(' CF=',I3/)
10490 FORMAT(/'*** ALGEB2: YOU HAVE FLAGGED READ OF AN OLD TERMS',      &
     &       ' FILE, BUT NONE CAN BE FOUND...'/12X,                     &
     &       'SWITCH-OFF FLAG AND',                                     &
     &      ' RE-RUN (FOR ENERGIES ONLY) TO GENERATE ONE (EFFEICIENTLY)'&
     &      )
!w 1121 FORMAT(/'*** IN LARGE CASES IT IS MORE EFFICIENT TO READ A'
!w     X,' "TERMS" FILE GENERATED BY A PRIOR (ENERGIES ONLY) RUN')
10500 FORMAT(' *** USER-SUPPLIED (SPECTATOR) SUB-SHELL TERM ',          &
     &       'RESTRICTIONS:'//)
10510 FORMAT(' GAM',' NE',2X,'2S+1',' L')
10520 FORMAT(I4,I3,3X,I3,I2)
10530 FORMAT(' GAM',' NE')
10540 FORMAT(//' MINSTS=',I2,3X,'MAXSTS=',I2,5X,'MINLTS=',I2,3X,        &
     &       'MAXLTS=',I2)
10550 FORMAT(/86X,I10,'=MTGD, MAXDC=',I10,' BUFFER STORAGE USED')
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION MVC(M1,M2)
!
      INTEGER(SP) M1,M2,MVC
!
      MVC=((M1+2)*M1/2+M2)/2+1
!
      END FUNCTION MVC
!-----------------------------------------------------------------------
!
      END SUBROUTINE ALGEB2
!
!                             *******************
!
      SUBROUTINE ALGEB3(MAM,NAM,QLMC,QBML,QBMS,JYI,JYF,MAXEL)
!
!-----------------------------------------------------------------------
!
!  SR.ALGEB3 DEALS WITH THE CALCULATION OF THE ALGEBRA OF THE FINE
!  STRUCTURE INTERACTIONS (SPIN-ORBIT,RESIDUAL MUTUAL-SPIN-ORBIT AND
!  SPIN-SPIN). NOW SOLVES SLATER-STATE PROBLEM BY LSJP GROUP - NRB.
!
!  IT IS CALLED BY:
!    SR.ALGEB
!
!  IT CALLS:
!    SR.DISKDC
!    SR.DIMUSE
!    SR.NRB_TIME
!    SR.RES1
!    SR.RES2
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!    SR.SPOR0
!    SR.SPOR1
!    SR.SPOR1F
!    SR.SPOR2
!    FN.VCC
!
!  IT CONTAINS:
!    FN.MVC
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam                            !par
!
      USE COMMON_ALGEB,  ONLY: MPRINT
      USE COMMON_ALGEB,  ONLY: MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD     &
     &                        ,KFBUFF
      USE COMMON_ALGEB,  ONLY: BFOT
!!      COMMON /BASIC/NF,KF,KG,J1,J2,J1P,J2P,JGAP,NJ2,NJP2,MGAP(2)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,J1=>IBSK4,J2=>IBSK5            &
     &              ,J1P=>IBSK6,J2P=>IBSK7,IBSK8=>IBSK8,NJ2=>IBSK9      &
     &              ,NJP2=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_CFCT,   ONLY: VCA,VCB,MXLL,MAXLL0,MAXLL1,BVC,BDLBD
      USE COMMON_COEFF,  ONLY: DRKP,QRLP,IRLP,NRKP,NADP                 &
     &                        ,MXSOC0,MXSOI0
      USE COMMON_COEFF,  ONLY: IRKP,IRKP0
      USE COMMON_COEFFS, ONLY: DRKPS,QRLPS,NRKPS                        &
     &                        ,MXS1C0,MXS1I0
      USE COMMON_COEFFS, ONLY: IRKPS,IRKPS0,IRLPS,IRLPS0
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DC,     ONLY: BFAST,DC,IDC,IXIDC
      USE COMMON_DMQSS3, ONLY: DSS,MSS,QSS,NADR,MAXMI0,MXRSS0
      USE COMMON_DMQSS3, ONLY: IRS,IRS0,NL,NL000
      USE COMMON_DMQSSS, ONLY: DSSS,MSSS,QSSS,MXS2I0,MXS2C0
      USE COMMON_DMQSSS, ONLY: IRSS,IRSS0,NLS,NLS00
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR,NTJ,NFJ,JAXLV
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_NSTS1,  ONLY: NADS1,NSTJ1,NSTJ1D,IORIG1,JORIG1
      USE COMMON_NSTS2,  ONLY: NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2
      USE COMMON_QTG,    ONLY: MTGD,NXLL,NTT,NTG,JTGD,QTGS,QTGL,QTGD    &
     &                        ,NFI,NFK,NFQ
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      use common_misc,   only: iw,iwp,btime,btimex
!
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL2, ONLY: MDEL,MXORBR,MPOL00,MPOL0,MPOLE,MPOLX,CODE
      USE COMMON_NRBAL2, ONLY: MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBAL3, ONLY: MCFSS,KCFSS,KUTSS,KUTSO,QQCUT
      USE COMMON_NRBAL3, ONLY: DVC12,ICLRS,ICLRR,BLX
      USE COMMON_NRBAL4, ONLY: MBP1MX,MBP2MX,MEKVMX,KUTM1,MPOLM,QCUT
      USE COMMON_NRBDW,  ONLY: IDW,btop
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBFL0, ONLY: KINTI,KINTF,KEN2,KPTCFM,KINT,MPOINT      &
     &                        ,MXSTX0
      USE COMMON_NRBGCF, ONLY: KGSL,KGCF,NKSL
      USE COMMON_NRBGRJ, ONLY: NSLJ,NGSLJ
      USE COMMON_NRBIAD, ONLY: IADJ,IADJ8,NP8
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,NASTJ                           &
     &                        ,MINJT,MAXJT,NEIGENJ
      USE COMMON_NRBKUT, ONLY: KCUTX,LSKUT,NASTK
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
      USE COMMON_NRBRN2, ONLY: BINDB,MENGB
      USE COMMON_NRBVAL, ONLY: BRAD,BAUGER
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,IBUFF4
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M6)
      PARAMETER (TTYNY=TYNY/D1P3)
!
      INTEGER(SP) SJ,SJP
!
      INTEGER(EP) N8,nctot
!
      CHARACTER(LEN=1) LIT
      CHARACTER(LEN=4) MBLANK,MYRGE
!
      LOGICAL BEXJ                        !INQUIRE REQUIRES DEFAULT KIND
!
      DIMENSION MAM(*),NAM(*),JYI(*),JYF(*)                             &
     &         ,QLMC(MAXEL,*),QBML(*),QBMS(*)                           &
     &         ,nej(2),mej(2)
!
      DIMENSION LIT(8)
!
      ALLOCATABLE :: B1B(:),B2B(:),KSTART(:,:),QJI(:)
      allocatable :: ncc0(:),iorb(:)
!
      DATA MBLANK/'    '/
      DATA LIT(1),LIT(2),LIT(3),LIT(4)/' ','A','B','C'/
      DATA LIT(5),LIT(6),LIT(7),LIT(8)/'*','a','b','c'/
!
!-----------------------------------------------------------------------
!
      itest4=ibuff4
      itest4=itest4+1
!
      if(iunit(MR12).ne.0)then                               !for radwin
        n69=69
      else
!        n69=79                        !needs radwin present if external
        n69=69           !restrict to 60-9 normally, can extend to 79...
      endif
      n69=-n69                            !as likely superceded by kutls
!
!     IF ABS(MODD).GT.1 NOT ENOUGH VCC'S ARE  AVAILABLE FOR CALCULATING
!     FINESTRUCTURE INTERACTIONS.
!
      NJO=0
      IF(ABS(MODD).GT.1)THEN
        WRITE(MW6,10010)
        GO TO 2100                                  !RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
! INITIALIZATIONS
!
!-----------------------------------------------------------------------
!
      BPRINT=MPRINT.GT.0.OR.MPRINT.EQ.0.AND.IDW.EQ.0
!
      BKUTLS=KUTLS.LT.0                          !.T. FOR SINGLE CF MIX
!
!      BFAST=DC(0).LT.DZERO                 !ELSE OPT MEMORY
!
      MOD3=MODD                  !CAN RE-SET TO TEST VARIOUS TOTAL MJ
!      mod3=1                     !MODD.LE.0 NOW
      BMOD3=(MOD3+1)/2.EQ.1      !SLOWER
!
      BFASTSO=KUTSS.EQ.-1        !IF NO 2-BODY PRE-SET 1-BODY SO SS INTS
!      bfastso=.false.           !force if .true. uses too much memory
      IF(BFASTSO)NSS=JYF(KMAX)
!
!     ALIGNS TO THE DEFAULT REQUIREMENTS FOR KUTSS=0 AND -1
!
      MKT=KUTSS
      IF((MKT+3)/2.EQ.1)MKT=1+MKT
      MUTSO=KUTSO
      MUTSO=ABS(MUTSO)
!
! Test swap bra/ket. This is because there is an apparent anti/symmetry
! in the N-coefficient/integral combinations which is not readily taken
! into account. This means that the H symmetry is not readily apparent,
! which needs to be recognized when comparing with algxfs.
!
      bswap=.false.
!
      BLX=.FALSE.
      MPRNT1=MPRINT
      IF(MPRNT1.EQ.0.AND.MENGB.GE.0)MPRNT1=-1                !I.E. BBORN
!
!-----------------------------------------------------------------------
!
! DETERMINE NUMBER OF JP GROUPS AND LEVELS
!
!-----------------------------------------------------------------------
!
      JACT=QCL0+QCS0
!
      NJO=0                                        !TOT NUMBER OF GROUPS
      NJ=0                                         !TOT NUMBER OF LEVELS
!
  100 KPI=0
!
  200 IF(NASTJ.GT.0)THEN                                  !SELECT BY JPI
        JT=10*JACT+KPI/2
        DO I=1,NASTJ
          IF(JT.EQ.JPI(I))GO TO 300                                !WANT
        ENDDO
        GO TO 400                                            !DON'T WANT
      ELSEIF(NASTJ.LT.0)THEN                      !SELECT BY MINJT,MAXJT
        IF(JACT.LT.MINJT.OR.JACT.GT.MAXJT)GO TO 400          !DON'T WANT
      ENDIF
!
  300 N0=0                                    !NUMBER OF LEVELS IN GROUP
      NDJ=NJO+1                                         !JP GROUP NUMBER
!
!      IT=0
      DO I=1,NSL0
        NC=NSL(I)
!        IT=IT+NC
        IF(QPI(I).EQ.KPI)THEN
          LJ=QLI(I)
          SJ=QSI(I)
          IF(ABS(LJ-SJ).LE.JACT.AND.(LJ+SJ).GE.JACT)THEN
            NJ=NJ+NC
            N0=N0+NC
          ENDIF
        ENDIF
      ENDDO
!
      IF(N0.GT.0)THEN
!        WRITE(MW6,181)NDJ,JACT,KPI/2,N0
        NJO=NDJ
      ENDIF
!
  400 KPI=KPI+2
      IF(KPI.EQ.2)GO TO 200              !LOOP BACK UP FOR SECOND PARITY
!
      JACT=JACT-2
      IF(JACT.GE.0)GO TO 100                   !LOOP BACK UP FOR NEXT 2J
!
      NLEV=NJ
!
      IAXJG=NJO
      IAXLV=NLEV
!
!-----------------------------------------------------------------------
!
! EX-COMMON/JSPOR/
      ALLOCATE(NRR(NLEV+1),NT(NJO),JN(NLEV),NGR(NLEV),STAT=IERR)    !+1
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB3: ALLOCATION FAILS FOR NJO,NRR,NT,JN,NGR'
        NF=0
        RETURN
      ENDIF
!
! EX-COMMON/QTG/
      ALLOCATE(NTJ(KMAX),NFJ(NLEV),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB3: ALLOCATION FAILS FOR NTJ,NFJ'
        NF=0
        RETURN
      ENDIF
!
! EX-COMMON/NRBDWM/
      ALLOCATE(NMETGJ(NJO),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB3: ALLOCATION FAILS FOR NMETGJ'
        NF=0
        RETURN
      ENDIF
!
! EX-COMMON/NRBGRJ/
      ALLOCATE(NSLJ(NSL0,NJO),NGSLJ(NJO),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB3: ALLOCATION FAILS FOR NSLJ,NGSLJ'
        NF=0
        RETURN
      ENDIF
!
! LOCAL
      ALLOCATE(QJI(NJO))
!
! local, as recalculated in sr.diagon (ex-common/nrbtmp/)
      allocate(ncc0(mxorb),iorb(0:mxorb),stat=ierr)
!
      if(ierr.ne.0)then
        write(mw0,*)'algeb3: allocation fails for  ncc0,iorb'
        nf=0
        return
      endif
!
!-----------------------------------------------------------------------
!
      DO J=1,IAXJG
        NMETGJ(J)=0
        DO I=1,IAXSL
          NSLJ(I,J)=0            !AS NOT ALL SLP CONTRIB TO ANY GIVEN JP
        ENDDO
      ENDDO
!
      IF(NASTJ.NE.0)THEN
        WRITE(MW6,10220)
        WRITE(MW6,10230)
        IF(NASTJ.GT.0)THEN
          WRITE(MW6,10240)
          DO I=1,NASTJ
            IJ=JPI(I)/10
            IP=JPI(I)-IJ*10
            WRITE(MW6,10250)I,IJ,IP
          ENDDO
        ELSE
          WRITE(MW6,10260)MINJT,MAXJT
        ENDIF
        WRITE(MW6,10220)
      ENDIF
!
!-----------------------------------------------------------------------
!
! THE FOLLOWING SECTION SETS UP THE STATES ACCORDING TO THEIR
! J-VALUES: J=TOTAL ANGULAR MOMENTUM.
!
!-----------------------------------------------------------------------
!
      JACT=QCL0+QCS0
      WRITE(MW6,10170)
!
      NJO=0
      NJ=0
      NP8=0
      NCTOT=0
      ISXDK=1
      IAXDK=1
      IAXJU=0
      IXAAK=0
!      lusum=0
      bcont=.false.
!
  500 KPI=0
!
  600 IF(NASTJ.GT.0)THEN                                  !SELECT BY JPI
        JT=10*JACT+KPI/2
        DO I=1,NASTJ
          IF(JT.EQ.JPI(I))GO TO 700                                !WANT
        ENDDO
        GO TO 900                                            !DON'T WANT
      ELSEIF(NASTJ.LT.0)THEN                      !SELECT BY MINJT,MAXJT
        IF(JACT.LT.MINJT.OR.JACT.GT.MAXJT)GO TO 900          !DON'T WANT
      ENDIF
!
  700 N0=0
      NCC=0
      NDJ=NJO+1                                  !NDJ IS JP GROUP NUMBER
      BVC=NDJ.GT.IAXJG
      IF(.NOT.BVC)NGSLJ(NDJ)=0
!
!      if(bkutls)then
      do k=1,kmax
        ntj(k)=0
      enddo
!      else
      do i=1,mxorb
        ncc0(i)=0
      enddo
      mx0=mxorb+1
!      endif
      lu=0
!
! LOOP TO FIND NUMBER OF LEVELS WHICH CAN RESULT IN GIVEN J
!
      IT=0
      DO I=1,NSL0
        NC=NSL(I)
        IT=IT+NC
        IF(QPI(I).NE.KPI)GO TO 800
!
        LJ=QLI(I)
        SJ=QSI(I)
        IF(ABS(LJ-SJ).GT.JACT.OR.(LJ+SJ).LT.JACT)GO TO 800
!
        IT=IT-NC
        IF(.NOT.BVC)THEN
          NGSLJ(NDJ)=NGSLJ(NDJ)+1
          NSLJ(NGSLJ(NDJ),NDJ)=I
        ENDIF
!
        nc0=ncc
        N00=0
        DO N=1,NC
!
          IT=IT+1
          NJ=NJ+1
          KG=NFK(IT)
          II=QCG(NF,KG)
          ii=ieq(ii)
          IF(QN(II).GE.90)THEN
            NCC=NCC+1
            ncc0(ii)=ncc0(ii)+1
            mx0=min(mx0,ii)
          ELSE
            N00=N00+1
          ENDIF
          ntj(kg)=ntj(kg)+1
!
          if(bprint)WRITE(MW6,10120)NJ,SJ+1,LJ/2,JACT,KG,IT
!
          BLF=NJ.GT.IAXLV
          IF(.NOT.BLF)THEN
            NRR(NJ)=IT
            JN(NJ)=JACT
            NGR(NJ)=NDJ
          ENDIF
!
        ENDDO
        N0=N0+N00
        lu=lu+n00*(ncc-nc0)                     !if no 2-fs
!
  800 ENDDO
!
      IF(N0+ncc.GT.0)THEN
!
        if(bkutls)then
!
          n0=n0+ncc
!
          ncft0=0
          ncft=0
          do k=1,kmax
            ncf0=ntj(k)
            isxdk=max(isxdk,ncf0)
            ncft=ncft+ncf0*ncf0
            N8=ncf0
            NP8=NP8+((N8+1)*N8)/2
            if(.not.bfot)then
              II=QCG(NF,K)
              ii=ieq(ii)
              if(qn(ii).lt.90)ncft0=ncft0+ncf0*ncf0
!        write(mw6,*)nn,k,ncft0,ncft,qn(ii)
            endif
          enddo
!
          if(bfot)then                          !need c-c e-vectors
            nctot=nctot+ncft
          else                                  !only b-b
            n8=nctot+ncft
            iaxju=max(iaxju,int(n8,ep))         !but need buffer
            nctot=nctot+ncft0                   !so can overwite c-c
          endif
!
        else
!
          N8=N0                                   !not strictly true but
          if(n8*n8.gt.ibuff4.and.itest4.lt.ibuff4)then     !time for I*8
            write(mw0,*)                                                &
     &         'sr.algeb3: I*4 will overflow for diagfs tfu array index'
            go to 2700
          endif
          NP8=NP8+((N8+1)*N8)/2
          isxdk=max(isxdk,n0)
          iorb(mx0-1)=n0*n0                     !I*4 overflow anyway...
          do i=mx0,mxorb
            n=ncc0(i)
            iorb(i)=iorb(i-1)+n*n
            if(n.gt.0)then
              n8=n
              np8=np8+((n8+1)*n8)/2
              isxdk=max(isxdk,n)
              n0=n0+n
            endif
          enddo
!
          if(bfot)then                          !need c-c e-vectors
            nctot=nctot+iorb(mxorb)
          else                                  !only b-b
            n8=nctot+iorb(mxorb)
            iaxju=max(iaxju,int(n8,ep))         !but need c-c buffer
            nctot=nctot+iorb(mx0-1)             !so can overwite c-c
          endif
!
        endif
!
        WRITE(MW6,10130)NDJ,JACT,KPI/2,N0
!
        IAXDK=MAX(IAXDK,N0)
        IF(N0.GT.MAXDK)THEN
          IF(MAXDK.GT.0)WRITE(MW6,10200)
        ENDIF
!
        IF(BAUGER)THEN
          IF(.NOT.BFASTSO)THEN
            LU=NCC*(N0-NCC)   !WE HAVE 2-FS, NEED ND.NE.NC B-C INTERCTNS
            NP8=NP8+INT(LU,EP)   !& NEED 2-FS POINTERS (SKIP IF LS ONLY)
          ENDIF
          IXAAK=MAX(LU,IXAAK)
!
!          lusum=lusum+lu
!          write(mw6,*)lu,np8
!          write(mw6,*)'lusum=',lusum
        ENDIF
!
        bcont=bcont.or.ncc.gt.0
!
        NJO=NDJ
        IF(.NOT.BVC)THEN
          NT(NDJ)=N0
          QJI(NDJ)=INT(JACT,QP)
        ENDIF
      ENDIF
!
  900 KPI=KPI+2
      IF(KPI.EQ.2)GO TO 600              !LOOP BACK UP FOR SECOND PARITY
!
      JACT=JACT-2
      IF(JACT.GE.0)GO TO 500                   !LOOP BACK UP FOR NEXT 2J
!                                                 !END JP SYMMETRY LOOPS
!
      if(nj.ne.iaxlv.or.njo.ne.iaxjg)then
        write(mw0,*)njo,iaxjg,nj,iaxlv
        stop '***algeb3: mis-match in levels/groups'
      endif
!
      NLEV=NJ
!
      CALL DIMUSE('MAXLV',NLEV)
      IF(IAXLV.GT.MAXLV)THEN
        IF(MAXLV.GT.0)WRITE(MW6,10180)IAXLV,MAXLV
      ENDIF
!
      CALL DIMUSE('MAXJG',NJO)
      IF(IAXJG.GT.MAXJG)THEN
        IF(MAXJG.GT.0)WRITE(MW6,10190)IAXJG,MAXJG
      ENDIF
!
      IADJ8=NP8
      IADJ=INT(IADJ8,SP)                               !FOR I*4 BRANCHES
!
      CALL DIMUSE('MXADJ',IADJ)
      IF(IADJ8.GT.MXADJ)THEN
        IF(MXADJ.GT.0)WRITE(MW6,10450)IADJ8,MXADJ
      ENDIF
!
! THESE 3 DIMENSIONS ARE FOR INFO ONLY. NOT NEEDED UNTIL DIAGFS.
! NOTE: IF MODE=3 OR 4 IS SET IN MINIM THEN THE ACTUAL DIMENSIONS
! REQUIRED (ALLOCATED F95) WILL BE LARGER. THESE MODES ARE (SMALL)
! TEST CASES, NOT PRODUCTION RUNS, SO NOT LIKELY AN ISSUE. WOULD
! NEED USER TO SET MODE IN ALGEB, AND CODE DIAGFS DIMENSION VARIATION.
!
      if(bfot)iaxju=nctot
      WRITE(MW6,10070)ISXDK,IAXDK,MAXDK
      WRITE(MW6,10100)NCTOT,IAXJU,MAXJU
      WRITE(MW6,10080)IXAAK,MXAAK
!
      if(iaxju.gt.ibuff4.and.itest4.lt.ibuff4)then
        write(mw0,*)                                                    &
     &         'sr.algeb3: I*4 will overflow for diagfs tfu array index'
        go to 2700
      endif
!
      IF(IAXJU.GT.MAXJU)THEN
        IF(MAXJU.GT.0)WRITE(MW6,10090)
      ENDIF
!
      IF(IXAAK.GT.MXAAK)THEN
        IF(MXAAK.GT.0)WRITE(MW6,10160)IXAAK
      ENDIF
!
      IF(BLX)THEN                                    !NO LONGER POSSIBLE
        WRITE(MW6,10110)
        WRITE(MW0,*)'*** INCREASE MXAAK OR MAXDK'
        GO TO 2800
      ENDIF
!
! local (ex-common/nrbtmp/)
      deallocate(ncc0,iorb,stat=ierr)
!
      if(ierr.ne.0)then
        write(mw0,*)'algeb2: de-allocation fails for  ncc0,iorb'
        nf=0
        return
      endif
!
!     INDEX POSITION OF LEVEL WITHIN A CONFIG.
!
      DO K=1,KMAX
        NTJ(K)=0
        DO J=1,NLEV
          IT=NRR(J)
          IF(NFK(IT).EQ.K)THEN
            NTJ(K)=NTJ(K)+1
            NFJ(J)=NTJ(K)
          ENDIF
        ENDDO
      ENDDO
!
!-----------------------------------------------------------------------
!
! SET METASTABLE jp GROUPS BASED-ON PRE-EXISTING LEVELS FILE
! SO AS TO RESTRICT UNNECESSARY MK EVALUATION ETC.
!
!-----------------------------------------------------------------------
!
      IF(NMETAJ.LT.0.AND..NOT.BVC)THEN
!        NMETJ0=NMETAJ
        NMETAJ=-NMETAJ
        INQUIRE(FILE='LEVELS',EXIST=BEXJ)
        IF(BEXJ)THEN
          OPEN(MRW15,FILE='LEVELS',STATUS='OLD')
          READ(MRW15,*,END=940)
          DO K=1,NJO                             !ASSUME WE CAN RESTRICT
            NMETGJ(K)=1
          ENDDO
          READ(MRW15,10210,END=940)JSP,IP0,IS0,LS0,ICF0,NDUM,DUM,MYRGE
          IS0=ABS(IS0)
          REWIND(MRW15)
          READ(MRW15,*,END=940)
          DO N=1,NMETAJ
            READ(MRW15,10210,END=940)JSP,IPP,ISP,LSP,ICF,NDUM,DUM,MYRGE
            IF(MYRGE.NE.MBLANK)THEN                     !CANNOT RESTRICT
              DO K=1,NJO
                NMETGJ(K)=0
              ENDDO
              GO TO 940
            ENDIF
            ISP=ABS(ISP)
            IF(ISP.GT.0)THEN
              IF(NMETAJ/JAXLV.GT.0)THEN
                IF(ISP.NE.IS0.OR.LSP.NE.LS0.OR.IPP.NE.IP0.OR.           &
     &             ICF.NE.ICF0)GO TO 940
                ICF0=ICF
                IS0=ISP
                LS0=LSP
                IP0=IPP
              ENDIF
              ISP=ISP-1
              LSP=LSP+LSP
              IPP=IPP+IPP
              DO KK=1,NJO
                IF(JSP.EQ.QJI(KK))THEN
                  KP=NSLJ(1,KK)
                  IF(IPP.EQ.QPI(KP))THEN
                    NMETGJ(KK)=0
                    DO KP=1,NGSLJ(KK)
                      K=NSLJ(KP,KK)
                      if(nmetag(k).ne.0)stop 'algeb3: nmetag error'
                      NMETAG(K)=0
                    ENDDO
                    GO TO 920
                  ENDIF
                ENDIF
              ENDDO
            ELSE
              GO TO 940
            ENDIF
  920     ENDDO
  940     CLOSE(MRW15)
          IUNIT(MRW15)=-1
!          NMETAJ=NMETJ0                                     !RE-INSTATE
!          write(mw6,*)'jp groups'
!          do k=1,njo
!            write(mw6,*)k,nmetgj(k)
!          enddo
!          write(mw6,*)'lsp groups'
!          do k=1,nsl0
!            write(mw6,*)k,nmetag(k)
!          enddo
        ELSE
          WRITE(MW6,10270)
          WRITE(MW0,10270)
        ENDIF
!w      ELSE
!w        IF(IDW.NE.0.AND.NMETAJ.GT.0)THEN
!w          WRITE(MW6,1123)
!w          WRITE(MW0,1123)
!w        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
! FLAG EXISTENCE, OR NOT, OF ONE- AND TWO-BODY INTERACTIONS BETWEEN
! CONFIGURATION PAIRS
!
!-----------------------------------------------------------------------
!
! LOCAL
      IXD19=(KMAX*(KMAX+1))/2
!
      ALLOCATE(B1B(IXD19),B2B(IXD19),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB3: ALLOCATION FAILS FOR B1B,B2B'
        NF=0
        GO TO 2100
      ENDIF
!
!!      iflagc=0
      KK=0
      DO KF=1,KMAX                                        !BEGIN KF LOOP
        II=IEQ(QCG(NF,KF))
        KCF=0
        IF(QN(II).GE.90)KCF=II                                !CONTINUUM
        if(qn(ii).ge.60.and.qn(ii).le.n69)kcf=-ii           !omit ryd ci
!!        iflagc=max(iflagc,kcf)
!
        DO KG=1,KF                                        !BEGIN KG LOOP
          KK=KK+1
          B1BODY=.FALSE.
          B2BODY=.FALSE.
!
          II=IEQ(QCG(NF,KG))
          KCG=0
          IF(QN(II).GE.90)KCG=II
          if(qn(ii).ge.60.and.qn(ii).le.n69)kcg=-ii         !omit ryd ci
!
! OMIT CONT-CONT'
          IF(KCF.NE.KCG.AND.KCF*KCG.NE.0)GO TO 1000    !DOES NOT CONTRIB
          IF(.NOT.BAUGER.AND.KCF.NE.KCG.AND.(KCF.GT.0.OR.KCG.GT.0))     &
     &       GO TO 1000                                       !NO AUGERS
          if(kcf.ne.kcg.and.(kcf+kcg).lt.0)go to 1000
!
! omit corr-corr'
          if(kcutx.gt.0.and.kf.ne.kg.and.kg.gt.kcut)go to 1000
!!                   .and.kcf+kcg+iflagc.gt.0
!
! single cf mixing (but keeping b-c)
          if(kf.ne.kg.and.(kcf+kcg.eq.0.or.kcf*kcg.ne.0))then
            if(kf.gt.kutls)go to 1000
            if(kg.gt.kutls)go to 1000
          endif
!
          IF(JYI(KG).GT.JYF(KG))GO TO 1000                  !NULL CONFIG
!
          IF(KUTSO.GT.0)THEN
            IF(KF.GT.MUTSO.OR.KG.GT.MUTSO)THEN
              IF(KF.NE.KG)GO TO 1000
            ENDIF
          ELSEIF(KUTSO.LT.0)THEN
            IF(KF.NE.KG)GO TO 1000
            IF(KF.GT.MUTSO)GO TO 1000
          ENDIF
!
! NOW, FIND NUMBER MK/2 OF ELECTRON PAIRS IN WHICH KF, KG DIFFER
!
          DO M=1,NF
            QLMC(M,1)=QCG(M,KG)
          ENDDO
          MK=0
          DO M=1,NF
            ICG=IEQ(QCG(M,KF))
            DO L=1,NF
              IF(IEQ(QLMC(L,1)).EQ.ICG)THEN
                QLMC(L,1)=0
                GO TO 960
              ENDIF
            ENDDO
            MK=MK+2
            IF(MK.EQ.2)LD1=QCG(M,KF)
  960     ENDDO
!
          IF(MK.GT.4)GO TO 1000                     !THREE PAIRS OR MORE
          IF(MK-4.EQ.0.AND.MKT.GE.0)GO TO 1000     !TWO, BUT NO TWO-BODY
!
! SEE IF WE NEED TWO-BODY
!
          IF(-MKT.LT.KMAX)THEN                      !AS -1 -> 0
            IF(MKT.GE.0.AND.MK.NE.0)GO TO 980
            IF(KCFSS(KF)*KCFSS(KG).LE.0)THEN
              IF(KF.GT.ABS(MKT))GO TO 980
              IF(KG.GT.ABS(MKT))GO TO 980
            ENDIF
          ENDIF
          IF(NF.GT.1)B2BODY=.TRUE.
  980     IF(.NOT.B2BODY.AND.MK.EQ.4)GO TO 1000
!
! SEE IF ONE-BODY EXISTS
!
          IF(MK.EQ.2)THEN
            DO L=1,NF
              IF(QLMC(L,1).NE.0)THEN
                LD2=QCG(L,KG)
                GO TO 990
              ENDIF
            ENDDO
            write(mw6,*)'algeb3: should not be here - report to nrb'
            write(mw0,*)'algeb3: should not be here - report to nrb'
  990       IF(QL(LD1).NE.QL(LD2))THEN
              IF(.NOT.B2BODY)GO TO 1000
              LDD=-1
            ELSE
              LDD=QL(LD1)
            ENDIF
          ELSEIF(MK.EQ.4)THEN
            LDD=-1
          ELSE
            LDD=1
          ENDIF
          B1BODY=LDD.GT.0
!
! FLAG WHETHER KF-KG NEEDED
!
 1000     B1B(KK)=B1BODY
          B2B(KK)=B2BODY
!
        ENDDO                                   !END LOOP KG
!
      ENDDO                                     !END LOOP KF
!
!-----------------------------------------------------------------------
!
! SET-UP LOCATIONS OF ONE-BODY SPIN-ORBIT SLATER-SLATE INTERACTIONS
!
!-----------------------------------------------------------------------
!
      KINT=0
      IF(.NOT.BFASTSO)GO TO 1100                !SKIP
!
! SET POINTERS TO ML BOUNDARIES
!
!
! EX-COMMON/NRBFL0/
!
      IXD02=QCL0/2
      IXD03=IXD02+1
      IF(KUTSO.EQ.-1)THEN      !NORMAL
        IXD19=KMAX
      ELSE         !MAXIMAL FOR KUTSO=0, COULD REDUCE ELSEWISE
        IXD19=(KMAX*(KMAX+1))/2
      ENDIF
!
      IXSTX=MAX(MXSTX0,MXSTX,IXSTX)               !USE LARGEST PREVIOUS
!      IXSTX=MAX(MXSTX0,MXSTX)                     !RESET
      ALLOCATE(KINTI(IXSTX),KINTF(IXSTX),KEN2(IXSTX),                   &
     &         KPTCFM(-IXD02:IXD03,-IXD02:IXD03,0:IXD19),               &
     &         MPOINT(-IXD02:IXD03,KMAX),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB3: ALLOCATION FAILS FOR KPTCFM,MPOINT ETC.'
        NF=0
        GO TO 2100
      ENDIF
!
!-----------------------------------------------------------------------
!
      IF(MPRINT.LT.-2)GO TO 1100             !SKIP MXSTX DIMENSION CHECK
!
!-----------------------------------------------------------------------
!
      DO K=1,KMAX
        J=JYI(K)
        ML0=QBML(J)
        ML=ML0/2
        J=J-1
        DO M=IXD03,ML,-1
          MPOINT(M,K)=J
        ENDDO
        DO J=JYI(K),JYF(K)
          ML=QBML(J)
          IF(ML.LT.ML0)THEN
            ML0=ML0/2
            ML1=1+ML/2
            DO M=ML0,ML1,-1
              MPOINT(M,K)=J-1
            ENDDO
            ML0=ML
          ENDIF
        ENDDO
        ML=ML/2
        MPOINT(ML,K)=JYF(K)
        ML=ML-1
        DO M=ML,-IXD02,-1
          MPOINT(M,K)=JYF(K)
        ENDDO
      ENDDO
!
! SET-UP POINTERS TO 1-BODY SLATER-STATE INTERACTIONS
!
      KK=0
      KPTCFM(IXD03,IXD02,1)=0
!
      if(btime)call nrb_time(timei)
!
      KB=0
      KG1=1
      DO KF=1,KMAX
        IF(KUTSO.EQ.-1)KG1=KF
        DO KG=KG1,KF
          KK=KK+1
!
          IF(B1B(KB+KG))THEN
            CALL SPOR0(KK,QLMC,QBML,QBMS,MAXEL)
            IF(NF.EQ.0)GO TO 2100
          ELSE
            DO M=IXD02,-IXD02,-1
              DO MP=IXD02,-IXD02,-1
                KPTCFM(MP,M,KK)=KINT
              ENDDO
            ENDDO
          ENDIF
!
!          write(mw0,*)'*** kg, kf, kint:',kg,kf,kint
!
          IF(KK.GT.1)KPTCFM(IXD03,IXD02,KK)=KPTCFM(-IXD02,-IXD02,KK-1)
!
          MPP=-IXD02
          DO M=IXD02-1,-IXD02,-1
            IF(KF.EQ.KG)MPP=M+1
            KPTCFM(IXD03,M,KK)=KPTCFM(MPP,M+1,KK)
!            kptcfm(ixd03,m,kk)=kptcfm(m,ixd03,kk)
          ENDDO
!
! checks and debug print (remove/comment-out eventually)
!
!          do m=ixd02,-ixd02,-1
!            if(kf.eq.kg)mpp=m
!            do mp=ixd02,mpp,-1
!              do k=kptcfm(mp+1,m,kk)+1,kptcfm(mp,m,kk)
!                if(k.gt.mxstx)stop 'increase mxstx'
!                j=kinti(k)
!                jd=kintf(k)
!                if(qbml(jd).ne.2*mp.or.qbml(j).ne.2*m)then
!                  write(mw6,*)kg,jd,mp,qbml(jd)/2,' cf j ml qbml',
!     &                      kf,j,m,qbml(j)/2,'    kint=',k
!                  stop 'algeb3: ml-mismatch'
!               endif
!              enddo
!            enddo
!          enddo
!
        ENDDO
        KB=KB+KF
      ENDDO
!
      if(btime)then
        call nrb_time(timef)
        time0=timef-timei
!
!par        if(iam.ge.0)then                                        !par
!par          write(iwp,*)'proc',iam,' for algeb3:'                 !par
!par          write(iwp,*)'    spor0 time=',nint(time0),'sec'       !par
!par          call flush(iwp)                                       !par
!par        else                                                    !par
        write(iw,*)'spor0 time=',nint(time0),'sec'
!          call flush(iw)
!par        endif                                                   !par
      endif
!
      CALL DIMUSE('MXSTX',KINT)
!
      IF(KINT.GT.IXSTX)THEN                        !SHOULDN'T HAPPEN NOW
        WRITE(MW6,*)'SR:ALGEB3: INCREASE MXSTX TO:',KINT
        WRITE(MW0,*)'INCREASE MXSTX TO:',KINT
        GO TO 2800
      ENDIF
!
 1100 CONTINUE
!
!-----------------------------------------------------------------------
!
! CHECK BUFFERS FOR DC ARRAY IF DISKDC IN USE
!
!-----------------------------------------------------------------------
!
      MDCBUF3=0
      IF(KUTDSK.LT.KMAX)THEN
        IEND=MTGD                                            !FOR DISKDC
        MTGD1=MTGD+1
        CALL DISKDC(IUD,IONE,IZERO,IZERO,IZERO,IZERO,IZERO)
                                                         !REPOINT
!
        IF(KUTDSK.LT.KFBUFF)THEN
          NGJX=0                                       !DIM FOR ALLOCATE
          DO K=1,NJO
            NGJX=MAX(NGJX,NGSLJ(K))
            MTGD1=MTGD+1                                        !RESTORE
            DO NGJ1=1,NGSLJ(K)
              NC=NSLJ(NGJ1,K)
              DO KF=KUTDSK+1,KFBUFF
                NGSYM=KGSL(KF,NC)                         !POS WITHIN CF
                IF(NGSYM.GT.0)THEN
                  ISTRT=MTGD1
!
                  CALL DISKDC(IUD,ISTRT,IFIN,KF,NGSYM,IZERO,IZERO)
!
                  MTGD1=IFIN+1
                ENDIF
              ENDDO
            ENDDO
            IFIN=MTGD1-1
            MDCBUF3=MAX(MDCBUF3,IFIN)
          ENDDO
          IF(MDCBUF3.GT.MDCBUF)THEN
!
            IXXX=MDCBUF3
!
            WRITE(MW6,*)'*** ALGEB3: increasing MAXDC from ',IAXDC,     &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** ALGEB3: increasing MAXDC from ',IAXDC,     &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC(DC,IZERO,MTGD,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'ALGEB3: RE-ALLOCATION FAILS FOR DC',IERR
              NF=0
              GO TO 2100
            ENDIF
!
            IF(.NOT.BFAST)THEN
!
              CALL RE_ALLOC(IDC,IONE,MTGD,IXXX,IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)'ALGEB3: RE-ALLOCATION FAILS FOR IDC',IERR
                NF=0
                GO TO 2100
              ENDIF
!
            ENDIF
!
            IAXDC=IXXX
            MDCBUF=IAXDC
          ENDIF
          MDCBUF3=0
        ELSE
          MDCBUF3=MDCBUF
          NGJX=0                                       !DIM FOR ALLOCATE
          DO K=1,NJO
            NGJX=MAX(NGJX,NGSLJ(K))
          ENDDO
        ENDIF
!
        ALLOCATE(KSTART(KMAX,NGJX))
!
        IF(KUTDSK.GE.KFBUFF)THEN
          DO N=1,NGJX
            DO K=KFBUFF+1,KMAX
              KSTART(K,N)=0
            ENDDO
          ENDDO
        ENDIF
!
      ENDIF
!
      IF(MDCBUF3.GT.0)CALL DIMUSE('MAXDC',MDCBUF3)
!
!-----------------------------------------------------------------------
!
      IF(MPRINT.LT.-2)THEN
        WRITE(MW6,10410)-KUTSO,KUTSS,LIT(QQCUT)
        WRITE(MW6,10440)MXADJ,MAXLV,MAXLV,IXSOC,IXSOI,MXADJ,MAXLV,MAXLV,&
     &                  IXRSS,IAXMI
        WRITE(MW6,10030)IADJ8,NJ,NJ,0,0
        WRITE(MW6,10290)NP8,NJ,NJ,IRS,NL
        WRITE(MW6,10040)IXS1C,IXS1I,0,0,mxstx,kint
        IF(KUTSS.NE.-1)WRITE(MW6,10050)IXS2C,IXS2I,0,0
        WRITE(MW6,10140)MDCBUF3,MAXDC
      ENDIF
!
!-----------------------------------------------------------------------
!
! ex-ALGEB4
!     no 1-body m1+bp
      MMAX0=MIN(MPOLE-2,MPOLM)                  !AS MPOLM NOT IN RESTART
      MMIN0=MAX(MPOL0-2,ITWO)
      bnom1bp1=MPRINT.EQ.-2.OR.MPRINT.EQ.-1.OR.MPRINT.EQ.-4.OR.         &
     &         MMIN0.GT.MMAX0.OR.MBP1MX.LT.2.AND.MMAX0.LT.4.AND.        &
     &         MEKVMX.LT.2
!
! EX-COMMON/COEFF/
!
      IXSOC=MAX(MXSOC0,MXSOC,IXSOC)               !USE LARGEST PREVIOUS
!      IXSOC=MAX(MXSOC0,MXSOC)                     !RESET
      IXSOI=MAX(MXSOI0,MXSOI,IXSOI)               !USE LARGEST PREVIOUS
!      IXSOI=MAX(MXSOI0,MXSOI)                     !RESET
!
      ALLOCATE(DRKP(IXSOC),QRLP(4,IXSOI),NRKP(IXSOC),NADP(0:IADJ8),     &
     &         STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB3: ALLOCATION FAILS FOR DRKP,QRLP,NRKP,NADP'
        NF=0
        GO TO 2100
      ENDIF
!
! EX-COMMON/COEFFS/
!
      IXS1C=MAX(MXS1C0,MXS1C,IXS1C)               !USE LARGEST PREVIOUS
!      IXS1C=MAX(MXS1C0,MXS1C)                     !RESET
      IXS1I=MAX(MXS1I0,MXS1I,IXS1I)               !USE LARGEST PREVIOUS
!      IXS1I=MAX(MXS1I0,MXS1I)                     !RESET
!
      ALLOCATE(DRKPS(IXS1C),QRLPS(4,IXS1I),NRKPS(IXS1C),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB3: ALLOCATION FAILS FOR  DRKPS,QRLPS,NRKPS'
        NF=0
        GO TO 2100
      ENDIF
!
! EX-COMMON/NSTS1/
!
      IXXX1=MAX(IXS1I,IXSOI)
      IXD27=KMAX*KMAX
      ALLOCATE(NADS1(0:IXD27),NSTJ1(IXS1C),NSTJ1D(IXS1C),IORIG1(IXXX1), &
     &         JORIG1(IXS1I),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB3: ALLOCATION FAILS FOR NADS1,NSTJ1, ETC'
        NF=0
        GO TO 2100
      ENDIF
!
! ex-ALGEB4
!     no 2-body m1+bp
      bnom1bp2=bnom1bp1.OR.MBP2MX.LT.2
!
! SET ALLOCATE SIZE
!
      IF(bnom1bp2.and.KUTSS.EQ.-1)THEN            !FOR ANY RESTART
        BG2BODY=.FALSE.
        IADJXX=0
        IXRSS=0
        IAXMI=0
        IXS2C=0
        IXS2I=0
        IXD27=0
      ELSE
        ITEST4=IBUFF4
        ITEST4=ITEST4+1
        IF(IADJ8.GT.IBUFF4.AND.ITEST4.LT.IBUFF4)THEN
          WRITE(MW0,*)'I*4 OVERFLOW ON 2-BODY FINE-STRUCTURE'
          GO TO 2600
        ENDIF
        BG2BODY=.TRUE.
        IADJXX=IADJ
        IXRSS=MAX(MXRSS0,MXRSS,IXRSS)             !USE LARGEST PREVIOUS
!        IXRSS=MAX(MXRSS0,MXRSS)                   !RESET
        IAXMI=MAX(MAXMI0,MAXMI,IAXMI)             !USE LARGEST PREVIOUS
!        IAXMI=MAX(MAXMI0,MAXMI)                   !RESET
        IXS2C=MAX(MXS2C0,MXS2C,IXS2C)             !USE LARGEST PREVIOUS
!        IXS2C=MAX(MXS2C0,MXS2C)                   !RESET
        IXS2I=MAX(MXS2I0,MXS2I,IXS2I)             !USE LARGEST PREVIOUS
!        IXS2I=MAX(MXS2I0,MXS2I)                   !RESET
        IXD27=KMAX*KMAX
      ENDIF
      B2BODY=BG2BODY
!
! EX-COMMON/DMQSS3/
!
      ALLOCATE(DSS(IXRSS),MSS(IXRSS),QSS(5,IAXMI),NADR(0:IADJXX),       &
     &         STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB3: ALLOCATION FAILS FOR  DSS,MSS,QSS,NADR'
        NF=0
        GO TO 2100
      ENDIF
!
! EX-COMMON/DMQSSS/
!
      ALLOCATE(DSSS(IXS2C),MSSS(IXS2C),QSSS(5,IXS2I),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB3: ALLOCATION FAILS FOR  DSSS,MSSS,QSSS'
        NF=0
        GO TO 2100
      ENDIF
!
! EX-COMMON/NSTS2/
!
      IXXX2=MAX(IXS2I,IAXMI)
      ALLOCATE(NADS2(0:IXD27),NSTJ2(IXS2C),NSTJ2D(IXS2C),IORIG2(IXXX2), &
     &         JORIG2(IXS2I),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB3: ALLOCATION FAILS FOR NADS2,NSTJ2, ETC'
        NF=0
        GO TO 2100
      ENDIF
!
!-----------------------------------------------------------------------
!
      IF(MPRINT.LT.-2)GO TO 2100            !EXIT LEVEL DIMENSION CHECK
!
!-----------------------------------------------------------------------
!
! CALCULATE SOME (PRODUCTS OF) CLEBSCH-GORDAN COEFFICIENTS:
!
! VCA=C(L1,L2,L,0,0,0)*C(L1,L2,KT,ML1,ML2,MLK)/(L+1)
! VCB=C(L1,L2,L,0,0,0)*C(L1,L2,KT+2,ML1,ML2,MLK)
!
      IF(BDLBD.OR.KUTSS.EQ.-1)GO TO 1700  !NORMALLY CALCULATED IN ALGEB2
!                                         !ONLY HERE IF MSTART=3
      MXLL=NXLL
      IF(MXLL.LT.0)GO TO 1700
!
      IF(MAXLL.GE.0)THEN                 !AS MAXLL IS NOW MAX L *PLUS* 1
        IAXLL=MAXLL
      ELSE
        IAXLL=MAXLL0
      ENDIF
      IXLL1=MXLL/ITWO+1
      IAXLL=MIN(IXLL1,IAXLL,MAXLL1)
      BVC=IXLL1.LE.IAXLL
      IF(.NOT.BVC)MXLL=2*IAXLL-2
!
      IF(IAXLL.LE.0)GO TO 1700
!
      IXD31=IAXLL
      IXD32=IXD31*IXD31
!
      CALL DIMUSE('MAXLL',IXD31)
!
      ALLOCATE(VCA(IXD32,IXD32,IXD31),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB3: ALLOCATION FAILS FOR VCA'
        NF=0
        GO TO 2100
      ENDIF
      ALLOCATE(VCB(IXD32,IXD32,IXD31),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB3: ALLOCATION FAILS FOR VCB'
        NF=0
        GO TO 2100
      ENDIF
!
      M1=0
 1200 M2=0
!
 1300 MK=ABS(M1-M2)
!
 1400 MK2=MK+2
      DVC=VCC(M1,M2,MK,IZERO,IZERO,IZERO)
      ML1=-M1
!
 1500 MB1=MVC(M1,ML1)
      ML2=-M2
!
 1600 MB2=MVC(M2,ML2)
      DA=DZERO
      DD=DZERO
      MLK=ML1+ML2
!
      IF(ABS(MLK).LE.MK2)THEN
        DD=VCC(M1,M2,MK2,ML1,ML2,MLK)*DVC
        IF(ABS(MLK).LE.MK)DA=(VCC(M1,M2,MK,ML1,ML2,MLK)/(MK+1))*DVC
      ENDIF
!
      MLK=MK/4+1
      VCA(MB1,MB2,MLK)=DA
      VCB(MB1,MB2,MLK)=DD
!
      ML2=ML2+2
      IF(ML2.LE.M2)GO TO 1600
!
      ML1=ML1+2
      IF(ML1.LE.M1)GO TO 1500
!
      MK=MK+4
      IF(MK.LE.M1+M2)GO TO 1400
!
      M2=M2+2
      IF(M2.LE.MXLL)GO TO 1300
!
      M1=M1+2
      IF(M1.LE.MXLL)GO TO 1200
!
 1700 CONTINUE
!
!-----------------------------------------------------------------------
!
!   PREPARE TO CALCULATE THE ALGEBRA OF THE FINESTRUCTURE INTERACTIONS
!   I.E., THE COEFFICIENTS C,D,AND E.
!   THIS SECTION SHOULD BE STUDIED TOGETHER WITH (COMMENTS IN) SR.SPOR
!   AND SR.RES
!
!-----------------------------------------------------------------------
!
      IF(MPRNT1.LE.0)WRITE(MW6,10460)
      IF(MCFSS.GE.1)THEN
        WRITE(MW6,10420)
        DO I=1,KMAX
          IF(KCFSS(I).GE.1)WRITE(MW6,10430)I
        ENDDO
      ENDIF
!
      WRITE(MW6,10410)-KUTSO,KUTSS,LIT(QQCUT)
      WRITE(MW6,10440)MXADJ,MAXLV,MAXLV,IXSOC,IXSOI,MXADJ,MAXLV,MAXLV,  &
     &                IXRSS,IAXMI
!
! INITIALIZE FOR J-LOOP
!
      NL=0
      IRKP=0
      IRS=0
      IRLP=0
      MXIRKS=0
      MXIRLS=0
      MXIRSS=0
      MXNLS=0
      KPI=0
      KPIS=0
!
      NADP(0)=0
      NADR(0)=0
      NADS1(0)=0
      NADS2(0)=0
      NCJ=0
      NP8=0
      J1=2
      J1P=2
!                                                  !TEST ALTERNATIVE QMJ
      IF(BMOD3)THEN
        JACT=JN(1)
        QMJ=INT(JACT-(JACT/2)*2,QP)                     !0 or 1 i.e. min
      ENDIF
!
!********************************************
!
!  EXPAND OVER THE NJO JP GROUPS
! (NT IS THE NUMBER OF LEVELS IN A JP GROUP
!
!********************************************
!
      if(btime)then
        time1=dzero
        time2=dzero
        times2=dzero
        timer2=dzero
      endif
!
      DO K=1,NJO                                         !BEGIN JPI LOOP
!
        JACT=JN(NCJ+1)
        IF(.NOT.BMOD3)QMJ=INT(JACT,QP)  !QMJ=TWICE AZIMUTHAL COMPNT OF J
!      qmj=jact/2
!
        IF(KUTDSK.LT.KFBUFF)MTGD1=MTGD+1                        !RESTORE
!
        NCJ0=0
        DO NGJ1=1,NGSLJ(K)                                !BEGIN SL LOOP
          NC=NSLJ(NGJ1,K)
          N0=NSL(NC)
          LJ=QLI(NC)
          SJ=QSI(NC)
!
          DO KF=KUTDSK+1,KFBUFF                !PRELOAD NEW SL GROUP VCC
            KSTART(KF,NGJ1)=0
            NGSYM=KGSL(KF,NC)                             !POS WITHIN CF
            IF(NGSYM.GT.0)THEN
              ISTRT=MTGD1
              KSTART(KF,NGJ1)=ISTRT
!
              CALL DISKDC(IUD,ISTRT,IFIN,KF,NGSYM,IONE,IZERO)
!
              MTGD1=IFIN+1
              IF(IFIN.LT.0)THEN           !FAILURE TO READ REQUIRED DATA
                NF=-1
                GO TO 2100
              ENDIF
            ENDIF
          ENDDO
!
          NCJP0=0
          DO NGJP1=1,NGJ1                               !BEGIN S'L' LOOP
            ND=NSLJ(NGJP1,K)
            N0P=NSL(ND)
            LJP=QLI(ND)
            SJP=QSI(ND)
!
            if(btime)call nrb_time(timei)
!
            IFLG0=0
            IF(SJP+SJ.EQ.0)GO TO 1730
            IF(LJP+LJ.EQ.0)GO TO 1730
            IFLG0=1
!
            BEQUGRP=NGJ1.EQ.NGJP1
            if(bequgrp.and.nc.ne.nd)then
              stop 'bequgrp.and.nc.ne.nd'
            endif
            if(.not.bequgrp.and.nc.eq.nd)then
              stop '.not.bequgrp.and.nc.eq.nd'
            endif
!
            IRKPS=0
            IRLPS=0
            IRSS=0
            NLS=0
!
            KK=0
            KG2=KMAX
            DO KF0=1,KMAX                                 !BEGIN LOOP KF
              kf=kf0                                          !for bswap
!
              IFLG=0
              IF(KGSL(KF,NC).GT.0)IFLG=1        !CF CONTRIBS TO SL GROUP
!
              IF(BEQUGRP)KG2=KF
!
              DO KG0=1,KG2                                !BEGIN LOOP KG
                kg=kg0                                        !for bswap
                KK=KK+1
                IF(IFLG.EQ.0)GO TO 1720                      !JUST INDEX
!
                IF(.NOT.BEQUGRP)THEN
                  K0=MIN(KF,KG)
                  K1=MAX(KF,KG)
                  KB=(K1*(K1-1))/2+K0
                ELSE
                  KB=KK
                ENDIF
!
                B1BODY=B1B(KB)
                B2BODY=B2B(KB)
                IF(.NOT.B1BODY.AND..NOT.B2BODY)GO TO 1720
!
                IF(KGSL(KG,ND).GT.0)THEN      !CF CONTRIBS TO S'L' GROUP
                  IFLGG=1
                ELSE
                  IFLGG=0
                  GO TO 1720                             !NO, IT DOESN'T
                ENDIF
!
                IF(BFASTSO)THEN
                  BEQCFS=KF.EQ.KG
                  IF(KUTSO.EQ.-1)THEN
                    i1=1
                    i2=2
                    K2=KF                                    !KF=KG HERE
                  ELSE
                    if(kf.ge.kg)then
                      i1=1
                      i2=2
                      K2=(KF*(KF-1))/2+KG
                    else
                      i1=2
                      i2=1
                      K2=(KG*(KG-1))/2+KF
                    endif
                  ENDIF
                ENDIF
!
                if(bswap)then                         !test swap bra/ket
                  j=kf
                  kf=kg
                  kg=j
                  j=sj
                  sj=sjp
                  sjp=j
                  j=lj
                  lj=ljp
                  ljp=j
                endif
!
                JA=JYI(KF)
                JB=JYF(KF)
                JAP=JYI(KG)
                JBP=JYF(KG)
!
                IRKPS0=IRKPS+1
                IRLPS0=IRLPS
                IRSS0=IRSS+1
                NLS00=NLS
!
                ICLRR=0
                IF(B2BODY)ICLRR=1
                ICLRS=1
!
!-------------------------------------------------------------
! NOW LOOP-OVER ALL POSSIBLE ML,MS,ML',MS' THAT FORM MJ
! AND PICK-OUT THE CORRESPONDING SLATERSTATES, FOR ALL KF,KG.
!-------------------------------------------------------------
!
                QMS=INT(SJ,QP)
 1702           QML=QMJ-QMS
                BLX1=QMS.NE.-SJ.AND.QML.NE.LJ
                IF(QML.LT.-LJ)GO TO 1716
!
                IF(.NOT.BFASTSO)THEN
!
! MAM(I) IS CONSTRUCTED SO THAT IT CAN BE USED TO SELECT INITIAL STATES
!        HAVING THE CORRECT ML,MS.
!
                  J2=1
                  DO J=JA,JB
                    IF(QBML(J).EQ.QML.AND.QBMS(J).EQ.QMS)THEN
                      J2=J2+1
                      MAM(J2)=J
                    ENDIF
                  ENDDO
                  IF(J2.LT.J1)GO TO 1716
                ENDIF
!
                DVCL1=VCC(LJ,SJ,JACT,INT(QML,SP),INT(QMS,SP),INT(QMJ,SP)&
     &                )
                IF(ABS(DVCL1).LT.TTYNY)GO TO 1716
!
                QMSP=INT(SJP,QP)
 1704           QMLP=QMJ-QMSP
                BLX2=QMSP.NE.-SJP.AND.QMLP.NE.LJP
                IF(QMLP.LT.-LJP)GO TO 1714
!
                J1P=ABS(J1P)
                J2P=1
                IF(ABS(QMSP-QMS).GT.2)THEN                   !NO 1-BODY
                  IF(.NOT.B2BODY.OR.ABS(QMSP-QMS).GT.4)GO TO 1714
                                                             !NO 2-BODY
                  GO TO 1708                     !AS ABS(QMSP-QMS).EQ.4
                ENDIF
!
! SELECT SLATE STATES/INTERACTIONS
!
                IF(.NOT.BFASTSO)THEN
!
! NAM(I) IS CONSTRUCTED SO THAT IT CAN BE USED TO SELECT FINAL STATES
!        HAVING THE CORRECT MLP,MSP.
!
                  DO J=JAP,JBP
                    IF(QBML(J).EQ.QMLP.AND.QBMS(J).EQ.QMSP)THEN
                      J2P=J2P+1
                      NAM(J2P)=J
                    ENDIF
                  ENDDO
!
                ELSE
!
! SET POINTERS THAT SELECT SLATER STATE INTERACTIONS FOR QML & QMLP
!
                  if(beqcfs)then
                    if(qmlp.ge.qml)then
                      i1=1
                      i2=2
                    else
                      i1=2
                      i2=1
                    endif
                  endif
!
                  mej(i1)=qml/2
                  mej(i2)=qmlp/2
                  k1=kptcfm(mej(2),mej(1),k2)
                  mej(2)=mej(2)+1
                  k0=kptcfm(mej(2),mej(1),k2)+1
!
! MAM(J2) IS CONSTRUCTED TO SELECT INITIAL & FINAL STATES
!         HAVING THE CORRECT QML, QMS & QMLP,QMSP.
!
! If non-trivial time taken in this search, do a double sweep as in
!   v22.11. The coding below does seem to inhibit compiler optimization.
!
!             write(mw6,*)qml,qms,' ml ms ',qmlp,qmsp,'   k0 k1  ',k0,k1
!
                  J2=1
                  do ky=k0,k1
                    nej(i1)=kinti(ky)
                    nej(i2)=kintf(ky)
                    j=nej(1)
                    jp=nej(2)
                    jjp=jp
                    kp=ky
 1706               IF(QBMS(J).EQ.QMS.AND.QBMS(JP).EQ.QMSP)THEN
                      J2=J2+1
                      if(j2.gt.nss)then
                        write(mw6,*)'sr.algeb3: mxst0/nss exceeded...'
                        write(mw0,*)'sr.algeb3: mxst0/nss exceeded...'
                        go to 2100
                      endif
                      if(beqcfs.and.qmlp.lt.qml)kp=-kp
                      MAM(J2)=kp
                    ENDIF
                    if(beqcfs.and.QML.eq.QMLP.and.j.ne.jjp)then
                      jp=j
                      j=jjp
                      kp=-kp
                      go to 1706
                    endif
                  enddo
                  J1P=J1
                  J2P=J2
                ENDIF
!
                IF(.NOT.B2BODY.AND.J2P.LT.J1P)GO TO 1714
!
 1708           DVCL2=VCC(LJP,SJP,JACT,INT(QMLP,SP),INT(QMSP,SP),       &
     &                INT(QMJ,SP))
!
                DVC12=DVCL1*DVCL2
                IF(ABS(DVC12).LT.TYNY)GO TO 1714
!
                BLX=BLX1.OR.BLX2
!
!-------------------------------------------------------------
! CALCULATE THE SLATER-STATE INTERACTION BETWEEN CFS KF AND KG
!-------------------------------------------------------------
!
 1710           IF(B1BODY.AND.J2P.GE.J1P)THEN
!
!
                  IF(.NOT.BFASTSO)THEN
                    CALL SPOR1(QLMC,MAXEL,MAM,NAM)           !<-- 1-BODY
                  ELSE
                    CALL SPOR1F(QLMC,MAXEL,MAM)              !<-- 1-BODY
                  ENDIF
!
!
                  MXIRKS=MAX(MXIRKS,IRKPS)
                  MXIRLS=MAX(MXIRLS,IRLPS)
                  IF(KPIS.NE.0)GO TO 1800
                                      !DIM MXS1C AND/OR MXS1I EXCEEDED
                  IF(NF.LE.0)GO TO 2100
!
                  IF(ICLRS.EQ.0)THEN
                    IF(ICLRR.EQ.0)GO TO 1720
                    J1P=ABS(J1P)
                  ENDIF
!
                ENDIF
!
                IF(.NOT.B2BODY)GO TO 1714          !CASE BFASTSO.EQ.TRUE
!
                IF(ABS(QMSP-QMS).EQ.4)THEN           !NOW ADD 2-BODY SS
                  DO J=JAP,JBP
                    IF(QBML(J).EQ.QMLP.AND.QBMS(J).EQ.QMSP)THEN
                      J2P=J2P+1
                      NAM(J2P)=J
                    ENDIF
                  ENDDO
                ENDIF
!
 1712           IF(J2P.GE.J1P)THEN
!
!       write(mw6,*)qms,qml,qmsp,qmlp,qmj,irss,j1,j2,j1p,j2p
!
                  CALL RES1(QLMC,MAXEL,MAM,NAM)              !<-- 2-BODY
!
!
                  MXIRSS=MAX(MXIRSS,IRSS)
                  MXNLS=MAX(MXNLS,NLS)
                  IF(KPIS.NE.0)GO TO 1800
                                        !DIM MXS2C AND/OR MXS2I EXCEEDED
                  IF(NF.LE.0)GO TO 2100
!
                  IF(ICLRR.EQ.0)THEN
                    IF(ICLRS.EQ.0)GO TO 1720
                    GO TO 1718
                  ENDIF
!
                ENDIF
!
!-------------------------------------------------------------
! IF BLX=.TRUE. THE TRANSFORMATION TO THE J,MJ REPRESENTATION
!              IS NOT YET COMPLETE.
!-------------------------------------------------------------
!
 1714           QMSP=QMSP-QTWO
!
                IF(BLX2)GO TO 1704
!
 1716           QMS=QMS-QTWO
!
                IF(BLX1)GO TO 1702
!
! CLEAR ARRAYS, IF NOT ALREADY DONE
!
 1718           IF(ICLRS.NE.0)THEN
                  ICLRS=-ICLRS
                  B1BODY=.TRUE.
                  J1P=-ABS(J1P)
                  GO TO 1710
                ENDIF
!
                IF(ICLRR.NE.0)THEN
                  ICLRR=-ICLRR
                  J1P=-ABS(J1P)
                  GO TO 1712
                ENDIF
!
 1720           NADS1(KK)=IRKPS
                IF(BG2BODY)NADS2(KK)=IRSS
!
!        write(mw6,*)'***** kf,kg:',kf,kg,nads2(kk)-nads2(kk-1)
!        do ijk=nads2(kk-1)+1,nads2(kk)
!          jq=msss(ijk)
!          write(mw6,776)nstj2(ijk),nstj2d(ijk),msss(ijk),dsss(ijk)
!     &              ,(qsss(iq,jq),iq=1,5)
!  776  format(3i5,f12.6,5i5)
!        enddo
!
                if(bswap.and.iflg*iflgg.gt.0)then     !test swap bra/ket
                  j=kf
                  kf=kg
                  kg=j
                  j=sj
                  sj=sjp
                  sjp=j
                  j=lj
                  lj=ljp
                  ljp=j
                endif
!
              ENDDO                                         !END LOOP KG
!
            ENDDO                                           !END LOOP KF
!
!
 1730       CONTINUE
!
!
            if(btime)then
              call nrb_time(timef)
              time1=time1+timef-timei
            endif
!
!
!------------------------------------------------------------------
! NOW DETERMINE THE INTERACTION BETWEEN JP LEVELS OF THE LSP GROUPS
!------------------------------------------------------------------
!
            if(btime)call nrb_time(timei)
!
            istrt0=0
            KF0=0
            DO NJ11=1,N0                                 !BEGIN SLJ LOOP
!
              NJ1=NJ11+NCJ0
              NJ=NJ1+NCJ
              IT=NRR(NJ)
              KF=NFK(IT)
!
              if(bcont.or.bkutls)then
                ii=ieq(qcg(nf,kf))
                kcf=0
                if(qn(ii).ge.90)kcf=ii                        !continuum
              endif
!
              IF(IFLG0.EQ.0)GO TO 1735
!
              IF(KF.GT.KUTDSK.AND.KF.NE.KF0)THEN
                ISTRT=KSTART(KF,NGJ1)
                IF(ISTRT.EQ.0)THEN                       !BUFFERED BY CF
                  NGSYM=KGSL(KF,NC)                       !POS WITHIN CF
                  ISTRT=MTGD1
!
                  CALL DISKDC(IUD,ISTRT,IEND,KF,NGSYM,IONE,IZERO)
!
                  IF(IEND.LT.0)THEN       !FAILURE TO READ REQUIRED DATA
                    NF=-1
                    GO TO 2100
                  ENDIF
                ENDIF
                ISTRT0=ISTRT-MTGD-1                 !I.E. ORIGINAL MTGD1
                KF0=KF
              ENDIF
!
              II=NFI(IT)
              IF(BFAST)THEN
                NJ2=JTGD(II)+ISTRT0        !relative start flagged
              ELSE
                do j=jyi(kf),jyf(kf)
                  mam(j)=0
                enddo
                k2=jtgd(ii)                !absolute end flagged
                if(k2.lt.0)then            !bdisk first
                  k2=-k2
                  k1=mtgd
                else
                  k1=jtgd(ii-1)            !start
                  k1=abs(k1)              !case bdisk second
                endif
                k1=k1+1+istrt0
                k2=k2+istrt0
                do k12=k1,k2
                  j=idc(k12)
                  mam(j)=k12
                enddo
              ENDIF
!
 1735         IF(NC.EQ.ND)N0P=NJ11
!
              istrt=0
              KG0=0
              DO NJP11=1,N0P                           !BEGIN S'L'J LOOP
!
                NJP1=NJP11+NCJP0
                NJG=NJP1+NCJ
                ITP=NRR(NJG)
                KG=NFK(ITP)
!
                if(bcont.or.bkutls)then
                  ll=ieq(qcg(nf,kg))
                  kcg=0
                  if(qn(ll).ge.90)kcg=ll
!                                           c-c does not contrb
                  if(kcf.ne.kcg.and.kcf*kcg.ne.0)go to 1740
                  btest=kcf.ne.kcg.and.(kcf.gt.0.or.kcg.gt.0)
                  if(.not.bauger.and.btest)go to 1740  !no augers
!                                           no 2-fs and nc.ne.nd and b-c
                  btest=(kcf+kcg).ne.0.and.kcf*kcg.eq.0
                  if(bfastso.and.btest)go to 1740
!                                     single cf mixing (but keeping b-c)
                  btest=kf.ne.kg.and.(kcf+kcg.eq.0.or.kcf*kcg.ne.0)
                  if(bkutls.and.btest)go to 1740
                endif
!
                NP8=NP8+1
                IF(IFLG0.EQ.0)GO TO 1736               !NO INTRACTNS 0-0
!
! CALCULATE THE ALGEBRAIC CONTRIBUTION TO THE MATRIX ELEMENT.
!
                IF(BEQUGRP)THEN          !KG.LE.KF HERE
                  KK=(KF*(KF-1))/2+KG
                ELSE
                  KK=KMAX*(KF-1)+KG
                ENDIF
!
                B1BODY=NADS1(KK).GT.NADS1(KK-1)
                IF(BG2BODY)B2BODY=NADS2(KK).GT.NADS2(KK-1)
!
                IF(B1BODY.OR.B2BODY)THEN
!
                  IF(KG.GT.KUTDSK.AND.KG.NE.KG0)THEN
                    ISTRT=KSTART(KG,NGJP1)
                    IF(ISTRT.EQ.0)THEN                   !BUFFERED BY CF
                      LGSYM=KGSL(KG,ND)                   !POS WITHIN CF
                      ISTRT=IEND+1
!
                      CALL DISKDC(IUD,ISTRT,IFIN,KG,LGSYM,IONE,IZERO)
!
                      IF(IFIN.LT.0)THEN   !FAILURE TO READ REQUIRED DATA
                        NF=-1
                        GO TO 2100
                      ENDIF
                    ENDIF
                    ISTRT=ISTRT-MTGD-1              !I.E. ORIGINAL MTGD1
                    KG0=KG
                  ENDIF
!
                  LL=NFI(ITP)
                  IF(BFAST)THEN
                    NJP2=JTGD(LL)+ISTRT    !relative start flagged
                  ELSE
                    do j=jyi(kg),jyf(kg)
                      nam(j)=0
                    enddo
                    k2=jtgd(ll)            !absolute end flagged
                    if(k2.lt.0)then        !bdisk first
                      k2=-k2
                      k1=mtgd
                    else
                      k1=jtgd(ll-1)        !start
                      k1=abs(k1)          !case bdisk second
                    endif
                    k1=k1+1+istrt
                    k2=k2+istrt
                    do k12=k1,k2
                      j=idc(k12)
                      nam(j)=k12
                    enddo
                  ENDIF
!
                  if(bswap)then                       !test swap bra/ket
                    j=nj
                    nj=njg
                    njg=j
                    if(bfast)then
                      j=nj2
                      nj2=njp2
                      njp2=j
                    else
                      if(kf.ne.kg)then
                        do j=jyi(kf),jyf(kf)
                          nam(j)=mam(j)
                        enddo
                        do j=jyi(kg),jyf(kg)
                          mam(j)=nam(j)
                        enddo
                      else
                        do j=jyi(kf),jyf(kf)
                          l=mam(j)
                          mam(j)=nam(j)
                          nam(j)=l
                        enddo
                      endif
                    endif
                  endif
!
                ENDIF
!
                IRKP0=IRKP+1
                IF(B1BODY)THEN
!
                  if(btime)call nrb_time(timeii)
!
                  CALL SPOR2(mam,nam,KK)                     !<-- 1-BODY
!
                  if(btime)then
                    call nrb_time(timeff)
                    times2=times2+timeff-timeii
                  endif
!
                  IF(KPI.NE.0)GO TO 1800
                ENDIF
!
                IRS0=IRS+1
                IF(B2BODY)THEN
!
                  if(btime)call nrb_time(timeii)
!
                  CALL RES2(mam,nam,KK)                      !<-- 2-BODY
!
                  if(btime)then
                    call nrb_time(timeff)
                    timer2=timer2+timeff-timeii
                  endif
!
                  IF(KPI.NE.0)GO TO 1800
                ENDIF
!
!
! PRINT THE ALGEBRAIC COEFFICIENTS OF THE SPIN-ORBIT MATRIX ELEMENT
! IF THEY ARE NOT ZERO.
!
                IF(MPRINT.GT.0)THEN
                  IF(IRKP.EQ.IRKP0)THEN
                    WRITE(MW6,10020)NP8,NJ,NJG,IRKP,IRLP,               &
     &                              (NRKP(N),DRKP(N),N=IRKP0,IRKP)
                  ELSEIF(IRKP.GT.IRKP0)THEN
                    WRITE(MW6,10030)NP8,NJ,NJG,IRKP,IRLP,               &
     &                              (NRKP(N),DRKP(N),N=IRKP0,IRKP)
                  ELSE
                    WRITE(MW6,10020)
                  ENDIF
                  IF(IRS-IRS0.EQ.2)THEN
                    WRITE(MW6,10280)NP8,NJ,NJG,IRS,NL,                  &
     &                              (MSS(N),DSS(N),N=IRS0,IRS)
                  ELSEIF(IRS.GE.IRS0)THEN
                    WRITE(MW6,10290)NP8,NJ,NJG,IRS,NL,                  &
     &                              (MSS(N),DSS(N),N=IRS0,IRS)
                  ENDIF
                ELSEIF(MPRINT+idw.EQ.0)THEN
                  IF(NJG.EQ.NJ)WRITE(MW6,10060)NP8,NJ,NJG,IRKP,IRLP,IRS,&
     &                               NL
                ENDIF
!
                if(bswap)then                         !test swap bra/ket
                  j=nj2
                  nj2=njp2
                  njp2=j
                  j=nj
                  nj=njg
                  njg=j
                endif
!
! NADP IS THE ADDRESS ARRAY WHICH GIVES THE POSITION OF THE LAST
! SPIN-ORBIT PARAMETER ASSOCIATED WITH AN M.E. (J,MJ!F(SO)!JP,MJP)
! NADR SIMILARLY FOR 2-BODY FINE-STRUCTURE. (C.F. NAD FOR LS.)
!
 1736           NADP(NP8)=IRKP
                IF(BG2BODY)NADR(NP8)=IRS         !GLOBAL TEST
!
 1740         ENDDO                              !END S'L'J LOOP
!
            ENDDO                                !END SLJ LOOP
!
            if(btime)then
              call nrb_time(timef)
              time2=time2+timef-timei
            endif
!
            NCJP0=NCJP0+N0P
          ENDDO                                  !END S'L' LOOP
!
          NCJ0=NCJ0+N0
        ENDDO                                    !END SL LOOP
!
        IF(KUTDSK.LT.KFBUFF)THEN
          IFIN=MTGD1-1
          MDCBUF3=MAX(MDCBUF3,IFIN)
        ENDIF
!
        NCJ=NT(K)+NCJ
      ENDDO                                      !END JP LOOP
!
!
      if(btime)then
!par        if(iam.ge.0)then                                        !par
!par          write(iwp,*)'proc',iam,' for algeb3:'                 !par
!par          write(iwp,*)'    spor1+res1 time=',nint(time1),'sec'  !par
!par          write(iwp,*)'    spor2+res2 time=',nint(time2),'sec'  !par
!par          call flush(iwp)                                       !par
!par        else                                                    !par
        if(b2body)then
          write(iw,*)'spor1+res1 time=',nint(time1),'sec'
        else
          write(iw,*)'spor1      time=',nint(time1),'sec'
        endif
        write(iw,*)'spor2 core time=',nint(times2),'sec'
        if(b2body)then
          write(iw,*)'res2 core  time=',nint(timer2),'sec'
          write(iw,*)'spor2+res2 time=',nint(time2),'sec'
        else
          write(iw,*)'spor2      time=',nint(time2),'sec'
        endif
!          call flush(iw)
!par        endif                                                   !par
      endif
!
      if(ncj.ne.nlev)stop 'algeb3: nlevels=?'      !temp - to be removed
!
!OLD      QBML(1)=NCJ                     !PASS TO ALGEB FOR RESTART I/O
!OLD      QBMS(1)=NP8                   !PASS TO ALGEB4, NO LONGER USED?
!
      IF(IADJ8.NE.NP8)THEN
        WRITE(MW0,*)'SR.ALGEB3 GLOBAL INDEX ERROR:',IADJ8,NP8
        NF=-1
        GO TO 2100
      ENDIF
!
      CALL DIMUSE('MXSOC',IRKP)
      CALL DIMUSE('MXSOI',IRLP)
      IF(IRS.GT.0)THEN
        CALL DIMUSE('MXRSS',IRS)
        CALL DIMUSE('MAXMI',NL)
      ENDIF
      CALL DIMUSE('MXS1C',MXIRKS)
      CALL DIMUSE('MXS1I',MXIRLS)
      IF(IRSS.GT.0)THEN
        CALL DIMUSE('MXS2C',MXIRSS)
        CALL DIMUSE('MXS2I',MXNLS)
      ENDIF
      IF(MDCBUF3.GT.0)CALL DIMUSE('MAXDC',MDCBUF3)
!
      IF(MPRNT1.GE.0)THEN
        WRITE(MW6,10040)IXS1C,IXS1I,MXIRKS,MXIRLS,mxstx,kint
        IF(IRSS.GT.0)WRITE(MW6,10050)IXS2C,IXS2I,MXIRSS,MXNLS
        WRITE(MW6,10140)MDCBUF3,MAXDC
      ENDIF
      IF(MPRNT1.EQ.0)GO TO 2000                     !NORMAL RETURN
      IF(MPRNT1.GT.0)GO TO 1900
!
      NJG=NCJ
 1800 WRITE(MW6,10030)NP8,NJ,NJG,IRKP,IRLP
      WRITE(MW6,10290)NP8,NJ,NJG,IRS,NL
!
      IF(KPI.LT.0)GO TO 2200
      IF(KPI.GT.0)GO TO 2400
!
      WRITE(MW6,10040)IXS1C,IXS1I,MXIRKS,MXIRLS,mxstx,kint
      IF(IRSS.GT.0)WRITE(MW6,10050)IXS2C,IXS2I,MXIRSS,MXNLS
      WRITE(MW6,10140)MDCBUF3,MAXDC
      IF(KPIS.LT.0)GO TO 2300
      IF(KPIS.GT.0)GO TO 2500
!
      GO TO 2000                                    !NORMAL RETURN
!
 1900 IF(IRLP.GT.0)THEN
        WRITE(MW6,10370)          !NO. S-O BY THEIR ARGUMENTS
        DO L=1,IRLP
          WRITE(MW6,10380)L,(QRLP(K,L),K=1,2)
        ENDDO
      ENDIF
!
      IF(NL.GT.0)THEN           !TWO-BODY
        WRITE(MW6,10390)
        DO L=1,NL
          IF(QSS(5,L).GT.197)THEN
            WRITE(MW6,10150)L,(QSS(K,L),K=1,5)
          ELSE
            WRITE(MW6,10400)L,(QSS(K,L),K=1,5)
          ENDIF
        ENDDO
      ENDIF
!
!-----------------------------------------------------------------------
!
 2000 CONTINUE
!
! IF ACTUAL USAGE IS SUFFICIENTLY SMALLER THAN *INITIAL* ALLOCATION,
! THEN REDUCE USAGE TO ACTUAL - FOR SMALL CASES ON SMALL MEMORY MACHINES
!
      IXXX=(4*MXSOI)/5
      IF(bnom1bp1.and.IRLP.LT.IXXX)THEN
!
!      WRITE(MW6,*)'*** ALGEB3: decreasing MXSOI from ',IXSOI,' to: '
!                ,IRLP
!      WRITE(MW0,*)'*** ALGEB3: decreasing MXSOI from ',IXSOI,' to: '
!                ,IRLP
!
        CALL RE_ALLOC2(QRLP,IONE,IFOUR,IONE,IXSOI,IFOUR,IRLP,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB3: RE-ALLOCATION FAILS FOR QRLP...',IERR
          NF=0
          GO TO 2100
        ENDIF
!
        IXSOI=IRLP
!
      ENDIF
!
      IXXX=(4*MXSOC)/5
      IF(bnom1bp1.and.IRKP.LT.IXXX)THEN
!
!      WRITE(MW6,*)'*** ALGEB3: decreasing MXSOC from ',IXSOC,' to: '
!                ,IRKP
!      WRITE(MW0,*)'*** ALGEB3: decreasing MXSOC from ',IXSOC,' to: '
!                ,IRKP
!
        CALL RE_ALLOC(DRKP,IONE,IXSOC,IRKP,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB3: RE-ALLOCATION FAILS FOR DRKP...',IERR
          NF=0
          GO TO 2100
        ENDIF
!
        CALL RE_ALLOC(NRKP,IONE,IXSOC,IRKP,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB3: RE-ALLOCATION FAILS FOR NRKP...',IERR
          NF=0
          GO TO 2100
        ENDIF
!
        IXSOC=IRKP
!
      ENDIF
!
      IXXX=(4*MAXMI)/5
      IF(bnom1bp2.and.IAXMI.GT.0.and.NL.LT.IXXX)THEN
!
!        WRITE(MW6,*)'*** ALGEB3: decreasing MAXMI from ',IAXMI,' to: '
!                  ,NL
!        WRITE(MW0,*)'*** ALGEB3: decreasing MAXMI from ',IAXMI,' to: '
!                  ,NL
!
        CALL RE_ALLOC2(QSS,IONE,IFIVE,IONE,IAXMI,IFIVE,NL,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB3: RE-ALLOCATION FAILS FOR QSS...',IERR
          NF=0
          GO TO 2100
        ENDIF
!
        IAXMI=NL
!
      ENDIF
!
      IXXX=(4*MXRSS)/5
      IF(bnom1bp2.and.IXRSS.GT.0.and.IRS.LT.IXXX)THEN
!
!       WRITE(MW6,*)'*** ALGEB3: decreasing MXRSS from ',IXRSS,' to: '
!                 ,IRS
!       WRITE(MW0,*)'*** ALGEB3: decreasing MXRSS from ',IXRSS,' to: '
!                 ,IRS
!
        CALL RE_ALLOC(DSS,IONE,IXRSS,IRS,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB3: RE-ALLOCATION FAILS FOR DSS...',IERR
          NF=0
          GO TO 2100
        ENDIF
!
        CALL RE_ALLOC(MSS,IONE,IXRSS,IRS,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB3: RE-ALLOCATION FAILS FOR MSS...',IERR
          NF=0
          GO TO 2100
        ENDIF
!
        IXRSS=IRS
!
      ENDIF
!
!-----------------------------------------------------------------------
!
 2100 CONTINUE
!
! LOCAL
      IF(ALLOCATED(QJI))DEALLOCATE(QJI)
!
      IF(ALLOCATED(B1B))THEN
        DEALLOCATE(B1B,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB3: DE-ALLOCATION FAILS FOR B1B'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(B2B))THEN
        DEALLOCATE(B2B,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB3: DE-ALLOCATION FAILS FOR B2B'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(KSTART))DEALLOCATE(KSTART)
!
! EX-COMMON/CFCT/
      IF(ALLOCATED(VCA))THEN
        DEALLOCATE(VCA,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB3: DE-ALLOCATION FAILS FOR VCA'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/CFCT/ - DO NOT MERGE WITH ABOVE!
      IF(ALLOCATED(VCB))THEN
        DEALLOCATE(VCB,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB3: DE-ALLOCATION FAILS FOR VCB'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/COEFFS/
      IF(ALLOCATED(DRKPS))THEN
        DEALLOCATE(DRKPS,QRLPS,NRKPS,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB3: DE-ALLOCATION FAILS FOR  DRKPS,QRLPS..'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/DMQSSS/
      IF(ALLOCATED(DSSS))THEN
        DEALLOCATE(DSSS,MSSS,QSSS,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB3: DE-ALLOCATION FAILS FOR DSSS,MSSS,QSSS'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NSTS1/
      IF(ALLOCATED(NADS1))THEN
        DEALLOCATE(NADS1,NSTJ1,NSTJ1D,IORIG1,JORIG1,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB3: DE-ALLOCATION FAILS FOR NADS1,NSTJ1...'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NSTS2/
      IF(ALLOCATED(NADS2))THEN
        DEALLOCATE(NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB3: DE-ALLOCATION FAILS FOR NADS2,NSTJ2...'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBAL3/                                ONLY IN ALGEB3 BRANCH
      IF(ALLOCATED(KCFSS))THEN
        DEALLOCATE(KCFSS,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB3: DE-ALLOCATION FAILS FOR KCFSS'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBFL0/
      IF(ALLOCATED(KINTI))THEN
        DEALLOCATE(KINTI,KINTF,KEN2,KPTCFM,MPOINT,STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB3: DE-ALLOCATION FAILS FOR KPTCFM, ETC.'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
! as we are done
!
      do i=1,mxorb
        if(qn(i).ge.60.and.qn(i).le.n69)then
          im=mod(int(qn(i),sp),i60)   !not safe to down-kind int(i60,qp)
          qn(i)=int(im,qp)
        endif
      enddo
!
!-----------------------------------------------------------------------
!
      RETURN                  !<-------------------RETURN
!
!-----------------------------------------------------------------------
!
!     E R R O R   M E S S A G E S
!
 2200 WRITE(MW6,10320)
      GO TO 2800
 2300 WRITE(MW6,10330)
      GO TO 2800
 2400 WRITE(MW6,10300)
      GO TO 2800
 2500 WRITE(MW6,10310)
      GO TO 2800
 2600 WRITE(MW6,10340)
      GO TO 2800
 2700 WRITE(MW6,10350)
!
 2800 WRITE(MW6,10360)
      WRITE(MW0,*)'***SR.ALGEB3: STORAGE EXCEEDED ***'
      IF(NF.GT.0)NF=-1
!OLD  NJO=-1                  !SWITCH-OFF IC, BUT CONTINUE LS RUN
      GO TO 2100                                  !RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(/" NOT ENOUGH VCC'S AVAILABLE FOR CALCULATION OF ",        &
     &       "RELATIVISTIC CORRECTIONS: CHANGE MOD  TO 1,-1 OR 0")
10020 FORMAT(I9,2I6,I9,2I6,F12.6)
10030 FORMAT(I9,2I6,I9,2I6,F12.6/(36X,I6,F12.6))
10040 FORMAT(/' SLATER STATE INTERACTION STORAGE (MXS1C,MXS1I)',I9,I6,  &
     &       10X,'USED:',I9,I6/34X,'(MXSTX)',6X,I9,16X,'USED:',I9)
10050 FORMAT(/' SLATER STATE INTERACTION STORAGE (MXS2C,MXS2I)',I9,I6,  &
     &       10X,'USED:',I9,I6)
10060 FORMAT(I9,2I6,I9,I6,41X,I12,I6)
10070 FORMAT(/73X,'(',I6,')',I11,7X,'MAXDK=',I11)
10080 FORMAT(/83X,I9,7X,'MXAAK=',I11)
10090 FORMAT(' EXPECT ALLOCATION IN SR.DIAGFS TO INCREASE NO. OF ',     &
     &     'MATRIX ELEMENTS MAXJU AS ABOVE, IF RADIATIVE RATES REQUIRED'&
     &     )
10100 FORMAT(/68X,'(',I11,')',I11,7X,'MAXJU=',I11)
10110 FORMAT(/' SR.ALGEB3: INCREASE MXAAK OR MAXDK - SEE ABOVE')
10120 FORMAT(6I5)
10130 FORMAT(' ',44X,'JGROUP=',I3,4X,'2J=',I2,3X,'PARITY=',I3,4X,'N0=', &
     &       I6//)
10140 FORMAT(/86X,I10,'=MTGD, MAXDC=',I10,' BUFFER STORAGE USED')
10150 FORMAT(I6,7X,4I5,I7)
10160 FORMAT(/' TOO MANY BOUND-FREE INTERACTIONS, EXPECT ',             &
     &       'ALLOCATION IN ','DIAGFS, TO INCREASE MXAAK TO',I11)
10170 FORMAT(//'   LV  2S+1   L   2J   CF    T',44X,                    &
     &       '**** LEVEL TABLE ****')
10180 FORMAT(/' SR.ALGEB3:  ALLOCATION INCREASES NUMBER OF LEVELS',     &
     &       ' IAXLV=',I7,' .GT. MAXLV=',I7)
10190 FORMAT(/' SR.ALGEB3:  ALLOCATION INCREASES NUMBER OF (J,P) GROUPS'&
     &       ,' IAXJG=',I3,' .GT. MAXJG=',I3)
10200 FORMAT(' NOTE: ALLOCATION IN SR.DIAGFS WILL INCREASE SIZE OF',    &
     &       ' SLJ MATRIX MAXDK AS BELOW')
10210 FORMAT(2I2,2X,2I2,2I5,F18.8,3X,A4)
10220 FORMAT(//1X,136('-')//)
10230 FORMAT(' *** USER-SUPPLIED LEVEL SYMMETRY RESTRICTIONS:'//)
10240 FORMAT('   LV  2J   P')
10250 FORMAT(1X,3I4)
10260 FORMAT(' MINJT=',I2,3X,'MAXJT=',I2)
10270 FORMAT(/' *** ALGEB3: YOU HAVE FLAGGED READ OF AN OLD LEVELS',    &
     &       ' FILE, BUT NONE CAN BE FOUND...'/12X,                     &
     &       'SWITCH-OFF FLAG AND',                                     &
     &      ' RE-RUN (FOR ENERGIES ONLY) TO GENERATE ONE (EFFEICIENTLY)'&
     &      )
!w 1123 FORMAT(/'*** IN LARGE CASES IT IS MORE EFFICIENT TO READ A'
!w     X,' "LEVELS" FILE GENERATED BY A PRIOR (ENERGIES ONLY) RUN')
10280 FORMAT(56X,I12,2I6,I9,I6,3(I5,F9.4))
10290 FORMAT(56X,I12,2I6,I9,I6,3(I5,F9.4)/(95X,3(I5,F9.4)))
10300 FORMAT(' STORAGE MAYBE EXCEEDED IN SR.RES2: INCREASE  MXRSS OR',  &
     &       ' MAXMI')
10310 FORMAT(' STORAGE EXCEEDED IN SR.RES1: INCREASE  MXS2C OR',        &
     &       ' MXS2I')
10320 FORMAT(' STORAGE EXCEEDED IN SR.SPOR2: AUGMENT  MXSOC OR',        &
     &       ' MXSOI')
10330 FORMAT(' STORAGE EXCEEDED IN SR.SPOR1: INCREASE  MXS1C OR',       &
     &       ' MXS1I')
10340 FORMAT(' *** SR.ALGEB3: I*4 OVERFLOW ON 2-BODY FINE-STRUCTURE'/   &
     &       '    SET KUTSS=-1 TO SWITCH-OFF, OR REDUCE PROBLEM SIZE')
10350 FORMAT(//' *** SR.ALGEB3: I*4 WILL OVERFLOW FOR DIAGFS TFU ARRAY',&
     &       ' INDEX, RECOMPILE FORCING I*8 OR SWITCH-OFF RADIATION/PI' &
     &       //)
10360 FORMAT(//' **** SR.ALGEB3: STORAGE EXCEEDED - UNABLE TO ALLOCATE',&
     &       ' ANY MORE MEMORY - REDUCE SIZE OF PROBLEM ****'//)
10370 FORMAT(/' SPIN-ORBIT PARAMETER REFERENCE LIST'/'  I(Z)',6X,       &
     &       'ZETA(     A    B)= SPIN-ORBIT PARAMETERS')
10380 FORMAT(I6,12X,2I5)
10390 FORMAT(/' REFERENCE LIST OF MAGNETIC INTEGRALS N AND V'/' INDEX', &
     &       5X,'N(    A    B    C    D   2LBD+200)',7X,'INDEX',2X,     &
     &       'V(    A    B    C    D   2LBD+100)')
10400 FORMAT(51X,I6,4X,4I5,I7)
10410 FORMAT(//'  ALGEBRA OF THE SPIN-ORBIT INTERACTION ',4X,'KUTSO =', &
     &       I3,9X,                                                     &
     &       ' ALGEBRA OF THE SPIN-SPIN (C), MUTUAL SPIN-ORBIT (A)'/67X,&
     &       'AND THE SPIN-OTHER-ORBIT (B) INTERACTIONS',10X,'KUTSS =', &
     &       I4,A1)
10420 FORMAT(//' CONFIGURATIONS FOR WHICH TWO-BODY FINE-STRUCTURE',     &
     &     ' INTERACTIONS ARE EVALUATED; IN ADDITION TO THOSE SPECIFIED'&
     &     ,' BELOW BY KUTSS'/)
10430 FORMAT(I4)
10440 FORMAT(4X,'MXADJ MAXLV MAXLV    MXSOC MXSOI',27X,'MXADJ MAXLV ',  &
     &       'MAXLV    MXRSS MAXMI'/I9,2I6,I9,I6,2X,                    &
     &       'STORAGE RESTRICTIONS ',I9,2I6,I9,I6/7X,'NP',4X,'LV',3X,   &
     &       'LVP',7X,'CN',3X,'IND',2X,'I(Z)',6X,'C(A,B)',12X,'NP',4X,  &
     &       'LV',3X,'LVP',7X,'CN',3X,'IND',3(3X,'I(Y) X(A-D)'))
10450 FORMAT(' SR.ALGEB3: ALLOCATION INCREASES NUMBER OF MATRIX ',      &
     &       ' ELEMENTS IADJ =',I10,' .GT. MXADJ=',I10)
10460 FORMAT(/' *** PRINTOUT OF COEFFICIENTS C, D AND E SUPPRESSED BY', &
     &       ' MPRINT .LE. 0')
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION MVC(MLX,MLY)
!
      INTEGER(SP) MLX,MLY,MVC
!
      MVC=((MLX+2)*MLX/2+MLY)/2+1
!
      END FUNCTION MVC
!-----------------------------------------------------------------------
!
      END SUBROUTINE ALGEB3
!
!                             *******************
!
      SUBROUTINE ALGEB4(MAM,NAM,QLMC,QBML,QBMS,JYI,JYF,MAXEL)
!
!-----------------------------------------------------------------------
!
!  SR.ALGEB4 WORKS OUT RADIATIVE MK ALGEBRA, INCLUDING BP CORRECTIONS
!  TO M1 AND E1VEL.
!
!  IT IS CALLED BY:
!    SR.ALGEB
!
!  IT CALLS;
!    SR.DISKDC
!    SR.DIMUSE
!    SR.MKALG1
!    SR.MKALG2
!    SR.NRB_TIME
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!    FN.VCC
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam                            !par
!
      USE COMMON_ALGEB,  ONLY: MPRINT
      USE COMMON_ALGEB,  ONLY: MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD     &
     &                        ,KFBUFF
      USE COMMON_ALGEB,  ONLY: BFOT
!!      COMMON /BASIC/NF,KF,KG,JA,JB,JAP,JBP,JGAP,ND1,NDP1,ND2,NDP2
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,JA=>IBSK4,JB=>IBSK5            &
     &              ,JAP=>IBSK6,JBP=>IBSK7,IBSK8=>IBSK8,ND1=>IBSK9      &
     &              ,NDP1=>IBSK10,ND2=>IBSK11,NDP2=>IBSK12
      USE COMMON_COEFF,  ONLY: DRKP,QRLP,IRLP,NRKP,IWORD1               &
     &                        ,MXSOC0,MXSOI0,IPLANT_SOI
      USE COMMON_COEFF,  ONLY: IRKP,IRKP0
      USE COMMON_COEFFS, ONLY: DRKPS,QRLPS,NRKPS                        &
     &                        ,MXS1C0,MXS1I0
      USE COMMON_COEFFS, ONLY: IRKPS,IRKPS0,IRLPS,IRLPS0
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DC,     ONLY: BFAST,DC,IDC,IXIDC
      USE COMMON_DMQSS3, ONLY: DSS,MSS,QSS,IWORD2                       &
     &                        ,MAXMI0,MXRSS0,IPLANT_MI                  &
     &                        ,IRS,IRS0,NL000=>NL,NL=>NL000
      USE COMMON_DMQSSS, ONLY: DSSS,MSSS,QSSS,MXS2I0,MXS2C0
      USE COMMON_DMQSSS, ONLY: IRSS,IRSS0,NLS,NLS00
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
      USE COMMON_NRBGCF, ONLY: KGSL,KGCF,NKSL
      USE COMMON_NSTS1,  ONLY: NADS1,NSTJ1,NSTJ1D,IORIG1,JORIG1
      USE COMMON_NSTS2,  ONLY: NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2
      USE COMMON_QTG,    ONLY: MTGD,NXLL,NTT,NTG,JTGD,QTGS,QTGL,QTGD    &
     &                        ,NFI,NFK,NFQ
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      use common_misc,   only: iw,iwp,btime,btimex
!
!      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL2, ONLY: MDEL,MXORBR,MPOL00,MPOL0,MPOLE,MPOLX,CODE
      USE COMMON_NRBAL3, ONLY: MCFSS,KCFSS,KUTSS,KUTSO,QQCUT
      USE COMMON_NRBAL4, ONLY: MBP1MX,MBP2MX,MEKVMX,KUTM1,MPOLM,QCUT
      USE COMMON_NRBAL4, ONLY: DVC12,NC0X,MJS1,MJL1,MJS2,MJL2,MJJL,MJJR &
     &                  ,NC,ND,ICLR,QLIT,BLX1,BLX2,BMSKIP,BOSKIP,BM1BODY
      USE COMMON_NRBAL4, ONLY: DVC,MJ1,MJ2,MLAM,BE1CASE
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBGRJ, ONLY: NSLJ,NGSLJ
      USE COMMON_NRBMKP, ONLY: NMD1,NMD2
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,IBUFF4
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (IW12=MAX(IWORD1,IWORD2))
!
      INTEGER(IW12) NTMP
!
      CHARACTER(LEN=1) CQLIT,MP
!
      DIMENSION MAM(*),NAM(*),JYI(*),JYF(*)                             &
     &         ,QLMC(MAXEL,*),QBML(*),QBMS(*)
!
      DIMENSION CQLIT(10)
!
      ALLOCATABLE :: B1B(:),B2B(:),KSTART(:,:),VC1(:),ITMP(:)
      ALLOCATABLE :: MMD1(:,:,:),MMD2(:,:,:),TMP(:),NTMP(:)
!
      DATA MG/-2/,BDEBUG1/.FALSE./
      DATA CQLIT/'0','1','2','3','4','F','S','Q','W','X'/
!
!-----------------------------------------------------------------------
!
      BLOCAL=.FALSE.
!
      NL=NL000
!OLD      NL=NL000-1
!
! HOLD ORIGINAL VALUES
!               N.B. NL000 IS ALREADY ORIG NL (ORDER SWAPPED IN /NXRNL/)
      IRS000=IRS
      IRLP000=IRLP
      IRKP000=IRKP
!
      IF(NJO.LE.0)GO TO 700
!     BECAUSE ALL I.C. CALCULATIONS HAVE BEEN SWITCHED OFF.
!
      IF(MPRINT.EQ.MG)GO TO 700
!     BECAUSE ON INPUT RADIATIVE CALCULATIONS HAVE BEEN SUPPRESSED.
!
      IF(MPRINT.EQ.-1.OR.MPRINT.EQ.-4)GO TO 700
!     BECAUSE ELECTRIC DIPOLE ONLY.
!
      MMAX0=MIN(MPOLE-2,MPOLM)                  !AS MPOLM NOT IN RESTART
      MMIN0=MAX(MPOL0-2,ITWO)
      IF(MMIN0.GT.MMAX0)GO TO 700
!     BECAUSE NO VALID MAGNETIC MULTIPOLE.
!
      IF(MBP1MX.LT.2.AND.MMAX0.LT.4.AND.MEKVMX.LT.2)GO TO 700
!     BECAUSE ONLY ORDINARY M1 - USE TRIVIAL DIAGFS CODING -
!     NOTE: MBP1MX<0 SWTCHES-OFF M1 IN DIAGFS AS WELL.
!
! CHECK WORD LENGTHS
!
      ITEST4=IBUFF4
      ITEST4=ITEST4+1
!
      IF(IWORD1.EQ.4.AND.ITEST4.LT.IBUFF4)THEN                !I.E. SP=4
        IPLANT_SOI=INT(IBUFF4/NLEV,SP)
!          write(mw0,*)ixsoi,iplant_soi,ibuff4,nlev,kind(iplant_soi)
        IF(IXSOI.GT.IPLANT_SOI)THEN         !NEED TO CHECK RE-ALLOCATION
          WRITE(MW0,*)'ALGEB4: I*4/SP TOO SHORT FOR 1-BODY M_K RAD'
          WRITE(MW6,*)'ALGEB4: CHANGE TO I*8/EP IN MODULE COMMON_COEFF'
          NF=0
          GO TO 300
        ENDIF
      ELSE
        IPLANT_SOI=IBUFF4                                     !I.E. SP=8
      ENDIF
!
      IF(MBP2MX.GT.0.AND.IWORD2.EQ.4.AND.ITEST4.LT.IBUFF4)THEN     !SP=4
        IPLANT_MI=INT(IBUFF4/NLEV,SP)
        IF(IAXMI.GT.IPLANT_MI)THEN          !NEED TO CHECK RE-ALLOCATION
          WRITE(MW0,*)'ALGEB4: I*4/SP TOO SHORT FOR 2-BODY M_K RAD'
          WRITE(MW6,*)'ALGEB4: CHANGE TO I*8/EP IN MODULE COMMON_DMQSS3'
          NF=0
          GO TO 300
        ENDIF
      ELSE
        IPLANT_MI=IBUFF4                                      !I.E. SP=8
      ENDIF
!
! EX-COMMON/NRBMKP/
!
      ALLOCATE(NMD1(2,NJO,NLEV),NMD2(2,NJO,NLEV),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB4: ALLOCATION FAILS FOR  NMD1,NMD2'
        NF=0
        GO TO 300
      ENDIF
!
! EX-COMMON/COEFFS/
!
!      IXS1C=MAX(MXS1C0,MXS1C,IXS1C)               !USE LARGEST PREVIOUS
      IXS1C=MAX(MXS1C0,MXS1C)                     !RESET, ELSE ALGEB3
!      IXS1I=MAX(MXS1I0,MXS1I,IXS1I)               !USE LARGEST PREVIOUS
      IXS1I=MAX(MXS1I0,MXS1I)                     !RESET, ELSE ALGEB3
!
      ALLOCATE(DRKPS(IXS1C),QRLPS(4,IXS1I),NRKPS(IXS1C),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB4: ALLOCATION FAILS FOR  DRKPS,QRLPS,NRKPS'
        NF=0
        GO TO 300
      ENDIF
!
! EX-COMMON/NSTS1/
!
      IXXX1=MAX(IXS1I,IXSOI)
      IXD27=KMAX*KMAX
!
      ALLOCATE(NADS1(0:IXD27),NSTJ1(IXS1C),NSTJ1D(IXS1C),IORIG1(IXXX1), &
     &         JORIG1(IXS1I),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB4: ALLOCATION FAILS FOR NADS1,NSTJ1, ETC'
        NF=0
        GO TO 300
      ENDIF
!
! TWO-BODY
!
      IF(MBP2MX.LT.2)THEN
        IXS2C=0
        IXS2I=0
        IXXX2=0
!        IXD27=0                                   !NEED NADS2 TO FLAG
      ELSE
        IXS2C=MAX(MXS2C0,MXS2C,IXS2C)             !USE LARGEST PREVIOUS
!        IXS2C=MAX(MXS2C0,MXS2C)                   !RESET
        IXS2I=MAX(MXS2I0,MXS2I,IXS2I)             !USE LARGEST PREVIOUS
!        IXS2I=MAX(MXS2I0,MXS2I)                   !RESET
!
        IXXX2=MAX(IXS2I,IAXMI)
      ENDIF
!
! EX-COMMON/DMQSSS/
!
      ALLOCATE(DSSS(IXS2C),MSSS(IXS2C),QSSS(5,IXS2I),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB4: ALLOCATION FAILS FOR  DSSS,MSSS,QSSS'
        NF=0
        GO TO 300
      ENDIF
!
! EX-COMMON/NSTS2/
!
      ALLOCATE(NADS2(0:IXD27),NSTJ2(IXS2C),NSTJ2D(IXS2C),IORIG2(IXXX2), &
     &         JORIG2(IXS2I),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB4: ALLOCATION FAILS FOR NADS2,NSTJ2, ETC'
        NF=0
        GO TO 300
      ENDIF
!
! LOCAL (TBD: USE ACTUAL DIMENSIONS FOR MXD23)
!
      IAXDK=0
      IXD22=0
      DO N=1,NJO
        IAXDK=MAX(IAXDK,NT(N))
        IXD22=MAX(IXD22,NGSLJ(N))
      ENDDO
      IXD23=15*IAXDK+2000                  !INITIAL ALLOC, WILL RE-ALLOC
!
      ALLOCATE(MMD1(2,IXD22,IAXDK),MMD2(2,IXD22,IAXDK),TMP(IXD23),      &
     &         NTMP(IXD23),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB4: ALLOCATION FAILS FOR  MMDX,TMP'
        NF=0
        GO TO 300
      ENDIF
      BLOCAL=.TRUE.
!
      BFAST=DC(0).LT.DZERO                 !ELSE OPT MEMORY
!
! CHECK KCUT (AND VIA OLD QCUT)
!
      DO I=1,10
        QLIT(I)=INT(ICHAR(CQLIT(I)),QP)
      ENDDO
!
      BLPT=MPRINT.GT.0
!
      KUT=KCUT
      DO I=1,7
        IF(QLIT(I).EQ.QCUT)THEN
          IF(I.EQ.6)THEN
            KUT=KMAX
            GO TO 100
          ENDIF
          IF(I.LT.6)THEN
            KUT=I-1
            GO TO 100
          ENDIF
          KUT=KUTSS
        ENDIF
      ENDDO
!
      IF(KUT.LT.0)GO TO 800           !NONE, FLAG AND RETURN
      IF(KUT.EQ.0)KUT=KMAX
      IF(KUTM1.NE.0)KUT=ABS(KUTM1)
!
  100 IF(ABS(MBP2MX).GT.0)THEN       !THERE EXISTS 1/2-BODY BP ALG
        WRITE(MW6,10080)KUT,CHAR(QCUT)
      ELSE                            !JUST 1-BODY NON-BP
        WRITE(MW6,10090)
      ENDIF
!
!-----------------------------------------------------------------------
!
! FLAG EXISTENCE, OR NOT, OF ONE- AND TWO-BODY INTERACTIONS BETWEEN
! CONFIGURATION PAIRS
!
!-----------------------------------------------------------------------
!
! LOCAL
      IXD19=(KMAX*(KMAX+1))/2
!
      ALLOCATE(B1B(IXD19),B2B(IXD19),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB4: ALLOCATION FAILS FOR B1B,B2B'
        NF=0
        GO TO 300
      ENDIF
!
! SMALL
      IF(KUTDSK.LT.KMAX)ALLOCATE(KSTART(KMAX,2))
      ALLOCATE(ITMP(NF))
!
      IFOTMX=0
      IF(BFOT)IFOTMX=1
!
      KK=0
      DO KF=1,KMAX                                        !BEGIN KF LOOP
        II=IEQ(QCG(NF,KF))
        KCF=0
        IF(QN(II).GE.90)KCF=1                                 !CONTINUUM
!
        DO KG=1,KF                                        !BEGIN KG LOOP
          KK=KK+1
!
          B1BODY=.FALSE.
          B2BODY=.FALSE.
!
          II=IEQ(QCG(NF,KG))
          KCG=0
          IF(QN(II).GE.90)KCG=1
          IF(KCF+KCG.GT.IFOTMX)GO TO 140               !DOES NOT CONTRIB
!
          BE1CASE=QCP(KF).NE.QCP(KG)
          BMSKIP=KG.GT.KUT.AND.KF.GT.KUT
          BOSKIP=KF.GT.KUT.OR.KG.GT.KUT
          IF(BE1CASE)BOSKIP=BMSKIP
          BQCUT=QCUT.NE.QLIT(8).AND.QCUT.NE.QLIT(9).AND.KUTM1.GE.0
                                                       !SO BMSKIP=BOSKIP
!
! FIND NUMBER MK/2 OF ELECTRON PAIRS IN WHICH KF AND KG DIFFER
! AND THEN SEE IF THIS CF PAIR CONTRIBUTES
!
          DO I=1,NF
            ITMP(I)=QCG(I,KG)
          ENDDO
          MK=0
          DO I=1,NF
            ICG=IEQ(QCG(I,KF))
            DO L=1,NF
              IF(IEQ(ITMP(L)).EQ.ICG)THEN
                ITMP(L)=0
                GO TO 120
              ENDIF
            ENDDO
            MK=MK+2
            IF(MK.EQ.2)LD1=QCG(I,KF)
  120     ENDDO
!
          IF(MK.GT.4)GO TO 140                      !THREE PAIRS OR MORE
          IF(MK.EQ.4.AND.(MBP2MX.LE.0.OR.BE1CASE))GO TO 140 !NO TWO-BODY
!
! SEE IF WE NEED TWO-BODY
!
          IF(.NOT.BOSKIP.AND.NF.GT.1.AND..NOT.BE1CASE)B2BODY=.TRUE.  !M1
          IF(.NOT.B2BODY.AND.MK.EQ.4)GO TO 140
!
! SEE IF ONE-BODY EXISTS
!
          IF(MK.EQ.2)THEN
            DO L=1,NF
              IF(ITMP(L).NE.0)THEN
                LD2=QCG(L,KG)
                GO TO 130
              ENDIF
            ENDDO
  130       LDD=ABS(QL(LD1)-QL(LD2))
            IF(LDD.GT.MPOLE)LDD=-1
          ELSEIF(MK.EQ.4)THEN
            LDD=-1
          ELSE
            LDD=1
          ENDIF
          B1BODY=LDD.GE.0
!
! FLAG WHETHER KF-KG NEEDED
!
  140     B1B(KK)=B1BODY
          B2B(KK)=B2BODY
!
!          write(mw0,*)kf,kg,b1body,b2body
!
        ENDDO                                   !END LOOP KG
!
      ENDDO                                     !END LOOP KF
!
!
!-----------------------------------------------------------------------
!
!   START CALCULATION OF THE ALGEBRA FOR MAGNETIC MULTIPOLES
!   VIZ. 1-BODY ALL MULTIPOLES AND 2-BODY BP CORRECTIONS TO DIPOLE
!
!-----------------------------------------------------------------------
!
      irlp=-irlp             !flag end of structure integrals for mkalg2
!
!OLD      NL=NL000
      ja=2
      jap=2
!
!t      mc0x=0
      IF(MBP2MX.LE.0.AND.MEKVMX.LE.0)THEN
        NC0X=0
        ALLOCATE(VC1(1))              !AS PASSED TO MKALG1 VIA ARGUMENT
      ELSE                            !SHOULD ONLY BE LOW-L HERE, BUT...
!
        NC0X=(NXLL+2)*2                         !m1+bp only *3->*2
        ALLOCATE(VC1(NC0X))
!
        IF(2*(NC0X+2).GT.IXDFS)THEN
          WRITE(MW6,10060)IXDFS,2*(NC0X+2)
          NF=-1
          GO TO 300
        ENDIF
        DO J=1,NC0X
          LL=(J/2)*2
          LM=LL-2
          IF(LL.NE.J)LM=LL+2
          VC1(J)=VCC(LL,ITWO,LM,IZERO,IZERO,IZERO)
        ENDDO
      ENDIF
!
      MXIRKS=0
      MXIRLS=0
      MXIRSS=0
      MXNLS=0
!
      DO J=1,NLEV                               !INITIALIZE (FOR SAFETY)
        DO K=1,NJO
          NMD1(1,K,J)=0
          NMD1(2,K,J)=-1
          NMD2(1,K,J)=0
          NMD2(2,K,J)=-1
        ENDDO
      ENDDO
!
!-----------------------------------------------------------------------
!
! CHECK BUFFERS FOR DC ARRAY IF DISKDC IN USE
!
!-----------------------------------------------------------------------
!
      MDCBUF4=0
      IF(KUTDSK.LT.KMAX)THEN
        IEND=MTGD                                            !FOR DISKDC
        MTGD1=MTGD+1
        CALL DISKDC(IUD,IONE,IZERO,IZERO,IZERO,IZERO,IZERO)
                                                         !REPOINT
!
        IF(KUTDSK.LT.KFBUFF)THEN
          DO K=1,NSL0
            MTGD1=MTGD+1                                        !RESTORE
            DO KF=KUTDSK+1,KFBUFF
              NGSYM=KGSL(KF,K)                            !POS WITHIN CF
              IF(NGSYM.GT.0)THEN
!
                do kg=1,kmax
                  k1=max(kf,kg)
                  k2=min(kf,kg)
                  kk=(k1*(k1-1))/2+k2
                  if(b1b(kk).or.b2b(kk))go to 142          !need this kf
                enddo
                go to 150
!
  142           ISTRT=MTGD1
!
                CALL DISKDC(IUD,ISTRT,IFIN,KF,NGSYM,IZERO,IZERO)
!
                MTGD1=IFIN+1
              ENDIF
  150       ENDDO
            IFIN=MTGD1-1
            MDCBUF4=MAX(MDCBUF4,IFIN)
          ENDDO
          MDCBUF4=MDCBUF4+MDCBUF4-mtgd
          IF(MDCBUF4.GT.MDCBUF)THEN
!
            if(MDCBUF.ne.IAXDC)stop 'algeb4: buffer index error...'
!
            IXXX=MDCBUF4
!
            WRITE(MW6,*)'*** ALGEB4: increasing MAXDC from ',IAXDC,     &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** ALGEB4: increasing MAXDC from ',IAXDC,     &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC(DC,IZERO,MTGD,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'ALGEB4: RE-ALLOCATION FAILS FOR DC',IERR
              NF=0
              GO TO 300
            ENDIF
!
            IF(.NOT.BFAST)THEN
!
              CALL RE_ALLOC(IDC,IONE,MTGD,IXXX,IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)'ALGEB4: RE-ALLOCATION FAILS FOR IDC',IERR
                NF=0
                GO TO 300
              ENDIF
!
            ENDIF
!
            IAXDC=IXXX
            MDCBUF=IAXDC
          ENDIF
          MDCBUF4=0
        ELSE
          MDCBUF4=MDCBUF
          DO I=1,2
            DO K=KFBUFF+1,KMAX
              KSTART(K,I)=0
            ENDDO
          ENDDO
        ENDIF
      ENDIF
!
      if(btime)then
        time1=dzero
        time2=dzero
      endif
!
! START LOOP STRUCTURE
!
      NCJ=0
      DO K=1,NJO                       !BEGIN UPPER LOOP OVER JP GROUPS
        MJJL=JN(NCJ+1)
!
        NCJ0=0
        DO NGJ1=1,NGSLJ(K)             !BEGIN UPPER LOOP OVER SLP GROUPS
!
          NC=NSLJ(NGJ1,K)
          MJL1=QLI(NC)
          MJS1=QSI(NC)
          N0=NSL(NC)
!
          IF(KUTDSK.LT.KFBUFF)THEN
            MTGD1=MTGD+1                                        !RESTORE
            DO KF=KUTDSK+1,KFBUFF                !LOAD INITIAL GROUP VCC
              KSTART(KF,1)=0
              NGSYM=KGSL(KF,NC)                           !POS WITHIN CF
              IF(NGSYM.GT.0)THEN
!
                do kg=1,kmax
                  k1=max(kf,kg)
                  k2=min(kf,kg)
                  kk=(k1*(k1-1))/2+k2
                  if(b1b(kk).or.b2b(kk))go to 152          !need this kf
                enddo
                kstart(kf,1)=mtgd1
                                !dummy, else alternate kf read triggered
                go to 160
!
  152           ISTRT=MTGD1
                KSTART(KF,1)=ISTRT
!
                CALL DISKDC(IUD,ISTRT,IFIN,KF,NGSYM,IONE,IZERO)
!
                MTGD1=IFIN+1
                IF(IFIN.LT.0)THEN         !FAILURE TO READ REQUIRED DATA
                  NF=-1
                  GO TO 300
                ENDIF
              ENDIF
  160       ENDDO
            MHOLD=MTGD1
            IFIN=MTGD1-1
          ENDIF
!
          NCJP=0
          DO KP=1,K                     !BEGIN LOWER LOOP OVER JP GROUPS
!
            IF(NMETGJ(K)+NMETGJ(KP).GT.1)GO TO 210
!        IF(K.EQ.KP.AND.NT(K).EQ.1)GO TO 2500            !need for lande
!
            MJJR=JN(NCJP+1)
            ND=NSLJ(1,KP)
            BE1CASE=QPI(ND).NE.QPI(NC)
            MMIN=MAX(MMIN0,ABS(MJJR-MJJL))
            MMAX=MIN(MMAX0,MJJR+MJJL)
            IF(BE1CASE)BE1CASE=MMIN.EQ.2.AND.MEKVMX.GT.0
            IF(.NOT.BE1CASE)THEN
              IF(MOD(QPI(ND)+QPI(NC)+MMIN,IFOUR).EQ.0)MMIN=MMIN+2
              IF(MOD(QPI(ND)+QPI(NC)+MMAX,IFOUR).EQ.0)MMAX=MMAX-2
              BODD=(1-MOD(MMIN,IFOUR)).GT.0.OR.(MMAX-MMIN).GT.0
              BEVEN=(1-MOD(MMIN,IFOUR)).LT.0.OR.(MMAX-MMIN).GT.0
            ELSE
              BODD=.TRUE.
              BEVEN=(MMAX-MMIN).GT.0
            ENDIF
            IF(MMIN.GT.MMAX)GO TO 210
!
            NCJP0=0
            NGJP1X=NGSLJ(KP)
            IF(NGJP1X.GT.IXD22)GO TO 400
                                       !SHOULD NOT HAPPEN NOW
            IF(K.EQ.KP)NGJP1X=NGJ1
            DO NGJP1=1,NGJP1X          !BEGIN LOWER LOOP OVER SLP GROUPS
!
              ND=NSLJ(NGJP1,KP)
              MJL2=QLI(ND)
              MJS2=QSI(ND)
              N0P=NSL(ND)
!
              BEQUGRP=K.eq.KP.and.nc.eq.nd   !nc.eq.nd missing since v18
              if(bequgrp.and.ngj1.ne.ngjp1)then
                stop 'bequgrp.and.ngj1.ne.ngjp1'
              endif
              if(k.eq.kp.and.nc.ne.nd.and.ngj1.eq.ngjp1)then
                stop '.not.bequgrp.and.ngj1.eq.ngjp1'
              endif
!
              if(btime)call nrb_time(timei)
!
              IRKPS=0
              IRLPS=0
              IRSS=0
              NLS=0
!
              NADS1(0)=0
              NADS2(0)=0
!
              KK=0
              K2=KMAX
              DO KF=1,KMAX                                !BEGIN KF LOOP
!
                IFLG=0
                IF(KGSL(KF,NC).GT.0)IFLG=1      !CF CONTRIBS TO SL GROUP
!
                IF(BEQUGRP)K2=KF
!
                DO KG=1,K2                                !BEGIN KG LOOP
                  KK=KK+1
                  IF(IFLG.EQ.0)GO TO 182                     !JUST INDEX
!
                  IF(.NOT.BEQUGRP)THEN
                    K0=MIN(KF,KG)
                    K1=MAX(KF,KG)
                    KB=(K1*(K1-1))/2+K0
                  ELSE
                    KB=KK
                  ENDIF
!
                  B1BODY=B1B(KB)
                  B2BODY=B2B(KB)
                  IF(.NOT.B1BODY.AND..NOT.B2BODY)GO TO 182
                  IF(QCP(KG).NE.QPI(ND))GO TO 182
                  IF(QCP(KF).EQ.QCP(KG).AND..NOT.BEVEN)GO TO 182
                  IF(QCP(KF).NE.QCP(KG).AND..NOT.BODD)GO TO 182
                  IF(.NOT.B1BODY.AND.MBP2MX.LT.MMIN)GO TO 182
                                                         !NO 2-BODY HERE
!
                  IF(KGSL(KG,ND).LE.0)GO TO 182
                                            !CF DOES NOT CONTRIB TO S'L'
!
                  BMSKIP=KG.GT.KUT.AND.KF.GT.KUT
                  BOSKIP=KF.GT.KUT.OR.KG.GT.KUT
                  IF(BE1CASE)BOSKIP=BMSKIP
                  IF(BQCUT)BMSKIP=BOSKIP
                  IF(B1BODY)THEN
                    MK=2
                    IF(KF.EQ.KG)MK=0
                  ELSE
                    MK=4
                  ENDIF
!
! NOW DETERMINE INTERACTION BETWEEN KF AND KG FOR THESE CSLJP GROUPS
!
                  JL1=JYI(KF)
                  JL2=JYF(KF)
                  JR1=JYI(KG)
                  JR2=JYF(KG)
!      write(mw6,*)"$",k,ngj1,kf,kp,ngjp1,kg
!
                  IRKPS0=IRKPS+1
                  IRLPS0=IRLPS
                  IRSS0=IRSS+1
                  NLS00=NLS
!
! BEGIN LOOP OVER MAGNETIC MULTIPOLES MLAM/2:
!                                       MLAM=MPOL0-2,MPOLE-2,4 AS MPOL E
!
                  BE1CASE=QPI(ND).NE.QPI(NC).AND..NOT.boskip
                                                          !RE-INITIALIZE
                  IF(BE1CASE)BE1CASE=MMIN.EQ.2.AND.MEKVMX.GT.0
!
                  MLAM=MMIN
  162             MLAMH=MLAM/2
!
                  IF(BDEBUG1)THEN
                    MP='M'
                    IF(BE1CASE)MP='E'
                  ENDIF
!
                  BM1BODY=BE1CASE.OR.MLAM.GT.MBP2MX
                                                  !SO NO 2-BODY BP TO MK
!
!    IF(MBP1MX+MBP2MX.EQ.0.AND.MLAM.EQ.2.AND.IT.NE.ITP.AND..NOT.BE1CASE)
                  IF(MLAM.EQ.2)THEN
                    IF(BE1CASE)THEN
! ?????
                    ELSE
                      IF(MBP1MX+MBP2MX.EQ.0.AND.IT.NE.ITP)GO TO 180
                                                            !ORDINARY M1
                      IF(BMSKIP.AND.KF.NE.KG)GO TO 180
                    ENDIF
                  ENDIF
!      write(mw6,*)ngj1,ngjp1,mjjr,mjjl,nc,nd,mmin,mlam,mmax,be1case
!
! FIND A NONVANISHING MULTIPOLE MATRIX ELEMENT
!
                  ICLR=1
                  K0=0
                  MJ1=MJJL
  164             MJ2=MJJR
  166             MLK=MJ1-MJ2
                  ML2=-MJ2
!
                  DVC=VCC(MJJL,MJJR,MLAM,MJ1,ML2,MLK)
!
                  IF(DVC.NE.DZERO)THEN
                    IF(MODD.LE.0)GO TO 168
                    IF(MJ1.LE.1.AND.MJ2.LE.1)GO TO 168
                    K0=1
                  ENDIF
!
                  MJ2=MJ2-2
                  IF(MJ2.GE.0)GO TO 166
                  MJ1=MJ1-2
                  IF(MJ1.GE.0)GO TO 164
                  IF(MODD*K0.LE.0)GO TO 180
                  WRITE(MW6,10120)
                  GO TO 800
!
!---- BEGIN TAKE OUT
!
  168             IRKPS0=IRKPS+1
                  IRLPS0=IRLPS
                  IRSS0=IRSS+1
                  NLS00=NLS
!
                  MS1=MJS1
!      IF(DEBUG)WRITE(MW6,400)IRKP,ND1,NDP1,MJJL,MJJR
  170             ML1=MJ1-MS1
                  BLX1=MS1.NE.-MJS1.AND.ML1.NE.MJL1
                  IF(ML1.LT.-MJL1)GO TO 178
!
                  JB=1
                  DO I=JL1,JL2
                    IF(QBML(I).EQ.ML1.AND.QBMS(I).EQ.MS1)THEN
                      JB=JB+1
                      MAM(JB)=I
                    ENDIF
                  ENDDO
!
                  IF(JB.LT.JA)GO TO 178
!
                  DVCL1=VCC(MJL1,MJS1,MJJL,ML1,MS1,MJ1)
!
                  MS2=MJS2
  172             ML2=MJ2-MS2
                  BLX2=MS2.NE.-MJS2.AND.ML2.NE.MJL2
                  IF(ML2.LT.-MJL2)GO TO 176
                  IF(ABS(MS2-MS1).GT.2)GO TO 176            !42
! RDD       IF(ABS(ML2-ML1).GT.4)GO TO 39
!
                  IF(MK.EQ.0.AND.ML2.EQ.ML1.AND.MS2.EQ.MS1)THEN
                    JBP=JB
                    DO I=JAP,JBP
                      NAM(I)=MAM(I)
                    ENDDO
                  ELSE
                    JBP=1
                    DO I=JR1,JR2
                      IF(QBML(I).EQ.ML2.AND.QBMS(I).EQ.MS2)THEN
                        JBP=JBP+1
                        NAM(JBP)=I
                      ENDIF
                    ENDDO
                    IF(JBP.LT.JAP)GO TO 176
                  ENDIF
!
                  DD2=VCC(MJL2,MJS2,MJJR,ML2,MS2,MJ2)
!
                  DVC12=DVCL1*DD2
                  IF(DVC12.EQ.DZERO)GO TO 176
!
                  IF(BDEBUG1)WRITE(MW6,10100)MK,MS1,ML1,MS2,ML2,IRKP,   &
     &                             DVC,DVCL1,DD2,JAP,JBP,MP,MLAMH
!
! DETERMINE SLATER STATE INTERACTION
!
  174             CALL MKALG1(QLMC,MAXEL,VC1,MAM,NAM)
!
                  MXIRKS=MAX(MXIRKS,IRKPS)
                  MXIRLS=MAX(MXIRLS,IRLPS)
                  MXIRSS=MAX(MXIRSS,IRSS)
                  MXNLS=MAX(MXNLS,NLS)
!
                  IF(NF.EQ.0)GO TO 600               !DIMENSION EXCEEDED
                  IF(NF.LT.0)GO TO 300               !INDEX ERROR
!
! IF .T. COMPUTE FOR DIFFERENT (MS,ML) GIVING THE SAME MS+ML=MJ
!
  176             MS2=MS2-2
                  IF(BLX2)GO TO 172
!
  178             MS1=MS1-2
                  IF(BLX1)GO TO 170
!
                  ICLR=-ICLR
                  IF(ICLR.NE.0)GO TO 174
!
!----   END TAKE OUT
!
  180             MLAM=MLAM+4
                  IF(BE1CASE)THEN
                    MLAM=MLAM-2
                    BE1CASE=.FALSE.
                  ENDIF
                  IF(MLAM.LE.MMAX)GO TO 162
!
  182             NADS1(KK)=IRKPS
                  NADS2(KK)=IRSS
!          write(mw6,*)kk,irkps,irss
!
                ENDDO                                     !END LOOP KG
!
              ENDDO                                       !END LOOP KF
!
              if(btime)then
                call nrb_time(timef)
                time1=time1+timef-timei
              endif
!
! NOW DETERMINE THE INTERACTION BETWEEN JP LEVELS OF THE CLSP GROUPS
!
              BE1CASE=QPI(ND).NE.QPI(NC)
                                     !.and..not.boskip    !RE-INITIALIZE
              BM1BODY=BE1CASE.OR.MMIN.GT.MBP2MX   !SO NO 2-BODY BP TO MK
!
              IF(KUTDSK.LT.KFBUFF)THEN
                MTGD1=MHOLD                                     !RESTORE
                DO KG=KUTDSK+1,KFBUFF              !LOAD FINAL GROUP VCC
                  IF(NC.EQ.ND)THEN
                    KSTART(KG,2)=KSTART(KG,1)
                  ELSE
                    KSTART(KG,2)=0
                    LGSYM=KGSL(KG,ND)                     !POS WITHIN CF
                    IF(LGSYM.GT.0)THEN
!
                      k1=1
                      if(bequgrp)k1=kg
                      do kf=k1,kmax
                        if(bequgrp)then
                          kk=(kf*(kf-1))/2+kg
                        else
                          kk=kmax*(kf-1)+kg
                        endif
                        b1body=nads1(kk).gt.nads1(kk-1)
                        b2body=nads2(kk).gt.nads2(kk-1)
                        if(b1body.or.b2body)go to 184      !need this kg
                      enddo
                      go to 186
!
  184                 ISTRT=MTGD1
                      KSTART(KG,2)=ISTRT
!
                      CALL DISKDC(IUD,ISTRT,IFIN,KG,LGSYM,IONE,IZERO)
!
                      MTGD1=IFIN+1
                      IF(IFIN.LT.0)THEN   !FAILURE TO READ REQUIRED DATA
                        NF=-1
                        GO TO 300
                      ENDIF
                    ENDIF
                  ENDIF
  186           ENDDO
                IFIN=MTGD1-1
                MDCBUF4=MAX(MDCBUF4,IFIN)
              ENDIF
!
              if(btime)call nrb_time(timei)
!
              istrt0=0
              KF0=0
              DO NJ11=1,N0                 !BEGIN UPPER LOOP OVER LEVELS
!
                NJ1=NCJ0+NJ11
                ND1=NJ1+NCJ
                MMD2(1,NGJP1,NJ11)=IRS+1
                MMD1(1,NGJP1,NJ11)=IRKP+1
!
                IT=NRR(ND1)
                KF=NFK(IT)
!
                IF(KF.GT.KUTDSK.AND.KF.NE.KF0)THEN
                  ISTRT=0
                  ISTRT=KSTART(KF,1)
                  IF(ISTRT.EQ.0)THEN                     !BUFFERED BY CF
                    NGSYM=KGSL(KF,NC)                     !POS WITHIN CF
                    ISTRT=MTGD1
!
                    CALL DISKDC(IUD,ISTRT,IEND,KF,NGSYM,IONE,IZERO)
!
                    IF(IEND.LT.0)THEN     !FAILURE TO READ REQUIRED DATA
                      NF=-1
                      GO TO 300
                    ENDIF
                  ENDIF
                  ISTRT0=ISTRT-MTGD-1               !I.E. ORIGINAL MTGD1
                  KF0=KF
                ENDIF
!
                II=NFI(IT)
                IF(BFAST)THEN
                  ND2=JTGD(II)+ISTRT0      !relative start flagged
                ELSE
                  do j=jyi(kf),jyf(kf)
                    mam(j)=0
                  enddo
                  k2=jtgd(ii)              !absolute end flagged
                  if(k2.lt.0)then          !bdisk first
                    k2=-k2
                    k1=mtgd
                  else
                    k1=jtgd(ii-1)          !start
                    k1=abs(k1)            !case bdisk second
                  endif
                  k1=k1+1+istrt0
                  k2=k2+istrt0
                  do k12=k1,k2
                    j=idc(k12)
                    mam(j)=k12
                  enddo
                ENDIF
!
                NJP11X=N0P
                IF(K.EQ.KP.AND.NGJP1.EQ.NGJ1)NJP11X=NJ11
!
                istrt=0
                KG0=0
                DO NJP11=1,NJP11X        !BEGIN LOWER LOOP OVER LEVELS
!
                  NJP1=NCJP0+NJP11
                  NDP1=NJP1+NCJP
!          write(mw6,*)'nd1=',nd1,'ndp1=',ndp1
!
                  ITP=NRR(NDP1)
                  KG=NFK(ITP)
!
!          BMSKIP=KF.GT.KUT.OR.KG.GT.KUT   !.and.mlam.eq.2 !mlam not set
!          IF(ITP.NE.IT.AND.BMSKIP)GO TO 25      !Use test before mkalg1
!
! CALCULATE THE ALGEBRAIC CONTRIBUTION TO THE MATRIX ELEMENT.
!
                  IF(BEQUGRP)THEN        !KG.LE.KF HERE
                    KK=(KF*(KF-1))/2+KG
!            if(kf.lt.kg)stop 'algeb4: kf.lt.kg'
                  ELSE
                    KK=KMAX*(KF-1)+KG
                  ENDIF
!
                  B1BODY=NADS1(KK).GT.NADS1(KK-1)
                  B2BODY=NADS2(KK).GT.NADS2(KK-1)
!
                  IF(B1BODY.OR.B2BODY)THEN
!
                    IF(KG.GT.KUTDSK.AND.KG.NE.KG0)THEN
                      ISTRT=KSTART(KG,2)
                      IF(ISTRT.EQ.0)THEN                 !BUFFERED BY CF
                        LGSYM=KGSL(KG,ND)                 !POS WITHIN CF
                        ISTRT=IEND+1
!
                        CALL DISKDC(IUD,ISTRT,IFIN,KG,LGSYM,IONE,IZERO)
!
                        IF(IFIN.LT.0)THEN !FAILURE TO READ REQUIRED DATA
                          NF=-1
                          GO TO 300
                        ENDIF
                      ENDIF
                      ISTRT=ISTRT-MTGD-1            !I.E. ORIGINAL MTGD1
                      KG0=KG
                    ENDIF
!
                    LL=NFI(ITP)
                    IF(BFAST)THEN
                      NDP2=JTGD(LL)+ISTRT  !relative start flagged
                    ELSE
                      do j=jyi(kg),jyf(kg)
                        nam(j)=0
                      enddo
                      k2=jtgd(ll)          !absolute end flagged
                      if(k2.lt.0)then      !bdisk first
                        k2=-k2
                        k1=mtgd
                      else
                        k1=jtgd(ll-1)      !start
                        k1=abs(k1)        !case bdisk second
                      endif
                      k1=k1+1+istrt
                      k2=k2+istrt
                      do k12=k1,k2
                        j=idc(k12)
                        nam(j)=k12
                      enddo
                    ENDIF
!
                    IRKP0=IRKP+1
                    IRS0=IRS+1
!
                    CALL MKALG2(mam,nam,KK)
!
                    IF(NF.EQ.0)GO TO 600             !DIMENSION EXCEEDED
                    IF(NF.LT.0)GO TO 300             !NOT USED CURRENTLY
!
                  ENDIF
!
                ENDDO             !25        !END LOWER LOOP OVER LEVELS
!
                MMD2(2,NGJP1,NJ11)=IRS
                MMD1(2,NGJP1,NJ11)=IRKP
!
!
!      write(mw6,*)k,kp,ngjp1,nj11,nd1,mmd2(1,ngjp1,nj11)
!     &,mmd2(2,ngjp1,nj11)
!       do m=mmd1(1,ngjp1,nj11),mmd1(2,ngjp1,nj11)
!         n1=nrkp(m)/mxsoi
!         n2=nrkp(m)-n1*mxsoi
!         write(mw6,*)m,n1+1,(qrlp(n3,n2),n3=1,4)
!       enddo
!
              ENDDO                          !END UPPER LOOP OVER LEVELS
!
              if(btime)then
                call nrb_time(timef)
                time2=time2+timef-timei
              endif
!
              NCJP0=NCJP0+N0P
            ENDDO                        !END LOWER LOOP OVER SLP GROUPS
!
!
! SHUFFLE COEFFS SO ALL LOWER LEVELS (WITHIN JP) ARE SEQUENTIAL FOR A
! GIVEN UPPER LEVEL. (CURRENTLY, ONLY TRUE FOR LOWER LEVELS WITHIN SLP.)
!
!      write(mw6,*)'begin shuffle'
!
            MX=0
!
            DO NJ11=1,N0      !BEGIN LOOP OVER UPPER LEVELS OF SLP GROUP
!
              NJ1=NCJ0+NJ11
              ND1=NJ1+NCJ
              IF(NJ11.EQ.N0)GO TO 195
!
              DO NGJP1=2,NGJP1X        !BEGIN LOOP OVER LOWER SLP GROUPS
!
! 1-BODY
!
                M1=MMD1(1,NGJP1,NJ11)
                M2=MMD1(2,NGJP1,NJ11)
!
                MX=M2-M1+1
                IF(MX.GT.IXD23)THEN                           !GO TO 500
!
                  DEALLOCATE(TMP,NTMP,STAT=IERR)
!
                  IF(IERR.NE.0)THEN
                    WRITE(MW0,*)'ALGEB4: DE-ALLOCATION FAILS FOR TMP'
                    NF=0
                    GO TO 300
                  ENDIF
!
                  IXD23=7*(MX/5+1)            !MIGHT AS WELL UP IT A BIT
                  ALLOCATE(TMP(IXD23),NTMP(IXD23),STAT=IERR)
!
                  IF(IERR.NE.0)THEN
                    WRITE(MW0,*)'ALGEB4: ALLOCATION FAILS FOR TMP,NTMP'
                    NF=0
                    GO TO 300
                  ENDIF
!
                ENDIF
!
                L1=MMD1(2,NGJP1-1,NJ11)+1
                L2=L1+MX-1
                IF(MX.EQ.0)GO TO 188
!
                N1=MMD1(1,1,NJ11+1)
                N2=MMD1(2,NGJP1-1,N0)
!
!        write(mw6,*)'shuffle',nj11,ngjp1-1,m1,m2,n1,n2
!
                IF(N1.LE.N2)THEN
                  MM=0
                  DO M=M1,M2            !PUT ASIDE
                    MM=MM+1
                    NTMP(MM)=NRKP(M)
                    TMP(MM)=DRKP(M)
                  ENDDO
                  DO N=N2,N1,-1
                    NN=MX+N
                    NRKP(NN)=NRKP(N)
                    DRKP(NN)=DRKP(N)
                  ENDDO
                  MM=0
                  DO L=L1,L2            !PUT BACK
                    MM=MM+1
                    NRKP(L)=INT(NTMP(MM),IWORD1)
                    DRKP(L)=TMP(MM)
                  ENDDO
                ENDIF
!
                DO N=NJ11+1,N0
                  DO I=1,NGJP1-1
                    MMD1(1,I,N)=MMD1(1,I,N)+MX
                    MMD1(2,I,N)=MMD1(2,I,N)+MX
                  ENDDO
                ENDDO
!
  188           MMD1(1,NGJP1,NJ11)=L1
                MMD1(2,NGJP1,NJ11)=L2
!
! NOW 2-BODY
!
                IF(.NOT.BM1BODY)THEN
                  M1=MMD2(1,NGJP1,NJ11)
                  M2=MMD2(2,NGJP1,NJ11)
!
                  MX=M2-M1+1
                  IF(MX.GT.IXD23)THEN                         !GO TO 500
!
                    DEALLOCATE(TMP,NTMP,STAT=IERR)
!
                    IF(IERR.NE.0)THEN
                      WRITE(MW0,*)'ALGEB4: DE-ALLOCATION FAILS FOR NTMP'
                      NF=0
                      GO TO 300
                    ENDIF
!
                    IXD23=7*(MX/5+1)          !MIGHT AS WELL UP IT A BIT
                    ALLOCATE(TMP(IXD23),NTMP(IXD23),STAT=IERR)
!
                    IF(IERR.NE.0)THEN
                      WRITE(MW0,*)                                      &
     &                           'ALGEB4: ALLOCATION FAILS FOR NTMP,TMP'
                      NF=0
                      GO TO 300
                    ENDIF
!
                  ENDIF
!
                  L1=MMD2(2,NGJP1-1,NJ11)+1
                  L2=L1+MX-1
                  IF(MX.EQ.0)GO TO 190
!
                  N1=MMD2(1,1,NJ11+1)
                  N2=MMD2(2,NGJP1-1,N0)
!
                  IF(N1.LE.N2)THEN
                    MM=0
                    DO M=M1,M2          !PUT ASIDE
                      MM=MM+1
                      NTMP(MM)=MSS(M)
                      TMP(MM)=DSS(M)
                    ENDDO
                    DO N=N2,N1,-1
                      NN=MX+N
                      MSS(NN)=MSS(N)
                      DSS(NN)=DSS(N)
                    ENDDO
                    MM=0
                    DO L=L1,L2          !PUT BACK
                      MM=MM+1
                      MSS(L)=INT(NTMP(MM),IWORD2)
                      DSS(L)=TMP(MM)
                    ENDDO
                  ENDIF
!
                  DO N=NJ11+1,N0
                    DO I=1,NGJP1-1
                      MMD2(1,I,N)=MMD2(1,I,N)+MX
                      MMD2(2,I,N)=MMD2(2,I,N)+MX
                    ENDDO
                  ENDDO
  190             MMD2(1,NGJP1,NJ11)=L1
                  MMD2(2,NGJP1,NJ11)=L2
                ENDIF
!
              ENDDO                      !END LOOP OVER LOWER SLP GROUPS
!
! NOW SET GLOBAL INDEX FOR DIAGFS
!
  195         DO N=1,NGJP1X
                N1=MMD1(1,N,NJ11)
                N2=MMD1(2,N,NJ11)
                IF(N1.LE.N2)GO TO 200
              ENDDO
              M2=N2
              GO TO 205
  200         DO M=NGJP1X,N,-1
                M1=MMD1(1,M,NJ11)
                M2=MMD1(2,M,NJ11)
                IF(M1.LE.M2)GO TO 205
              ENDDO
  205         NMD1(1,KP,ND1)=N1
              NMD1(2,KP,ND1)=M2
!
!        do n=1,ngjp1x
!          write(mw6,*)mmd1(1,n,nj11),mmd1(2,n,nj11)
!        enddo
!        write(mw6,*)"*",n1,m2
!
              IF(.NOT.BM1BODY)THEN
                DO N=1,NGJP1X
                  N1=MMD2(1,N,NJ11)
                  N2=MMD2(2,N,NJ11)
                  IF(N1.LE.N2)GO TO 206
                ENDDO
                M2=N2
                GO TO 208
  206           DO M=NGJP1X,N,-1
                  M1=MMD2(1,M,NJ11)
                  M2=MMD2(2,M,NJ11)
                  IF(M1.LE.M2)GO TO 208
                ENDDO
  208           NMD2(1,KP,ND1)=N1
                NMD2(2,KP,ND1)=M2
!        write(mw6,*)"**",n1,m2
              ENDIF
!
!      write(mw6,*)k,kp,ngjp1,nj11,nd1,nmd2(1,kp,nd1),nmd2(2,kp,nd1)
!       do m=nmd1(1,kp,nd1),nmd1(2,kp,nd1)
!         n1=nrkp(m)/mxsoi
!         n2=nrkp(m)-n1*mxsoi
!         write(mw6,3377)m,n1+1,(qrlp(n3,n2),n3=1,4),drkp(m)
! 3377  format(2i3,4i2,f10.5)
!       enddo
!
            ENDDO               !END LOOP OVER UPPER LEVELS OF SLP GROUP
!
            IF(MX.GT.IXD23)GO TO 500              !SHOULD NOT HAPPEN NOW
!
!      write(mw6,*)'end shuffle'
!
  210       NCJP=NCJP+NT(KP)
          ENDDO                           !END LOWER LOOP OVER JP GROUPS
!
          NCJ0=NCJ0+N0
        ENDDO                            !END UPPER LOOP OVER SLP GROUPS
!
        NCJ=NCJ+NT(K)
      ENDDO                               !END UPPER LOOP OVER JP GROUPS
!
!-----------------------------------------------------------------------
!
      CALL DIMUSE('MXSOC',IRKP)
      CALL DIMUSE('MXSOI',IRLP)
      CALL DIMUSE('MXRSS',IRS)
      CALL DIMUSE('MAXMI',NL)
      CALL DIMUSE('MXS1C',MXIRKS)
      CALL DIMUSE('MXS1I',MXIRLS)
      CALL DIMUSE('MXS2C',MXIRSS)
      CALL DIMUSE('MXS2I',MXNLS)
      IF(MDCBUF4.GT.0)CALL DIMUSE('MAXDC',MDCBUF4)
!
!      IRLP0=IRLP                        !not used further
      IF(.NOT.BLPT)WRITE(MW6,10110)IRKP,ND1,NDP1,MG,MG,IRLP,ND1,NDP1,   &
     &                             IRS,NL
      IF(BLPT.AND.NL.GT.NL000)WRITE(MW6,10070)                          &
     &                              (L,(QSS(I,L),I=1,5),L=NL000+1,NL)
      WRITE(MW6,10010)IXS1C,IXS1I,MXIRKS,MXIRLS
      IF(IRSS.GE.IRSS0)WRITE(MW6,10020)IXS2C,IXS2I,MXIRSS,MXNLS
      WRITE(MW6,10130)MDCBUF4,MAXDC
!
      if(btime)then
!par        if(iam.ge.0)then                                        !par
!par          write(iwp,*)'proc',iam,' for algeb4:'                 !par
!par          write(iwp,*)'    mkalg1 time=',nint(time1),'sec'      !par
!par          write(iwp,*)'    mkalg2 time=',nint(time2),'sec'      !par
!par          call flush(iwp)                                       !par
!par        else                                                    !par
        write(iw,*)'mkalg1 time=',nint(time1),'sec'
        write(iw,*)'mkalg2 time=',nint(time2),'sec'
!          call flush(iw)
!par        endif                                                   !par
      endif
!
!-----------------------------------------------------------------------
!
!
      irlp=abs(irlp)  !case no mk, remove flag from structure integrals
!
! IF ACTUAL USAGE IS SUFFICIENTLY SMALLER THAN *INITIAL* ALLOCATION,
! THEN REDUCE USAGE TO ACTUAL - FOR SMALL CASES ON SMALL MEMORY MACHINES
!
      IXXX=(4*MXSOI)/5
      IF(irlp000.ne.ixsoi.and.IRLP.LT.IXXX)THEN
!
!      WRITE(MW6,*)'*** ALGEB4: decreasing MXSOI from ',IXSOI,' to: '
!                ,IRLP
!      WRITE(MW0,*)'*** ALGEB4: decreasing MXSOI from ',IXSOI,' to: '
!                ,IRLP
!
        CALL RE_ALLOC2(QRLP,IONE,IFOUR,IONE,IXSOI,IFOUR,IRLP,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB4: RE-ALLOCATION FAILS FOR QRLP',IERR
          NF=0
          GO TO 300
        ENDIF
!
        IXSOI=IRLP
!
      ENDIF
!
      IXXX=(4*MXSOC)/5
      IF(irkp000.ne.ixsoc.and.IRKP.LT.IXXX)THEN
!
!      WRITE(MW6,*)'*** ALGEB4: decreasing MXSOC from ',IXSOC,' to: '
!                ,IRKP
!      WRITE(MW0,*)'*** ALGEB4: decreasing MXSOC from ',IXSOC,' to: '
!                ,IRKP
!
        CALL RE_ALLOC(DRKP,IONE,IXSOC,IRKP,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB4: RE-ALLOCATION FAILS FOR DRKP',IERR
          NF=0
          GO TO 300
        ENDIF
!
        CALL RE_ALLOC(NRKP,IONE,IXSOC,IRKP,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB4: RE-ALLOCATION FAILS FOR NRKP',IERR
          NF=0
          GO TO 300
        ENDIF
!
        IXSOC=IRKP
!
      ENDIF
!
      IXXX=(4*MAXMI)/5
      IF(nl000.ne.iaxmi.and.NL.LT.IXXX)THEN
!
!        WRITE(MW6,*)'*** ALGEB4: decreasing MAXMI from ',IAXMI,' to: '
!                  ,NL
!        WRITE(MW0,*)'*** ALGEB4: decreasing MAXMI from ',IAXMI,' to: '
!                  ,NL
!
        CALL RE_ALLOC2(QSS,IONE,IFIVE,IONE,IAXMI,IFIVE,NL,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB4: RE-ALLOCATION FAILS FOR QSS',IERR
          NF=0
          GO TO 300
        ENDIF
!
        IAXMI=NL
!
      ENDIF
!
      IXXX=(4*MXRSS)/5
      IF(irs000.ne.ixrss.and.IRS.LT.IXXX)THEN
!
!       WRITE(MW6,*)'*** ALGEB4: decreasing MXRSS from ',IXRSS,' to: '
!                 ,IRS
!       WRITE(MW0,*)'*** ALGEB4: decreasing MXRSS from ',IXRSS,' to: '
!                 ,IRS
!
        CALL RE_ALLOC(DSS,IONE,IXRSS,IRS,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB4: RE-ALLOCATION FAILS FOR DSS',IERR
          NF=0
          GO TO 300
        ENDIF
!
        CALL RE_ALLOC(MSS,IONE,IXRSS,IRS,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB4: RE-ALLOCATION FAILS FOR MSS',IERR
          NF=0
          GO TO 300
        ENDIF
!
        IXRSS=IRS
!
      ENDIF
!
!-----------------------------------------------------------------------
!
  300 CONTINUE
!
! LOCAL
      IF(ALLOCATED(VC1))DEALLOCATE(VC1)
!
      IF(ALLOCATED(B1B))THEN
        DEALLOCATE(B1B,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB4: DE-ALLOCATION FAILS FOR B1B'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(B2B))THEN
        DEALLOCATE(B2B,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB4: DE-ALLOCATION FAILS FOR B2B'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(KSTART))DEALLOCATE(KSTART)
      IF(ALLOCATED(ITMP))DEALLOCATE(ITMP)
!
! EX-COMMON/NSTS2/
      IF(ALLOCATED(NADS2))THEN
        DEALLOCATE(NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB4: DE-ALLOCATION FAILS FOR NADS2,NSTJ2...'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NSTS1/
      IF(ALLOCATED(NADS1))THEN
        DEALLOCATE(NADS1,NSTJ1,NSTJ1D,IORIG1,JORIG1,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB4: DE-ALLOCATION FAILS FOR NADS1,NSTJ1...'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/DMQSSS/
      IF(ALLOCATED(DSSS))THEN
        DEALLOCATE(DSSS,MSSS,QSSS,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB4: DE-ALLOCATION FAILS FOR DSSS,MSSS,QSSS'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/COEFFS/
      IF(ALLOCATED(DRKPS))THEN
        DEALLOCATE(DRKPS,QRLPS,NRKPS,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB4: DE-ALLOCATION FAILS FOR  DRKPS,QRLPS..'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(BLOCAL)THEN
        DEALLOCATE(MMD1,MMD2,TMP,NTMP,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGEB4: DE-ALLOCATION FAILS FOR MMDX,TMP'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
!     E R R O R   M E S S A G E S
!
  400 WRITE(MW6,10040)IXD22,NGJP1X*2
      GO TO 600
  500 WRITE(MW6,10050)IXD23,MX
!
  600 WRITE(MW6,10030)
      WRITE(MW6,10110)IRKP,ND1,NDP1,MG,MG,IRLP,ND1,NDP1,IRS,NL
!
      WRITE(MW0,*)'**** SR.ALGEB4: STORAGE EXCEEDED ****'
      IF(NF.GT.0)NF=-1
!
      GO TO 300
!
  700 CONTINUE
!
! EX-COMMON/NRBMKP/
      ALLOCATE(NMD1(1,1,1),NMD2(1,1,1),STAT=IERR)
!
  800 NMD2(1,1,1)=-1
      NMD1(1,1,1)=-1
!
      GO TO 300                                             !NULL RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(/' SLATER STATE INTERACTION STORAGE (MXS1C,MXS1I)',I9,I6,  &
     &       10X,'USED:',I9,I6)
10020 FORMAT(/' SLATER STATE INTERACTION STORAGE (MXS2C,MXS2I)',I9,I6,  &
     &       10X,'USED:',I9,I6)
10030 FORMAT(//' **** SR.ALGEB4: STORAGE EXCEEDED - UNABLE TO ALLOCATE',&
     &       ' ANY MORE MEMORY - REDUCE/SWITCH-OFF MK OR BP RADIATIVE', &
     &       ' CORRECTIONS ****'//)
10040 FORMAT(/' SR.ALGEB4:   INCREASE MAXSL FROM',I5,' TO',I5)
10050 FORMAT(/' SR.ALGEB4:   INCREASE MXD23 FROM',I6,' TO',I6)
10060 FORMAT(/' SR.ALGEB4:   INCREASE MXDFS FROM',I5,' TO',I5)
10070 FORMAT(/' REFERENCE TABLE FOR RADIATIVE MAGNETIC TWO-BODY TERMS'/ &
     &       (I14,4I3,I5))
10080 FORMAT(/'       CN    LV   LVP,    B   D,  IND',6X,'1-BODY',4X,   &
     &       'REL.RAD.ALGEBRA',8X,                                      &
     &       '2-BODY FOR M1: CONFIGURATIONS INCLUDED UP TO  CF =',I3,   &
     &       '(',A1,')')
10090 FORMAT(/' MAGNETIC MULTIPOLE ALGEBRA'/                            &
     &       '       CN    LV   LVP,    B   D,  IND',3X,                &
     &       '<J||TK||JP> = <J,MJ|TK|JP,MJP> / C(J,JP,K;MJ,MJP)',7X,    &
     &       '2MJ',1X,'2MJP',2X,'K')
10100 FORMAT(I9,3I6,I4,I6,F13.5,2F19.5,6X,2I4,3X,A1,I1,I4)
10110 FORMAT(I9,3I6,I4,I6,31X,2I6,I9,I6)
10120 FORMAT(49X,'NOT ENOUGH SLATER STATES STORED; CHANGE MODE TO',     &
     &       ' -1 IF RADIATIVE DATA REQUIRED')
10130 FORMAT(/86X,I10,'=MTGD, MAXDC=',I10,' BUFFER STORAGE USED')
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE ALGEB4
!
!                             *******************
!
      SUBROUTINE ALGX
!
!-----------------------------------------------------------------------
!
!  SR.ALGX CALCULATES EIE COLLISION ALGEBRA.
!
!  IT IS CALLED BY:
!    SR.DEIE
!
!  IT CALLS:
!    SR.ALGX0
!    SR.ALGXLS
!    SR.ALGXFS
!    SR.CALGX
!    SR.CALGX0
!    SR.CASYM
!    SR.DIMUSE
!    SR.DISKDC
!    SR.RE_ALLOC
!    SR.SYMLS
!    SR.SYMLSJ
!    FN.VCC
!
!  IT CONTAINS:
!    FN.MVC
!
!par!  and in parallel:                                             !par
!par!    sr.pcasym                                                  !par
!par!    sr.psymls                                                  !par
!par!    sr.psymj                                                   !par
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam,nproc,                     !par&
!par     &                           comm_barrier,comm_finalize     !par
!
      USE COMMON_ALGEB,  ONLY: MPRINT
      USE COMMON_ALGEB,  ONLY: MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD     &
     &                        ,KFBUFF
!!      COMMON /BASIC/NF,KX,KG,K1,K2,MGAP(7)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KX=>IBSK2,KG=>IBSK3,K1=>IBSK4,K2=>IBSK5            &
     &              ,IBSK6=>IBSK6,IBSK7=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9&
     &              ,IBSK10=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_CFCT,   ONLY: VCA,VCB,MXLL,MAXLL0,MAXLL1,BVC,BDLBD
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DC,     ONLY: BFAST,DC,IDC,IXIDC,LREC
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR
      USE COMMON_MINIM,  ONLY: BECOR
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_QTG,    ONLY: MTGD,NXLL,NTT,NTG,JTGD,QTGS,QTGL,QTGD    &
     &                        ,NFI,NFK,NFQ
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      use common_misc,   only: ione1,ione0
!
      USE COMMON_NRBAL0, ONLY: IRET0,LORIG,LMIN,MPRNT0,MOD0,MSTRT0,BPASS&
     &                        ,MLIT
      USE COMMON_NRBBBB, ONLY: BXIST0,BXIST1
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,INAST0=>NASTB,MINLTB,MAXLTB,LSPIB        &
     &                        ,INASTJ0=>NASTJB,JPIB,LFACT,JFACT         &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDW1, ONLY: MXORB,ma0,mb0
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
      USE COMMON_NRBDW4, ONLY: DSPECE,INDEX,JNDEX,NSPECE,NENERG
      USE COMMON_NRBDW9, ONLY: DSPECJ,INDXJ,JNDXJ,NSPECJ,NENERJ
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBDWX, ONLY: LLCH,ITARG,NCHG
      USE COMMON_NRBFL0, ONLY: KINTI,KINTF,KEN2,KPTCFM,KINT,MPOINT
      USE COMMON_NRBGCF, ONLY: KGSL,KGCF,NKSL,KSLX
      USE COMMON_NRBGRJ, ONLY: NSLJ,NGSLJ
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBIAD, ONLY: IADD,IADJ
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,INASTJ=>NASTJ                   &
     &                        ,MINJT,MAXJT,NEIGENJ
      USE COMMON_NRBKUT, ONLY: KCUTX,LSKUT,NASTK
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBORB, ONLY: IEQ
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      ALLOCATABLE :: MAM(:),NAM(:)                                      &
     &              ,QBMS(:),QBML(:),QLMC(:,:)                          &
     &              ,KACT(:,:),KTMP(:)
!
      ALLOCATABLE :: JYI(:),JYF(:)
!
!-----------------------------------------------------------------------
!
!      MVC(M1,M2)=((M1+2)*M1/2+M2)/2+1 !SEE INTRNL FUNCTN ABVE END ALGX
!
!-----------------------------------------------------------------------
!
      WRITE(MW6,10190)
!                                              !HISTORIC
      MXMTGD=3*2**26                           !MAX REC LEN FOR DC ARRAY
      MXMTGD=MXMTGD*(8/LREC)
!
! RE-POINT RESTART FILE
!
      REWIND(MRW10)
!
      IF(NSL0.LT.0)THEN          !CA, NO RESTART, JUST RECOVER PASS FILE
!
        BDISK=.FALSE.
!
        CALL CALGX0
!
        GO TO 100
!
      ENDIF
!
!-----------------------------------------------------------------------
! RECOVER TARGET HEADER INFO FROM ALGEB1
!-----------------------------------------------------------------------
!                                                                  !REC1
      READ(MRW10)MLIT,MXORB,NW,NF,MODD,KCUTX,KUTDSK,QQKUTX,QCL0,QCS0,   &
     &           MDCBUF,KSLX,MTGD,MTGDI,NTT,NSS,MAXEL,KMAX,NPRINT,MA0,  &
     &           MB0
!
      BDISK=KUTDSK.LT.KMAX                                   !USE DISKDC
      IF(BDISK)THEN
        IF(MDCBUF.LT.0)THEN
          MDCBUF=-MDCBUF
          MXTGDI=1
        ELSE
          MXTGDI=MDCBUF
        ENDIF
        MXTGD=MDCBUF
      ELSE
        MXTGD=MTGD
        MXTGDI=MTGDI
      ENDIF
!
      NMTGD=MTGD/MXMTGD
      IF(NMTGD.GT.0)THEN
        WRITE(MW0,*)'DC ARRAY TOO LARGE...'
        WRITE(MW6,10120)
        GO TO 1000
      ENDIF
!
      MAXEL1=MAXEL+1                   !ADD SPACE FOR CONTINUUM ELECTRON
      IXEL0=MAXEL1
!
      CALL DIMUSE('MXEL0',MAXEL1)
!
! LOCAL
      ALLOCATE(DC(0:MXTGD),IDC(MXTGDI),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGX: ALLOCATION FAILS FOR DC,IDC'
        GO TO 1100
      ENDIF
!
! LOCAL
      ALLOCATE(QBMS(NSS),QBML(NSS),QLMC(IXEL0,NSS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGX: ALLOCATION FAILS FOR    QXXX'
        GO TO 1100
      ENDIF
!
! LOCAL
      ALLOCATE(MAM(NSS),NAM(NSS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGX: ALLOCATION FAILS FOR MAM,NAM'
        GO TO 1100
      ENDIF
!
! LOCAL
      ALLOCATE(JYI(KMAX),JYF(KMAX))
!
!-----------------------------------------------------------------------
! RECOVER TARGET INFO
!-----------------------------------------------------------------------
!
      CALL ALGX0(QLMC,QBML,QBMS,JYI,JYF,MAXEL1)
!                                                      !just conceivable
      if(bdisk.and.dc(0).gt.dzero.and.mxtgdi.ne.mdcbuf)then
        stop 'algx buffer flag error: exactly one VCC in memory mtgd=1'
      endif
!
      IF(NF.LE.0.OR.NZION.EQ.0)GO TO 600                        !BAILOUT
!
!-----------------------------------------------------------------------
! (RE-)INITIALIZE
!-----------------------------------------------------------------------
!
  100 CONTINUE                                        !CA RE-ENTRY POINT
!
      IF(KUTOOX.EQ.-999)KUTOOX=-1                              !OR KUTOO
      IF(KUTOOX.EQ.-1)KUTOOX=0                                    !ALIGN
      BKUTOO=KUTOOX.NE.0
      BKUTSS=ABS(MODD).LT.2.AND.KUTSSX.NE.-1.AND.KUTSSX.NE.-1937
!
      BDLBD=BKUTSS.OR.BKUTOO
!
!-----------------------------------------------------------------------
! COMPUTE CLEBSCH-GORDAN VCC TABLES VCA & VCB
! FOR PRACTICAL PURPOSES, WE GO AS FAR AS DIMENSIONS ALLOW.
!-----------------------------------------------------------------------
!
      NXLL=-1
      DO K=1,MXORB
        IF(DEY(K).NE.DZERO.AND.QL(K).GT.NXLL)NXLL=QL(K)          !FOR CA
      ENDDO
!
      MXLL=-1
      BSKP=IDW.LT.0.OR.NSL0.LT.0  !NOT USED BY CA (6J-SYMBOL DOOMINATES)
!
      IF(.NOT.BSKP)THEN
!
!        MXLL=NXLL
!        IXLL1=MXLL/ITWO+1
!
        IF(MAXLL.GE.0)THEN               !AS MAXLL IS NOW MAX L *PLUS* 1
          IAXLL=MAXLL
        ELSE
          IAXLL=MAXLL0
        ENDIF
!        IAXLL=MIN(IXLL1,IAXLL,MAXLL1)
        IAXLL=MIN(IAXLL,MAXLL1)
        BVC=.FALSE.                                !AS CONTINUUM L LARGE
        IF(.NOT.BVC)MXLL=2*IAXLL-2
!
        IF(IAXLL.LE.0)GO TO 400
!
        IXD31=IAXLL
        IXD32=IXD31*IXD31
!
        CALL DIMUSE('MAXLL',IXD31)
!
! EX-COMMON/CFCT/
        ALLOCATE(VCA(IXD32,IXD32,IXD31),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGX: ALLOCATION FAILS FOR VCA'
          GO TO 1100
        ENDIF
        IF(BDLBD)THEN
          ALLOCATE(VCB(IXD32,IXD32,IXD31),STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'ALGX: ALLOCATION FAILS FOR VCB'
            GO TO 1100
          ENDIF
        ENDIF
!
        M1=0
  150   M2=0
!
  200   MK=ABS(M1-M2)
!
  250   MKT=MK+2
        DVC0=VCC(M1,M2,MK,IZERO,IZERO,IZERO)
        ML1=-M1
!
  300   MB1=MVC(M1,ML1)
        ML2=-M2
!
  350   MB2=MVC(M2,ML2)
        DA=DZERO
        DD=DZERO
        MLK=ML1+ML2
        IF(ABS(MLK).LE.MKT)THEN
          IF(BDLBD)DD=VCC(M1,M2,MKT,ML1,ML2,MLK)*DVC0
          IF(ABS(MLK).LE.MK)DA=(VCC(M1,M2,MK,ML1,ML2,MLK)/(MK+1))*DVC0
        ENDIF
        MLK=MK/4+1
        VCA(MB1,MB2,MLK)=DA
        IF(BDLBD)VCB(MB1,MB2,MLK)=DD
!
        ML2=ML2+2
        IF(ML2.LE.M2)GO TO 350
!
        ML1=ML1+2
        IF(ML1.LE.M1)GO TO 300
!
        MK=MK+4
        IF(MK.LE.M1+M2)GO TO 250
!
        M2=M2+2
        IF(M2.LE.MXLL)GO TO 200
!
        M1=M1+2
        IF(M1.LE.MXLL)GO TO 150
!
      ENDIF
!
  400 CONTINUE
!
!-----------------------------------------------------------------------
! COMPARE CONFIGURATION PAIRS:
! IF DIFFER IN MORE THAN ONE ELECTRON PAIR SET
!  BXIST0=.FALSE. (LS/J)
!  KACT=-1 (CA)
! ELSE SET
!  BXIST0=.TRUE. (LS/J)
!  KACT=THE DIFFERING PAIR, OR ZERO IF NONE (CA)
!
!-----------------------------------------------------------------------
!
      BNOTK=NSL0.GE.0                                  !ACTUALLY, NOT CA
!
! EX-COMMON/NRBBBB/
      IF(BNOTK)THEN
        ALLOCATE(BXIST0(KMAX,KMAX),BXIST1(KMAX),KTMP(NF),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGX: ALLOCATION FAILS FOR BXIST0,BXIST1'
          GO TO 1100
        ENDIF
      ELSE
        MXCF=KMAX
        ALLOCATE(KACT(KMAX,KMAX),KTMP(NF),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGX: ALLOCATION FAILS FOR KACT,KTMP'
          GO TO 1100
        ENDIF
      ENDIF
!
      DO KF=1,KMAX
        DO KG=1,KF
          IF(BNOTK)THEN
            BXIST0(KF,KG)=.TRUE.
            BXIST0(KG,KF)=.TRUE.
          ELSE
            KACT(KF,KG)=0
            KACT(KG,KF)=0
          ENDIF
          DO I=1,NF
            KTMP(I)=QCG(I,KG)
          ENDDO
          K=0
          DO I=1,NF
            L0=0
            DO L=1,NF
              IF(IEQ(KTMP(L)).EQ.IEQ(QCG(I,KF)))THEN
                KTMP(L)=0
                GO TO 420
              ELSE
                IF(KTMP(L).NE.0.AND.L0.EQ.0)L0=L
              ENDIF
            ENDDO
            K=K+1
            IF(K.GT.1)THEN
              IF(BNOTK)THEN
                BXIST0(KF,KG)=.FALSE.
                BXIST0(KG,KF)=.FALSE.
              ELSE
                KACT(KF,KG)=-1
                KACT(KG,KF)=-1
              ENDIF
              GO TO 450
            ENDIF
            IF(.NOT.BNOTK)THEN
              KACT(KF,KG)=QCG(I,KF)
              KACT(KG,KF)=KTMP(L0)
            ENDIF
  420     ENDDO
  450   ENDDO
      ENDDO
!
! checksum - shouldn't happen, but it did....
      if(.not.bnotk)then
        do kf=1,kmax
          do kg=1,kf
            if(kact(kg,kf).gt.0)then
              n1=kact(kf,kg)
              n2=kact(kg,kf)
              nef1=nel(n1,kf)
              nef2=nel(n2,kf)
              neg1=nel(n1,kg)
              neg2=nel(n2,kg)
              if(neg2-1.ne.nef2.or.neg1.ne.nef1-1)then
                write(mw0,*)'algx: invalid interacting electron pair..'
                write(mw0,*)kg,n2,neg2,neg1,'    ',kf,n1,nef1,nef2
!                stop 'algx: invalid interacting electron pair...'
              endif
            endif
          enddo
        enddo
      endif
!               FLAG NF+1 AS CONT. (NOT USED BY CA?)
      NF1=NF+1
      M1=MXORB+1
      DO K=1,KMAX
        QCG(NF1,K)=INT(M1,QP)
      ENDDO
!
!-----------------------------------------------------------------------
! DETERMINE CONTINUUM EXPANSION (CA/LS)
!-----------------------------------------------------------------------
!
      IF(NSL0.LT.0)THEN                                          !FOR CA
        QCL0=INT(2*NXLL,QP)                               !4*(MAX ORB L)
        QCL0=MIN(QCL0,INT(NXLL+IFOUR,QP))                  !CASE LARGE-L
        WRITE(MW6,10050)
      ENDIF
!
      IF(LCONDW.LE.0)THEN
        i1=0
        LCONDW=(QCL0+2)/2            !MAX NO OF CONT-L THAT CAN FORM SLP
      ELSE
        i1=mod(lcondw+1,itwo)
        LCONDW=(LCONDW-1)/2
        IC=QCL0/2
        if(lcondw.lt.ic)then
          WRITE(MW6,10100)LCONDW,IC
        elseif(lcondw.gt.ic)then
          IF(NSL0.GT.0)LCONDW=IC                  !AS STRICTLY FORBIDDEN
          IF(NSL0.LT.0)LCONDW=MIN(NXLL,LCONDW)    !AS STRICTLY FORBIDDEN
        endif
        LCONDW=LCONDW+1
      ENDIF
      LC=-LCONDW
      LCONDW=2*LCONDW-1                  !ALLOW FOR BOTH TARGET PARITIES
      lcondw=lcondw+i1
!
      MPOSC=MXORB
      LW=LCONDW
!
!-----------------------------------------------------------------------
! DETERMINE CONTINUUM EXPANSION (LSJ)
!-----------------------------------------------------------------------
!
      IF(BKUTSS)THEN
!
        IF(LCONDWJ.LE.0)THEN
          i1=mod(INT(qcs0+1,SP),itwo)
          LCONDWJ=(QCL0+QCS0+3)/2   !MAX NO OF CONT-L THAT CAN FORM SLJP
        ELSE
          LCONDWJ=MAX(LCONDW,LCONDWJ)                   !ELSE INDEX PAIN
          i1=mod(lcondwj+1,itwo)
          LCONDWJ=(LCONDWJ-1)/2
          IC=(QCL0+QCS0+3)/2-1
          if(lcondwj.lt.ic)then
            WRITE(MW6,10180)LCONDWJ,IC
          elseif(lcondw.gt.ic)then
            LCONDWJ=IC                            !AS STRICTLY FORBIDDEN
          endif
          LCONDWJ=LCONDWJ+1
        ENDIF
        LCJ=-LCONDWJ
        LCONDWJ=2*LCONDWJ-1              !ALLOW FOR BOTH TARGET PARITIES
        lcondwj=lcondwj+i1
!
        MPOSC=MPOSC+(LCONDWJ-1)/2-(LCONDW-1)/2             !BUFFER SPACE
        LW=LCONDWJ
!
      ELSE
!
        LCONDWJ=LCONDW
!
      ENDIF
!
      if(bkutoo.and.lcondwj.eq.1)then    !note: SET lcondw, not lcondwj!
        write(mw6,*)'*** buffer space too small, switch-off 2-nfs or',  &
     &              'set lcondw=2'
        write(mw0,*)'*** increase lcondw to 2'
        go to 1000
      endif
!
!-----------------------------------------------------------------------
! INITIALZE CONTINUUM ORBITAL LOCATIONS (LABEL & FLAG EXISTENCE)
!-----------------------------------------------------------------------
!
      IAXGR=MXORB+LW                            !N.B. NEL IS STILL MXORB
!
      CALL RE_ALLOC(QL,IONE,MXORB,IAXGR,IERR)
      CALL RE_ALLOC(QN,IONE,MXORB,IAXGR,IERR)
      CALL RE_ALLOC(DEY,IONE,MXORB,IAXGR,IERR)
!
      DO L=1,LW
        I=MXORB+L
        QN(I)=90
        DEY(I)=DONE
      ENDDO
!
      WRITE(MW6,10060)
!
      DO L=1,LCONDW
        I=MPOSC+L
        LC=LC+1
        IF(LC.LT.0)WRITE(MW6,10070)I,ABS(LC)
        IF(LC.EQ.0)WRITE(MW6,10080)I
        IF(LC.GT.0)WRITE(MW6,10090)I,LC
      ENDDO
!
!-----------------------------------------------------------------------
!
! INITIALIZE FOR PARALLEL OPERATION.
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      if(nsl0.lt.0)then                                         !par
!par        call pcasym(iam,nproc)                                  !par
!par      elseif(abs(MODD).gt.1)then                                !par
!par        call psymls(iam,nproc)                                  !par
!par      else                                                      !par
!par        call psymj(iam,nproc)                                   !par
!par      endif                                                     !par
!par!                                                               !par
!par      if(nf.lt.0)then                                           !par
!par        call comm_finalize()                                    !par
!par        go to 5000                                              !par
!par      endif                                                     !par
!par!                                                               !par
!
!-----------------------------------------------------------------------
!
! SET-UP CA SYMMETRIES & CHANNEL LIST
!
!-----------------------------------------------------------------------
!
      IF(NSL0.LT.0)THEN
!
        CALL CASYM(KACT,MXCF)
!
        IF(NF.LE.0)GO TO 600
!
!-----------------------------------------------------------------------
!
! FORM 2-BODY CA COLLISION ALGEBRA
!
!-----------------------------------------------------------------------
!
        CALL CALGX(KACT,MXCF)
!
        IF(NF.LE.0)GO TO 600
!
        GO TO 500
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! SET-UP LSP SYMMETRIES & CHANNEL LIST
!
!-----------------------------------------------------------------------
!
      CALL SYMLS
!
      IF(NF.LE.0)GO TO 600
!
!-----------------------------------------------------------------------
!
! FORM 2-BODY NON-FINE-STRUCTURE COLLISION ALGEBRA IN LS-COUPLING
!
!-----------------------------------------------------------------------
!
      CALL ALGXLS(MAM,NAM,QLMC,QBML,QBMS,JYI,JYF,MAXEL1)
!
      IF(NF.LE.0)GO TO 600
!
      INASTJ=0
!
      IF(ABS(MODD).GT.1)GO TO 700                    !QUICK RETURN (LS)
!
!-----------------------------------------------------------------------
!
! SET-UP LSJ SYMMETRIES & CHANNEL LIST, INC. SET-UP FOR FINE-STRUCTURE
!
!-----------------------------------------------------------------------
!
      IF(KUTSSX.EQ.-1.AND.MAXJFS.GE.0)THEN
        WRITE(MW6,10110)KUTSSX,MAXJFS
        WRITE(MW0,10110)KUTSSX,MAXJFS
        GO TO 1000
      ENDIF
      IF(KUTSSX.EQ.-1937)KUTSSX=-1                     ! or KUTSS (slow)
      IF(MAXJFS.EQ.-999)MAXJFS=2*MAXLX-QCS0-1
      IF(KUTSSX.EQ.-1)MAXJFS=-2        !not -1, for safety c.f. sr.psymj
!
      CALL SYMLSJ
!
      IF(NF.LE.0)GO TO 600
!
      INASTJ0=0
!
      IF(KUTSSX.EQ.-1)GO TO 900                !NO OPERATORS SET FOR 2FS
      IF(MAXJFS.LT.0)GO TO 800                         !NO J SET FOR 2FS
!
      WRITE(MW6,10130)MAXJFS
!
      WRITE(MW6,10140)
!
      LC=LCJ
      DO L=1,LCONDWJ
        I=MXORB+L
        LC=LC+1
        IF(LC.LT.0)WRITE(MW6,10150)I,ABS(LC)
        IF(LC.EQ.0)WRITE(MW6,10160)I
        IF(LC.GT.0)WRITE(MW6,10170)I,LC
      ENDDO
!
!-----------------------------------------------------------------------
!
! FORM 2-BODY FINE-STRUCTURE COLLISION ALGEBRA IN LSJ-COUPLING
!
!-----------------------------------------------------------------------
!
      CALL ALGXFS(MAM,NAM,QLMC,QBML,QBMS,JYI,JYF,MAXEL1)
!
      IF(NF.LE.0)GO TO 600
!
!-----------------------------------------------------------------------
!
  500 IF(IDW.LT.0)THEN
        WRITE(MW6,10040)IDW
        NF=0
      ENDIF
!par!                                                               !par
!par 5000 continue                                                  !par
!
  600 CONTINUE
!
! FINALIZE (CLOSE) WRITE/READ DC ARRAY TO/FROM DISK.
!
      IF(BDISK)CALL DISKDC(IUD,IZERO,IZERO,IZERO,IZERO,IZERO,IZERO)
!
! DEALLOCATE
!
! LOCAL
      IF(ALLOCATED(JYI))THEN
        DEALLOCATE(JYI,JYF,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGX: DE-ALLOCATION FAILS FOR JYI,JYF'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! LOCAL
      IF(ALLOCATED(DC))THEN
        DEALLOCATE(DC,IDC,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGX: DE-ALLOCATION FAILS FOR DC,IDC'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! LOCAL
      IF(ALLOCATED(QBMS))THEN
        DEALLOCATE(QBMS,QBML,QLMC,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGX: DE-ALLOCATION FAILS FOR QXXX'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! LOCAL
      IF(ALLOCATED(MAM))THEN
        DEALLOCATE(MAM,NAM,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGX: DE-ALLOCATION FAILS FOR MAM,NAM'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/CFCT/
      IF(ALLOCATED(VCA))THEN
        DEALLOCATE(VCA,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGX: DE-ALLOCATION FAILS FOR VCA'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/CFCT/
      IF(ALLOCATED(VCB))THEN
        DEALLOCATE(VCB,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGX: DE-ALLOCATION FAILS FOR VCB'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/QTG/
      IF(ALLOCATED(JTGD))THEN
        DEALLOCATE(JTGD,QTGS,QTGL,QTGD,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)                                                  &
     &              'ALGX: DE-ALLOCATION FAILS FOR  JTGD,QTGS,QTGL,QTGD'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBBBB/
      IF(BNOTK)THEN
        IF(ALLOCATED(BXIST0))THEN
          DEALLOCATE(BXIST0,BXIST1,KTMP,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'ALGX: DE-ALLOCATION FAILS FOR BXIST0,BXIST1'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
      ELSE
        IF(ALLOCATED(KACT))THEN
          DEALLOCATE(KACT,KTMP,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'ALGX: DE-ALLOCATION FAILS FOR KACT,KTMP'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
      ENDIF
!
! EX-COMMON/NRBDW/
      IF(ALLOCATED(LSPIB))THEN
        DEALLOCATE(LSPIB,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGX: DE-ALLOCATION FAILS FOR LSPIB'
          NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBDW/
      IF(ALLOCATED(JPIB))THEN
        DEALLOCATE(JPIB,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGX: DE-ALLOCATION FAILS FOR JPIB'
          NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBFL0/
      IF(ALLOCATED(KINTI))THEN
        DEALLOCATE(KINTI,KINTF,KEN2,KPTCFM,MPOINT,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGX: DE-ALLOCATION FAILS FOR KPTCFM ETC.'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBGCF/
      IF(ALLOCATED(KGCF))THEN
        DEALLOCATE(KGCF,NKSL,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGX: DE-ALLOCATION FAILS FOR KGCF,NKSL'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBGCF/
      IF(ALLOCATED(KGSL))THEN
        DEALLOCATE(KGSL,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGX: DE-ALLOCATION FAILS FOR KGSL'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
  700 WRITE(MW6,10010)
      KUTSSX=-1
      GO TO 500
!
  800 WRITE(MW6,10020)
!      KUTSSX=-1                                 !ALLOW BKUTSS FOR DWXBP
      GO TO 500
!
  900 WRITE(MW6,10030)
      GO TO 500
!
 1000 NF=-1
      GO TO 600
!
 1100 NF=0
      GO TO 600
!
!-----------------------------------------------------------------------
!
10010 FORMAT(/" NOT ENOUGH VCC'S AVAILABLE FOR CALCULATION OF",         &
     &       " RELATIVISTIC CORRECTIONS: CHANGE MOD  TO 1,-1 OR 0")
10020 FORMAT(/' *** NO TWO-BODY FINE-STRUCTURE POSSIBLE: SET MAXJFS NON'&
     &       ,'-NEGATIVE')
10030 FORMAT(/' *** NO TWO-BODY FINE-STRUCTURE POSSIBLE: SET KUTSSX TO '&
     &       ,'1 OR -9 ETC.')
10040 FORMAT(/' THIS WAS NO MORE THAN A DIMENSION CHECK -- IDW=',I2/)
10050 FORMAT(///1X,136('-')//52X,'*** COLLISION ALGEBRA (CA) ***'//1X,  &
     &       136('-')//)
10060 FORMAT(/' CONTINUUM ORBITAL INDEXING FOR TOTAL L:'/60X,' GAM',2X, &
     &       'SMALL L')
10070 FORMAT(60X,I4,3X,'L-',I2)
10080 FORMAT(60X,I4,3X,'L ',I2)
10090 FORMAT(60X,I4,3X,'L+',I2)
10100 FORMAT(/' WARNING SR.ALGX: YOU HAVE RESTRICTED THE CONTINUUM',    &
     &       ' EXPANSION TO:     L +/-',I2/29X,'WHILE THE FULL',        &
     &       ' EXPANSION EXTENDS TO:     L +/-',I2/)
10110 FORMAT('*** ERROR, SR.ALGX: YOU HAVE SPECIFIED CONFLICTING',      &
     &  ' OPTIONS FOR FINE-STRUCTURE COLLISION ALGEBRA; KUTSSX, MAXJFS='&
     &  ,2I4)
10120 FORMAT(/' DC ARRAY TOO LARGE TO READ (NEED NMTGD SET-UP) - TBD')
10130 FORMAT(//1X,136('-')//52X,'*** COLLISION ALGEBRA (LSJ) ***'//1X,  &
     &       136('-')///61X,'MAXJFS=',I3/61X,10('-')/)
10140 FORMAT(/' CONTINUUM ORBITAL INDEXING FOR TOTAL J:'/57X,' GAM',4X, &
     &       'SMALL L')
10150 FORMAT(57X,I4,3X,'INT(J)-',I2)
10160 FORMAT(57X,I4,3X,'INT(J) ',I2)
10170 FORMAT(57X,I4,3X,'INT(J)+',I2)
10180 FORMAT(/' WARNING SR.ALGX: YOU HAVE RESTRICTED THE LSJ CONTINUUM',&
     &       ' EXPANSION TO:     INT(J) +/-',I2/33X,'WHILE THE FULL',   &
     &       ' EXPANSION EXTENDS TO:     INT(J) +/-',I2/)
10190 FORMAT(///1X,136('-')//50X,'*** ELECTRON-IMPACT EXCITATION ***'// &
     &       1X,136('-')//)
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION MVC(M1,M2)
!
      INTEGER(SP) M1,M2,MVC
!
      MVC=((M1+2)*M1/2+M2)/2+1
!
      END FUNCTION MVC
!-----------------------------------------------------------------------
!
      END SUBROUTINE ALGX
!
!                             *******************
!
      SUBROUTINE ALGX0(QLMC,QBML,QBMS,JYI,JYF,MAXEL1)
!
!-----------------------------------------------------------------------
!
!  SR.ALGX0 RECOVERS TARGET INFO, ALGEBRA AND ENERGIES.
!
!  IT IS CALLED BY:
!    SR.ALGX
!
!  IT CALLS:
!    SR.NUMSYM
!    SR.RE_ALLOC
!
!-----------------------------------------------------------------------
!
      USE COMMON_ALGEB,  ONLY: MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD     &
     &                        ,KFBUFF
!!      COMMON /BASIC/NF,KX,KG,K1,K2,MGAP(7)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KX=>IBSK2,KG=>IBSK3,K1=>IBSK4,K2=>IBSK5            &
     &              ,IBSK6=>IBSK6,IBSK7=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9&
     &              ,IBSK10=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DC,     ONLY: BFAST,DC,IDC
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR,NTJ,NFJ
      USE COMMON_MINIM,  ONLY: BECOR
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_QTG,    ONLY: MTGD,NXLL,NTT,NTG,JTGD,QTGS,QTGL,QTGD    &
     &                        ,NFI,NFK,NFQ
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      use common_misc,   only: ione1,ione0
!
      USE COMMON_NRBAL0, ONLY: IRET0,LORIG,LMIN,MPRNT0,MOD0,MSTRT0,BPASS&
     &                        ,MLIT
      USE COMMON_NRBAL2, ONLY: MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                ,INAST0=>NASTB,MINSTB,MAXSTB,MINLTB,MAXLTB,LSPIB  &
     &               ,INASTJ0=>NASTJB,MINJTB,MAXJTB,JPIB,LFACT,JFACT    &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDW1, ONLY: MXORB,ma0,mb0
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
      USE COMMON_NRBDW4, ONLY: DSPECE,INDEX,JNDEX,NSPECE,NENERG
      USE COMMON_NRBDW9, ONLY: DSPECJ,INDXJ,JNDXJ,NSPECJ,NENERJ
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ !NMETAG0<-DUMP
      USE COMMON_NRBGCF, ONLY: KGSL,KGCF,NKSL,KSLX
      USE COMMON_NRBGRJ, ONLY: NSLJ,NGSLJ
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBIAD, ONLY: IADD,IADJ,IADJ8,NP8
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,INASTJ=>NASTJ                   &
     &                        ,MINJT,MAXJT,NEIGENJ
      USE COMMON_NRBKUT, ONLY: KCUTX,LSKUT,NASTK
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBORB, ONLY: IEQ
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      INTEGER(SP) SJ
!
      DIMENSION QLMC(MAXEL1,*),QBML(*),JYI(*),QBMS(*),JYF(*)
!
!-----------------------------------------------------------------------
!
      BPRNT0=JPRINT.NE.-3
      BTEST=BPRNT0          !.TRUE.                   !DETAILED PRINTOUT
!
! RE-POINT RESTART FILE
!
      REWIND(MRW10)
!
!-----------------------------------------------------------------------
! RECOVER TARGET HEADER INFO FROM ALGEB1 (NOTE: DEY IS JUST ON/OFF HERE)
! N.B. NOT ALL (SCALARS) USED, EX MORE GENERAL RESTART DUMP.
!-----------------------------------------------------------------------
!                                                                  !REC1
      READ(MRW10)MLIT,MXORB,NW,NF,MODD,KCUTX,KUTDSK,QQKUTX,QCL0,QCS0,   &
     &           MDCBUF,KSLX,MTGD,MTGDI,NTT,NSS,MAXEL,KMAX,NPRINT,MA0,  &
     &           MB0,MAXNV,IRLX,ITANAL,MXBORB,MXVORB,MXFORB,NGRP
      BACKSPACE(MRW10)
!
! EX-COMMON/MQVC/
      ALLOCATE(NEL(MXORB,KMAX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGX0: ALLOCATION FAILS FOR NEL'
        GO TO 1500
      ENDIF
!
! EX-COMMON/CCLSH/
      IAXCL=MAX(IONE,NW)
      ALLOCATE(NNL(IAXCL,3),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGX0: ALLOCATION FAILS FOR NNL'
        GO TO 1500
      ENDIF
!
! EX-COMMON/DBD2/
      ALLOCATE(QCP(KMAX),QCG(IXEL0,KMAX),QL(MXORB),QN(MXORB),DEY(MXORB),&
     &         STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGX0: ALLOCATION FAILS FOR QCP,QCG,QL,QN,DEY'
        GO TO 1500
      ENDIF
!
! EX-COMMON/QTG/
      ALLOCATE(NTG(0:KMAX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGX0: ALLOCATION FAILS FOR  NTG'
        GO TO 1500
      ENDIF
!
! EX-COMMON/NRBGCF/
      ALLOCATE(KGCF(0:KMAX),NKSL(KSLX,KMAX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGX0: ALLOCATION FAILS FOR KGCF,NKSL'
        GO TO 1500
      ENDIF
!
! EX-COMMON/NRBORB/
      ALLOCATE(IEQ(0:MXORB+1),STAT=IERR)            !+1 FOR POSS STOPOT
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGX0: ALLOCATION FAILS FOR IEQ'
        GO TO 1500
      ENDIF
!                                                                  !REC1
      READ(MRW10)MLIT,MXORB,NW,NF,MODD,KCUTX,KUTDSK,QQCUTX,QCL0,QCS0,   &
     &           MDCBUF,KSLX,MTGD,MTGDI,NTT,NSS,MAXEL,KMAX,NPRINT,MA0,  &
     &           MB0,MAXNV,IRLX,ITANAL,MXBORB,MXVORB,MXFORB,NGRP,       &
     &           ((NEL(I,J),I=1,MXORB),J=1,KMAX),                       &
     &           ((NNL(I,J),I=1,NW),J=1,3),                             &
     &           ((QCG(I,J),I=1,MAXEL),J=1,KMAX),(QL(I),I=1,MXORB),     &
     &           (QN(I),I=1,MXORB),(DEY(I),I=1,MXORB),(MSTAT,I=1,KMAX), &
     &           (IEQ(I),I=0,MXORB),(IGRCF,I=1,MXORB),(ICFGP,I=1,KMAX), &
     &           (KGCF(I),I=0,KMAX),                                    &
     &           ((NKSL(I,J),I=1,KGCF(J)-KGCF(J-1)),J=1,KMAX),          &
     &           (NTG(I),I=0,KMAX),(QCP(I),I=1,KMAX),(BANAL,I=1,KMAX)
!
      KCUT=ABS(KCUTX)
      BREL=NPRINT.LT.-4                            !INCASE BYPASS ALGEB0
      IF(BREL)NPRINT=MOD(NPRINT,IFIVE)
!
!-----------------------------------------------------------------------
! RECOVER SOME TARGET ALGEBRA FROM ALGEB1, AFTER CALL TO ALGEB3
!-----------------------------------------------------------------------
!
! EX-COMMON/QTG/
      ALLOCATE(JTGD(0:NTT),QTGS(NTT),QTGL(NTT),QTGD(NTT),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGX0: ALLOCATION FAILS FOR  JTGD,QTGX'
        GO TO 1500
      ENDIF
!
      READ(MRW10)(DC(I),I=0,MTGD)                                  !REC3
      READ(MRW10)(IDC(I),I=1,MTGDI)                                !REC3
      READ(MRW10)(JYI(I),I=1,KMAX),(JYF(I),I=1,KMAX),(QBML(I),I=1,NSS), &
     &           (QBMS(I),I=1,NSS),((QLMC(I,J),I=1,MAXEL),J=1,NSS),     &
     &           (JTGD(I),I=0,NTT),(QTGS(I),I=1,NTT),(QTGL(I),I=1,NTT), &
     &           (QTGD(I),I=1,NTT)
!
!-----------------------------------------------------------------------
! RECOVER SOME TARGET ALGEBRA FROM ALGEB2
! N.B. NOT ALL (SCALARS) USED, EX MORE GENERAL RESTART DUMP.
!-----------------------------------------------------------------------
!                                                                  !REC2
      READ(MRW10)IADD,IRK,IRKO,IRL,MTGD,MPOL00,MPOLE,IOS,NXLL,KUTLS,    &
     &           NSL0,NMETA,MXORBR
!
! EX-COMMON/QTG/
      ALLOCATE(NFI(NTT),NFK(NTT),NFQ(NTT),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGX0: ALLOCATION FAILS FOR  NFI,NFK,NFQ'
        GO TO 1500
      ENDIF
!
! EX-COMMON/TERMS/
      ALLOCATE(NSL(NSL0),QSI(NSL0),QLI(NSL0),QPI(NSL0),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGX0: ALLOCATION FAILS FOR NSL,QSI,QLI,QPI'
        GO TO 1500
      ENDIF
!
! EX-COMMON/NRBDWM/
      ALLOCATE(NMETAG(0:NSL0),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGX0: ALLOCATION FAILS FOR NMETAG'
        GO TO 1500
      ENDIF
!
! EX-COMMON/NRBGCF/
      ALLOCATE(KGSL(KMAX,NSL0),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGX0: ALLOCATION FAILS FOR KGSL'
        GO TO 1500
      ENDIF
!
! EX-COMMON/NRBGRP/
      ALLOCATE(NGRPI(NSL0),STAT=IERR) !NEED NADG(INAST) TARGET NOT USED
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGX0: ALLOCATION FAILS FOR NGRPI'
        GO TO 1500
      ENDIF
!                                                                  !REC3
      READ(MRW10)(NGRPI(I),I=1,NSL0),(NSL(I),I=1,NSL0),(QSI(I),I=1,NSL0)&
     &           ,(QLI(I),I=1,NSL0),(QPI(I),I=1,NSL0),                  &
     &           (NMETAG(I),I=0,NSL0),((KGSL(I,J),I=1,KMAX),J=1,NSL0),  &
     &           (NADGXIX,I=1,NSL0),(NFI(I),I=1,NTT),(NFK(I),I=1,NTT),  &
     &           (NFQ(I),I=1,NTT)
!
!-----------------------------------------------------------------------
! RECOVER SOME TARGET ALGEBRA FROM ALGEB3
! N.B. NOT ALL (SCALARS) USED, EX MORE GENERAL RESTART DUMP.
!-----------------------------------------------------------------------
!
      READ(MRW10)NJO,IRS,NL,IADJ8,IADJ0,IRKP,IRLP,NLEV,NMETAJ      !REC4
!
      IF(NJO.EQ.0)THEN                          !LS
        READ(MRW10)NJO                                             !REC5
      ELSE                                                         !REC5
!
! EX-COMMON/JSPOR/
        ALLOCATE(NRR(NLEV),NT(NJO),JN(NLEV),NGR(NLEV),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGX0: ALLOCATION FAILS FOR NJO,NRR,NT,JN,NGR'
          GO TO 1500
        ENDIF
!
! EX-COMMON/NRBDWM/
        ALLOCATE(NMETGJ(NJO),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGX0: ALLOCATION FAILS FOR NMETGJ'
          GO TO 1500
        ENDIF
!
! EX-COMMON/NRBGRJ/
        ALLOCATE(NSLJ(NSL0,NJO),NGSLJ(NJO),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGX0: ALLOCATION FAILS FOR NSL0,NGSLJ'
          GO TO 1500
        ENDIF
!
        READ(MRW10)NJO,(NRR(I),I=1,NLEV),(NT(I),I=1,NJO),               &
     &             (JN(I),I=1,NLEV),(NGR(I),I=1,NLEV),                  &
     &             (NMETGJ(I),I=1,NJO),((NSLJ(J,I),J=1,NSL0),I=1,NJO),  &
     &             (NGSLJ(I),I=1,NJO)
!     &         ,(NTJ(I),I=1,KMAX),(NFJ(I),I=1,NLEV)
      ENDIF
!
!-----------------------------------------------------------------------
! N.B. DUMP OF TARGET RADIAL INFO: DPNL, *DEY* ETC IS READ IN SR.RADCX0
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
! RECOVER TARGET DIAGON SO WE CAN SET METASTABLE AND CORRELATION ALGEBRA
!-----------------------------------------------------------------------
!
      READ(MRW10,END=100)NMETA                     !NDUM IF WANT NMETA=0
      READ(MRW10)(NMETAG(I),I=1,NSL0)
!      NENERG=0
      READ(MRW10)N,KCUT
      BECOR=N.LT.0
      IF(BECOR)N=-N
      NENERG=N
!
! EX-COMMON/NRBDW4/
      ALLOCATE(DSPECE(NENERG),INDEX(NENERG),JNDEX(NENERG),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGX0: ALLOCATION FAILS FOR DSPECE,INDEX,JNDEX'
        GO TO 1500
      ENDIF
!
      READ(MRW10)(INDEX(I),I=1,NENERG)
      READ(MRW10)(DSPECE(I),I=1,NENERG)                   !RYD NOW !
!
! REDUCE NENERG ENERGIES TO THE NSPECE NON-CORRELATION.
! THIS MAKES IT EASY TO HANDLE INTERSPERSED SPEC/CORR.
!
! ALSO, SET REVERSE INDEX(I), JNDEX(J):
! INDEX MAPS SPEC E.O. I=1,2,3  TO S.O.
! JNDEX MAPS *ALL S.O. I=1,2,3  TO SPEC E.O.
!   FOR CORR S.O. THE FULL E.O. POSITION IS SET. SUBSEQUENTLY, WE ONLY
!   CARE THAT IT HAS BEEN FLAGGED NEGATIVE FOR CORR. THE ACTUAL VALUE
!   IS NOT NEEDED/USED.
!
      NSPECE=0
      DO J=1,NENERG
        I=INDEX(J)
        if(i.lt.0)then
          jndex(-i)=-j
        else
          NSPECE=NSPECE+1
          JNDEX(I)=NSPECE                               !=J IN ORIG E.O.
          INDEX(NSPECE)=I
          DSPECE(NSPECE)=DSPECE(J)
        endif
      ENDDO
! if(nspece.lt.nenerg)then could re-allocate to reduce memory, but small
!
  100 IF(NENERG.EQ.0)THEN
        IF(NZION.NE.0)THEN                             !SHOULDN'T HAPPEN
          WRITE(MW6,*)'*** SR.ALGX0: MISSING LS TARGET INFO'
          WRITE(MW0,*)'*** SR.ALGX0: MISSING LS TARGET INFO'
          GO TO 1400
        ENDIF
! ELSE JUST AN ALGEBRA RUN
      ENDIF
!
! RE-RETABULATE THE NCI=NTG(KMAX) TERMS CASL OF THE KMAX CONFIGURATIONS
! ACCORDING TO TOTAL S,L,KPC(=PARITY  0,2 FOR EVEN,ODD); ONE OBTAINS
! NSL0 BLOCKS OF LENGTH NSL(N), WITH QSI(N)=2S,QLI(N)=2L,QPI(N)=KP;
! NGRPI(ND): GROUP ND STARTS AT NCI=NGRPI(ND)+1 IN TERM LIST
!***MOST OF THESE VARIABLES CAN BE RECOVERED FROM THE DUMP...
!
      WRITE(MW6,10070)NMETA
!
      NCTOT=0
      NCI=0
      NSL0=0
      NN=0
      NAST=INAST       !PASS NAST TARGETS, THEN -> INAST N+1 (USE BOTH)
!
      QCL=QCL0         !2L
!
  200 QCS=QCS0         !2S
!
  300 KCP=0            !2P
!
  400 NC=0
!
      DO K=1,KMAX
        IF(QCP(K).EQ.KCP)THEN
          NG0=NTG(K-1)+1
          NT0=NTG(K)
          QCS00=QTGS(NG0)
          QCL00=QTGL(NG0)
          K0=1
          ND0=0
          DO I=NG0,NT0
            IF(QTGL(I).NE.QCL00.OR.QTGS(I).NE.QCS00)THEN
              QCS00=QTGS(I)
              QCL00=QTGL(I)
              K0=K0+1
            ENDIF
            IF(QTGL(I).EQ.QCL.AND.QTGS(I).EQ.QCS)THEN
              NC=NC+1
              NCI=NCI+1
              ND=NSL0+1
              ND0=K0
              IF(BTEST)WRITE(MW6,10050)NCI,QCS+1,QCL/2,KCP/2,K,I,ND
              NFQ(NCI)=ND
              NFK(NCI)=K
              NFI(NCI)=I
            ELSE
              IF(QTGL(I).LT.QCL)GO TO 420                      !BAIL OUT
            ENDIF
          ENDDO
  420     IF(ND0.GT.0)KGSL(K,ND)=ND0                !GROUP NO. WITHIN CF
        ENDIF
      ENDDO
!
      IF(NC.GT.0)THEN
        NCTOT=NCTOT+NC*NC
!        if(btest)write(mw6,182)nc
        NN=((NC+1)*NC)/2+NN
        NSL0=ND
        QLI(ND)=QCL
        QSI(ND)=QCS
        QPI(ND)=INT(KCP,QP)
        NSL(ND)=NC
        NGRPI(ND)=NCI-NC
      ENDIF
!
      KCP=KCP+2
      IF(KCP.LE.2)GO TO 400           !LOOP UP TO NEXT PARITY
!
      QCS=QCS-QTWO
      IF(QCS.GE.0)GO TO 300           !LOOP UP FOR NEXT SPIN
!
      QCL=QCL-QTWO
      IF(QCL.GE.0)GO TO 200           !LOOP UP FOR NEXT ORB A.M.
!
      IADD=NN
!
      IF(NCI.NE.NENERG.AND.NZION.NE.0)THEN
        WRITE(MW6,10030)NCI,NENERG
        WRITE(MW0,10030)NCI,NENERG
        GO TO 1400
      ENDIF
!
!      if(btest)write(mw6,198)nctot,maxuc
!
! LOWEST (ENERGY) NMETA INITIAL TERMS TO ALL EXCITED STATES ONLY,
! SO FLAG GROUPS FOR OMISSION WHICH ONLY INTERACT VIA EXCITED STATES
! DEFAULT (NMETA=0) IS "ALL".
! (IF USER SETS NMETA.LT.0 THEN THEY COULD SPECIFY NMETAG DIRECTLY VIA
!  SALGEB NAMELIST... NOT CURRENTLY ALLOWED, BUT BP RUN SETS NMETAG
!  IN ALGX AND THEN RESETS .LT.0 TO SKIP HERE.)
!
      IF(ABS(MODD).GT.1)THEN
!
        NMETA=ABS(NMETA)
        NMETA=MIN(NMETA,NSPECE)
!
        DO N=1,NSL0                          !OR BGLS=IUNIT(14).LT.0
          IF(NMETAG(N).NE.0)THEN             !WAS SET IN STRUCTURE RUN
            BGLS=.TRUE.
            GO TO 450
          ENDIF
        ENDDO
        BGLS=.FALSE.                         !WAS NOT
  450   IF(NMETA.GT.0)THEN
          IF(.NOT.BGLS)THEN                  !SET NOW
            DO N=1,NSL0
              NMETAG(N)=1
            ENDDO
          ENDIF
          DO N=1,NMETA
            I=INDEX(N)
!            if(i.gt.0)then                          !else correlation
            ND=NFQ(I)
            IF(BGLS)THEN
              IF(NMETAG(ND).NE.0)THEN        !ABORT
                WRITE(MW0,10010)
                WRITE(MW6,10010)
                GO TO 1400
              ENDIF
            ELSE
              NMETAG(ND)=0
            ENDIF
!              write(mw0,*)i,nd
!            endif
          ENDDO
        elseif(nmeta.eq.0.and.nzion.ne.0)then    !shouldn't get here now
          stop 'algx0 error: nmeta.eq.0...'
        ENDIF
!
!        write(mw6,*)'lsp groups'
!        do k=1,nsl0
!          write(mw6,*)k,nmetag(k)
!        enddo
!
        GO TO 1200
!
      ENDIF
!
!-----------------------------------------------------------------------
! RECOVER TARGET DIAGFS SO WE CAN SET METASTABLE AND CORRELATION ALGEBRA
!-----------------------------------------------------------------------
!
      READ(MRW10,END=500) !NCTOT         !SKIP LS, AS NOT USED CURRENTLY
      READ(MRW10)  !(TFU(I),I=1,NCTOT)   !SKIP LS, AS NOT USED CURRENTLY
!
      READ(MRW10)NMETAJ                     !NDUM IF WANT NMETAJ=0
      READ(MRW10)(NMETGJ(I),I=1,NJO)
!      NENERJ=0
      READ(MRW10)N,KCUT
      BECOR=N.LT.0
      IF(BECOR)N=-N
      NENERJ=N
!
! EX-COMMON/NRBDW9/
      ALLOCATE(DSPECJ(NENERJ),INDXJ(NENERJ),JNDXJ(NENERJ),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGX0: ALLOCATION FAILS FOR DSPECJ,INDXJ,JNDXJ'
        GO TO 1500
      ENDIF
!
      READ(MRW10)(INDXJ(I),I=1,NENERJ)
      READ(MRW10)(DSPECJ(I),I=1,NENERJ)                   !RYD NOW !
!
! REDUCE NENERJ ENERGIES TO THE NSPECJ NON-CORRELATION.
! THIS MAKES IT EASY TO HANDLE INTERSPERSED SPEC/CORR.
!
! ALSO, SET REVERSE INDXJ(I), JNDXJ(J):
!  INDXJ MAPS SPEC E.O. I=1,2,3  TO S.O.
!  JNDXJ MAPS *ALL S.O. I=1,2,3  TO SPEC E.O.
!   FOR CORR S.O. THE FULL E.O. POSITION IS SET. SUBSEQUENTLY, WE ONLY
!   CARE THAT IT HAS BEEN FLAGGED NEGATIVE FOR CORR. THE ACTUAL VALUE
!   IS NOT NEEDED/USED.
!
      NSPECJ=0
      DO J=1,NENERJ
        I=INDXJ(J)
        if(i.lt.0)then
          jndxj(-i)=-j
        else
          NSPECJ=NSPECJ+1
          JNDXJ(I)=NSPECJ                               !=J IN ORIG E.O.
          INDXJ(NSPECJ)=I
          DSPECJ(NSPECJ)=DSPECJ(J)
        endif
      ENDDO
! if(nspecj.lt.nenerj)then could re-allocate to reduce memory, but small
!
  500 IF(NENERJ.EQ.0)THEN
        IF(NZION.NE.0)THEN                             !SHOULDN'T HAPPEN
          WRITE(MW6,*)'*** SR.ALGX0: MISSING IC TARGET INFO'
          WRITE(MW0,*)'*** SR.ALGX0: MISSING IC TARGET INFO'
          GO TO 1400
        ENDIF
! ELSE JUST AN ALGEBRA RUN
      ENDIF
!
! THE FOLLOWING SECTION SETS UP THE STATES ACCORDING TO THEIR
! J-VALUES: J=TOTAL ANGULAR MOMENTUM.
!***MOST OF THESE VARIABLES CAN BE RECOVERED FROM THE DUMP...
!
      bcutfs=nmetag(0).ne.0              !may use other values in future
      im=-1
      if(bcutfs)im=1
!
      WRITE(MW6,10080)NMETAJ*im
!
      DO J=1,NJO
        NGSLJ(J)=0
        DO I=1,NSL0
          NSLJ(I,J)=0   !NOT ALL TARGET SLP CONTRIB TO A GIVEN TARGET JP
        ENDDO
      ENDDO
!
      NJO=0
      NJ=0
      NP=0
      NCTOT=0
      NASTJ=INASTJ    !PASS NASTJ TARGETS, THEN -> INASTJ N+1 (USE BOTH)
!
      JACT=QCL0+QCS0
!
  600 KPI=0
!
  700 IF(NASTJ.GT.0)THEN                                  !SELECT BY JPI
        JT=10*JACT+KPI/2
        DO I=1,NASTJ
          IF(JT.EQ.JPI(I))GO TO 800                                !WANT
        ENDDO
        GO TO 1000                                           !DON'T WANT
      ELSEIF(NASTJ.LT.0)THEN                      !SELECT BY MINJT,MAXJT
        IF(JACT.LT.MINJT.OR.JACT.GT.MAXJT)GO TO 1000         !DON'T WANT
      ENDIF
!
  800 N0=0
      NDJ=NJO+1                                  !NDJ IS JP GROUP NUMBER
!
! DO LOOP TO FIND NUMBER OF LEVELS WHICH CAN RESULT IN GIVEN J
!
      IT=0
      DO I=1,NSL0
        NC=NSL(I)
        IT=IT+NC
        IF(QPI(I).NE.KPI)GO TO 900
!
        LJ=QLI(I)
        SJ=QSI(I)
        IF(ABS(LJ-SJ).GT.JACT.OR.(LJ+SJ).LT.JACT)GO TO 900
!
        IT=IT-NC
        NGSLJ(NDJ)=NGSLJ(NDJ)+1
        NSLJ(NGSLJ(NDJ),NDJ)=I
        DO N=1,NC
          IT=IT+1
          NJ=NJ+1
          N0=N0+1
          IF(BTEST)THEN
            KG=NFK(IT)
            WRITE(MW6,10060)NJ,SJ+1,LJ/2,JACT,KG,IT
          ENDIF
          NRR(NJ)=IT
          JN(NJ)=JACT
          NGR(NJ)=NDJ
        ENDDO
!
  900 ENDDO
!
      IF(N0.GT.0)THEN
        NJO=NDJ
        NP=((N0+1)*N0)/2+NP
        NCTOT=NCTOT+N0*N0
!        if(btest)write(mw6,181)ndj,jact,kpi/2,n0
        NT(NDJ)=N0
      ENDIF
!
 1000 KPI=KPI+2
      IF(KPI.EQ.2)GO TO 700              !LOOP BACK UP FOR SECOND PARITY
!
      JACT=JACT-2
      IF(JACT.GE.0)GO TO 600                   !LOOP BACK UP FOR NEXT 2J
!
      IADJ=NP
!
      IF(NJ.NE.NENERJ.AND.NZION.NE.0)THEN
        WRITE(MW6,10040)NJ,NENERJ
        WRITE(MW0,10040)NJ,NENERJ
        GO TO 1400
      ENDIF
!
!      if(btest)write(mw6,134)nctot,maxju
!
! NOW SET NMETAG, WHICH DEFINES THE LS(J) GROUP INTERACTIONS WE NEED,
! BASED UPON NMETAJ.
! PROBABLY DON'T WANT TO LET USER JOE OVERRIDE, I.E. RE-SET NMETA.GT.0.
!
! Default nmetaj.gt.0 will neglect 2fs between excited levels that at
! most spin-orbit mix with the metastable levels. (Passed via nmetag(0))
! User input nmetaj.lt.0 includes all allowed by a.m. selection.
!
!     bcutfs=nmetag(0).ne.0              !may use other values in future
!
! NMETGJ IS NOT CURRENTLY USED IN THE ALGX BRANCH (USED BY TARGET MK)
! RATHER, THE CONSTITUENT NMETAG GROUPS ARE USED/FLAGGED
! *THIS*, NMETGJ USE, MAY CHANGE AND SO WE SET IT UP CORRECTLY.
!
      NMETAJ=ABS(NMETAJ)
      NMETAJ=MIN(NMETAJ,NSPECJ)
!
! see if fully unitarized approximation ii, and set space for all phases
! (n.b. quietly switch-off maxjfs here if user has kutssx=-1, i.e
!  do not flag input conflict if maxjfs.ge.0...)
!
      bunit2=nmetaj.eq.nspecj.and.ione1.eq.0
      if(bunit2.and.(kutssx.eq.-1.or.kutssx.eq.-1937))then
        kutssx=0
        maxjfs=-2                                  !not -1, for sr.psymj
      elseif(maxjfs.eq.-1)then                   !not a wise user choice
        maxjfs=-2
      endif
!
      i0=0
      if(bcutfs)i0=-1
!
      DO N=1,NJO                           !OR BGLS=IUNIT(15).LT.0
        IF(NMETGJ(N).NE.0)THEN             !WAS SET IN STRUCTURE RUN
          BGIC=.TRUE.
          GO TO 1100
        ENDIF
      ENDDO
      BGIC=.FALSE.                         !WAS NOT
 1100 IF(NMETAJ.GT.0)THEN
        IF(.NOT.BGIC)THEN                  !SET NOW
          DO N=1,NJO
            NMETGJ(N)=1
          ENDDO
        ENDIF
        DO N=1,NMETAJ
          I=INDXJ(N)
!          if(i.gt.0)then                          !else correlation
          NDJ=NGR(I)                          !J-GROUP
          IF(BGIC)THEN
            IF(NMETGJ(NDJ).NE.0)THEN          !ABORT
              WRITE(MW0,10020)
              WRITE(MW6,10020)
              GO TO 1400
            ENDIF
          ELSE
            NMETGJ(NDJ)=0
          ENDIF
!          write(mw0,*)i,ndj
!        endif
        ENDDO
        IF(.NOT.BGIC)THEN                  !SINCE CONTROLLED BY NMETAJ
          DO K=1,NSL0
            NMETAG(K)=1
          ENDDO
        ENDIF
        DO N=1,NJO
          IF(NMETGJ(N).EQ.0)THEN
            NCN0=NGSLJ(N)
            DO NC0=1,NCN0
              ND=NSLJ(NC0,N)
              IF(BGIC)THEN
                IF(NMETAG(ND).gt.0)THEN      !ABORT
                  WRITE(MW0,10020)
                  WRITE(MW6,10020)
                  GO TO 1400
                else
                  nmetag(nd)=i0
                ENDIF
              ELSE
                NMETAG(ND)=i0
              ENDIF
            ENDDO
          ENDIF
        ENDDO
        if(bcutfs)then
          do n=1,nmetaj
            i=indxj(n)
            it=nrr(i)
            nd=nfq(it)
            nmetag(nd)=0
!            write(mw0,*)n,i,it,nd
          enddo
        endif
!        do n=1,nsl0
!          write(mw0,*)n,nmetag(n)
!        enddo
      elseif(nmetaj.eq.0.and.nzion.ne.0)then     !shouldn't get here now
        stop 'algx0 error: nmetaj.eq.0...'
      ENDIF
!
!      write(mw6,*)'jp groups'
!      do k=1,njo
!        write(mw6,*)k,nmetgj(k)
!      enddo
!      write(mw6,*)'lsp groups'
!      do k=1,nsl0
!        write(mw6,*)k,nmetag(k)
!      enddo
!
!-----------------------------------------------------------------------
! RE-INSTATE LS-SYMMETRY SELECTION
!-----------------------------------------------------------------------
!
 1200 CONTINUE
!
      INAST=INAST0
!
! EX-COMMON/NRBLS/
      IF(INAST.GT.0)THEN
        ALLOCATE(LSPI(INAST),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGX0: ALLOCATION FAILS FOR LSPI'
          GO TO 1500
        ENDIF
        IAXSL=INAST
      ELSE
        IF(.NOT.ALLOCATED(LSPI))THEN
          IAXSL=0
        ELSE
          STOP 'ALGX0: LSPI ALREADY ALLOCATED...'
        ENDIF
      ENDIF
!
! RESTORE
      DO I=1,INAST
        LSPI(I)=LSPIB(I)
      ENDDO
      MINLT=MINLTB
      MAXLT=MAXLTB
      MINSP=MINSTB
      MAXSP=MAXSTB
!
      WRITE(MW6,10090)
!
      IF(ABS(MODD).GT.1)GO TO 1300
!
!-----------------------------------------------------------------------
! RE-INSTATE J-SYMMETRY SELECTION
!-----------------------------------------------------------------------
!
      INASTJ=INASTJ0
!
! EX-COMMON/NRBJ/
      IF(INASTJ.GT.0)THEN
        ALLOCATE(JPI(INASTJ))
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGX0: ALLOCATION FAILS FOR JPI'
          GO TO 1500
        ENDIF
        IAXJG=INASTJ
      ENDIF
!
! RESTORE
      DO I=1,INASTJ
        JPI(I)=JPIB(I)
      ENDDO
      MINJT=MINJTB
      MAXJT=MAXJTB
!
!-----------------------------------------------------------------------
! PERFORM CONSISTENCY CHECKS ON LS & J, I.E. THAT WE HAVE REQUIRED SLP
! FOR JP AND THAT MAXLX IS SET APPROPRIATELY FOR MAXJFS.
!-----------------------------------------------------------------------
!
      IF(INAST0.LE.0)THEN
!
        IF(INASTJ0.LE.0)THEN
!
          M01=QCS0+1-2*((QCS0+1)/2)
          IF(MOD(MINJT,ITWO).EQ.MOD(INT(QCS0,SP),ITWO))THEN
            MINJT=MINJT-1
            MINJT=MAX(M01,MINJT)
          ENDIF
          IF(MAXJT.LT.200.AND.MOD(MAXJT,ITWO).EQ.MOD(INT(QCS0,SP),ITWO))&
     &       MAXJT=MAXJT+1
          IF(LVMAX.GE.0)THEN     !BTHRSH: CHECK BY CHANNEL LV (FOR BBGP)
!
            MAXJ=2*LVMAX+QCL0+QCS0+1
            IF(MAXJT.EQ.2000)MAXJT=MAXJ
            IF(MAXJT.GT.MAXJ)THEN
              WRITE(MW6,10100)
              WRITE(MW6,10170)MAXJ,LVMAX
              WRITE(MW6,10100)
              MAXJT=MAXJ
            ELSEIF(MAXJT.LT.MAXJ)THEN
              WRITE(MW6,10100)
              WRITE(MW6,10180)MAXJT,LVMAX,MAXJ
              WRITE(MW6,10100)
!              MAXJT=MAXJ                   !ALLOW USER TO RESTRICT BY J
            ENDIF
            MAXLT=(MAXJT+QCS0+1)/2   !DO NOT ALLOW USER TO RESTRICT BY L
!
            MINJ=2*LVMIN-QCL0-QCS0-1
            MINJ=MAX(M01,MINJ)
            IF(MINJT.GT.MINJ)THEN
              WRITE(MW6,10100)
              WRITE(MW6,10190)MINJT,LVMIN,MINJ
              WRITE(MW6,10100)
!              MINJT=MINJ                   !ALLOW USER TO RESTRICT BY J
            ELSEIF(MINJT.LT.MINJ)THEN
              WRITE(MW6,10100)
              WRITE(MW6,10200)MINJ,LVMIN
              WRITE(MW6,10100)
              MINJT=MINJ
            ENDIF
            MINLT=(MINJT-QCS0-1)/2   !DO NOT ALLOW USER TO RESTRICT BY L
            MINLT=MAX(IZERO,MINLT)
!
          ELSE                                !CHECK BY TOTAL L (FOR DW)
!
            IF(MAXLT.EQ.1000)MAXLT=30+(QCS0+1)/2
            IF(MAXLT.GT.100)THEN
              MAXLT=100
              WRITE(MW0,*)'*** SR.ALGX0: REDUCING MAXLT TO',MAXLT
              MINLT=MIN(MINLT,MAXLT)
            ENDIF
            IF(MAXJT.GT.200)THEN
              IF(MAXJT.NE.2000)WRITE(MW0,*)'***SR.ALGX0: REDUCING MAXJT'
              MAXJT=2*MAXLT-QCS0-1
              MINJT=MIN(MINJT,MAXJT)
            ELSE
              MAXL=(MAXJT+QCS0+1)/2
              IF(MAXLT.GT.MAXL)THEN
                WRITE(MW6,10100)
                WRITE(MW6,10110)MAXL,MAXJT
                WRITE(MW6,10100)
                MAXLT=MAXL
              ELSEIF(MAXLT.LT.MAXL)THEN
                WRITE(MW6,10100)
                WRITE(MW6,10120)MAXL,MAXJT
                WRITE(MW6,10100)
                MAXLT=MAXL           !DO NOT ALLOW USER TO RESTRICT BY L
              ENDIF
            ENDIF
!
            MINL=(MINJT-QCS0-1)/2
            MINL=MAX(IZERO,MINL)
            IF(MINLT.GT.MINL)THEN
              WRITE(MW6,10100)
              WRITE(MW6,10130)MINL,MINJT
              WRITE(MW6,10100)
              MINLT=MINL             !DO NOT ALLOW USER TO RESTRICT BY L
            ELSEIF(MINLT.LT.MINL)THEN
              WRITE(MW6,10100)
              WRITE(MW6,10140)MINL,MINJT
              WRITE(MW6,10100)
              MINLT=MINL
            ENDIF
!
          ENDIF
!
        ELSE                         !INASTJ0.GT.0
!
          MTEST=MOD(INT(QCS0,SP),ITWO)
          IFLAGJ=0
          DO I=1,INASTJ0
            IJ=JPI(I)/10
            IPJ=JPI(I)-IJ*10
            IF(MOD(IJ,ITWO).EQ.MTEST)THEN
              IF(IFLAGJ.EQ.0)WRITE(MW6,10150)
              IFLAGJ=IFLAGJ+1
              WRITE(MW6,10160)I,IJ,IPJ
            ELSE
              JCOUNT=0                  !THIS COUNTS THE LSPI FOR JPI(I)
              CALL NUMSYM(IJ,IPJ,JCOUNT)
              IAXSL=IAXSL+JCOUNT          !THIS INCLUDES DUPLICATE LSPI
            ENDIF
          ENDDO
          ALLOCATE(LSPI(IAXSL),STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'ALGX0: ALLOCATION FAILS FOR LSPI'
            GO TO 1500
          ENDIF
!
          MTEST=MOD(INT(QCS0,SP),ITWO)    !DUPLICATE FOR (FUTURE) SAFETY
          IFLAGJ=0
          JCOUNT=-1                    !NOW WE CAN STORE THE LSPI NEEDED
          INAST=0                                         !SO COUNT THEM
          DO I=1,INASTJ0
            IJ=JPI(I)/10
            IPJ=JPI(I)-IJ*10
            IF(MOD(IJ,ITWO).EQ.MTEST)THEN
              IF(IFLAGJ.EQ.0)WRITE(MW6,10150)
              IFLAGJ=IFLAGJ+1
              WRITE(MW6,10160)I,IJ,IPJ
            ELSE
              CALL NUMSYM(IJ,IPJ,JCOUNT)
            ENDIF
          ENDDO
          IF(IFLAGJ.GT.0)THEN
            WRITE(MW6,10220)
            WRITE(MW0,*)'***SR.ALGX0 ERROR:',IFLAGJ,                    &
     &                  ' ILLEGAL TOTAL 2J REQUESTED'
            NF=-1
            GO TO 1300
          ENDIF
          IF(INAST.LT.IAXSL)THEN
            CALL RE_ALLOC(LSPI,IONE,IAXSL,INAST,IERR)
            IAXSL=INAST
          ELSEIF(INAST.GT.IAXSL)THEN                  !SHOULD NOT HAPPEN
            STOP 'ALGX0: INITIAL ALLOCATION OF LSPI TOO SMALL...'
          ENDIF
          INAST0=INAST                                 !RE-SYNC.
!
        ENDIF
!
        IF(MAXJFS.GE.0)THEN
!          MLAM0=MXLAMX
          IF(MXLAMX.EQ.1000)THEN                 !MAX EXCHANGE MULTIPOLE
            IF(MAXLX.GE.100)THEN
              MXLAMX=NXLL+3                  !TWICE MAX ORB L+3 (was +1)
!              mxlamx=max(mxlamx,3)
            ELSE
!              MXLAMX=(MAXLX+1)/2
              MXLAMX=MAXLX-NXLL/2
            ENDIF
          ENDIF
!          IF(MAXLX.GE.100)MAXLX=2*MXLAMX            !MAX L FOR EXCHANGE
          IF(MAXLX.GE.100)MAXLX=MXLAMX+NXLL/2        !MAX L FOR EXCHANGE
          JTEST=MAXJFS
          IF(INASTJ.LE.0)JTEST=MIN(MAXJT,MAXJFS)
          IL=(JTEST+QCS0+1)/2
          IF(IL.GT.MAXLX)THEN
            WRITE(MW6,10210)IL
            WRITE(MW0,*)                                                &
     &              'NOTE: MAXLX IS INCREASED FOR 2-BODY FINE-STRUCTURE'
            MAXLX=IL
          ENDIF
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
 1300 RETURN
!
!-----------------------------------------------------------------------
!
 1400 NF=-1
      GO TO 1300
!
 1500 NF=0
      GO TO 1300
!
!-----------------------------------------------------------------------
!
10010 FORMAT('*** SR.ALGX: NMETA INCONSISTANCY, EITHER CREATE A NEW',   &
     &       ' "TERMS" FILE (BEST) OR DO NOT FLAG TO READ OLD FILE.')
10020 FORMAT('*** SR.ALGX: NMETAJ INCONSISTANCY, EITHER CREATE A NEW',  &
     &       ' "LEVELS" FILE (BEST) OR DO NOT FLAG TO READ OLD FILE.')
!  134 FORMAT(/82X,I9,5X,'MAXJU=',I9)
10030 FORMAT(/' SR.ALGX: MIS-MATCH BETWEEN ALGEB/DIAGON TARGET TERMS:', &
     &       2I5)
10040 FORMAT(/' SR.ALGX: MIS-MATCH BETWEEN ALGEB/DIAGFS TARGET LEVELS:',&
     &       2I5)
10050 FORMAT(I5,3I4,25X,I3,I6,I3)
10060 FORMAT(6I5)
!  198 FORMAT(/56X,I9,5X,'MAXUC=',I9)
10070 FORMAT(//'    T 2S+1  L  (P-0/1 FOR EVEN/ODD)',8X,'CF    NT GR',  &
     &       15X,'**** TARGET TERMS ****',15X,'NMETA=',I4)
10080 FORMAT(//'   LV  2S+1   L   2J   CF    T',39X,                    &
     &       '**** TARGET LEVELS ****',14X,'NMETAJ=',I5)
10090 FORMAT(///1X,136('-')//52X,'*** COLLISION ALGEBRA (LS) ***'//1X,  &
     &       136('-')//)
10100 FORMAT(//1X,136('-')//)
10110 FORMAT(/' NOTE: REDUCING MAXLT TO',I3,', THAT NEEDED BY MAXJT=',  &
     &       I4,' (=2J)')
10120 FORMAT(/' NOTE: INCREASING MAXLT TO',I3,', THAT NEEDED BY MAXJT=',&
     &       I4,' (=2J)')
10130 FORMAT(/' NOTE: REDUCING MINLT TO',I3,', THAT NEEDED BY MINJT=',  &
     &       I3,' (=2J)')
10140 FORMAT(/' NOTE: INCREASING MINLT TO',I3,', THAT NEEDED BY MINJT=',&
     &       I3,' (=2J)')
10150 FORMAT('  SYJ  2J   P')
10160 FORMAT(1X,3I4)
10170 FORMAT(/' NOTE: REDUCING MAXJT TO',I4,' (=2J)',                   &
     &       ', THAT NEEDED BY LVMAX=',I3)
10180 FORMAT(/' ***WARNING: YOU HAVE SET MAXJT=',I4,' (=2J)',           &
     &       ', LESS THAN THAT FORMALLY NEEDED BY LVMAX=',I3/22X,       &
     &       'SET MAXJT=',I4,7X,' TO SATISFY TRIANGLE RELATION')
10190 FORMAT(/' ***WARNING: YOU HAVE SET MINJT=',I3,' (=2J)',           &
     &       ', GREATER THAT FORMALLY NEEDED BY LVMIN=',I3/22X,         &
     &       'SET MINJT=',I3,7X,' TO SATISFY TRIANGLE RELATION')
10200 FORMAT(/' NOTE: INCREASING MINJT TO',I3,' (=2J)',                 &
     &       ', THAT NEEDED BY LVMIN=',I3)
10210 FORMAT(/'NOTE: MAX EXCHANGE L HAS BEEN INCREASED FOR 2-BODY',     &
     &       ' FINE-STRUCTURE TO MAXLX=',I3)
10220 FORMAT('***SR.ALGX ERROR: REQUESTED TOTAL 2J NOT POSSIBLE FOR ',  &
     &       'THIS ATOMIC TARGET - ADD/SUBTRACT 1 TO/FROM 2J')
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE ALGX0
!
!                             *******************
!
      SUBROUTINE ALGXFS(MAM,NAM,QLMC,QBML,QBMS,JYI,JYF,MAXEL1)
!
!-----------------------------------------------------------------------
!
!  SR.ALGXFS CALCULATES 2-BODY FS EIE COLLISION ALGEBRA IN LSJ-COUPLING.
!
!  IT IS CALLED BY:
!    SR.ALGX
!
!  IT CALLS:
!    SR.DIMUSE
!    SR.DISKDC
!    SR.NRB_TIME
!    FN.QPTLSJ
!    SR.RESX1
!    SR.RESX2
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!    FN.VCC
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam                            !par
!
      USE COMMON_ALGEB,  ONLY: MPRINT
      USE COMMON_ALGEB,  ONLY: MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD     &
     &                        ,KFBUFF
!!      COMMON /BASIC/NF,KF,KG,J1,J2,J1P,J2P,ND1,NDP1,LI,LF,NGAP
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,J1=>IBSK4,J2=>IBSK5            &
     &              ,J1P=>IBSK6,J2P=>IBSK7,ND1=>IBSK8,NDP1=>IBSK9       &
     &              ,LI=>IBSK10,LF=>IBSK11,IBSK12=>IBSK12
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DC,     ONLY: BFAST,DC,IDC
      USE COMMON_DMQSS3, ONLY: DSS,MSS,QSS,NADR,MAXMI0,MXRSS0
      USE COMMON_DMQSS3, ONLY: IRS,IRS0,NL,NL000
      USE COMMON_DMQSSS, ONLY: DSSS,MSSS,QSSS,MXS2I0,MXS2C0
      USE COMMON_DMQSSS, ONLY: IRSS,IRSS0,NLS,NLS00
      USE COMMON_MINIM,  ONLY: BECOR
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
      USE COMMON_NSTS2,  ONLY: NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2
      USE COMMON_QTG,    ONLY: MTGD,NXLL,NTT,NTG,JTGD,QTGS,QTGL,QTGD    &
     &                        ,NFI,NFK,NFQ
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      use common_misc,   only: ione1,ione0
      use common_misc,   only: iw,iwp,btime,btimex
!
      USE COMMON_NRBBBB, ONLY: BXIST0,BXIST1
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,INAST0=>NASTB                            &
     &                        ,INASTJ0=>NASTJB,LFACT,JFACT              &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDW1, ONLY: MXORB,ma0,mb0
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
      USE COMMON_NRBDW3, ONLY: DVC12,ICLRR,BLX,BEQUALM
      USE COMMON_NRBDW4, ONLY: DSPECE,INDEX,JNDEX,NSPECE,NENERG
      USE COMMON_NRBDWJ, ONLY: JSYMM,NCHGJ,NADGJ,NCHMXJ
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBDWX, ONLY: LLCH,ITARG,NCHG
      USE COMMON_NRBFL0, ONLY: KINTI,KINTF,KPTCFM
      USE COMMON_NRBGCF, ONLY: KGSL,KGCF,NKSL
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBIAD, ONLY: IADJ
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,INASTJ=>NASTJ                   &
     &                        ,MINJT,MAXJT,NEIGENJ
      USE COMMON_NRBKUT, ONLY: KCUTX,LSKUT,NASTK
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBORB, ONLY: IEQ
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M5)
      PARAMETER (TTYNY=TYNY/D1P3)
!
      INTEGER(SP) QPTLSJ                       !DO NOT USE SHORT INTEGER
!
      INTEGER(SP) SA,SAP
!
      CHARACTER(LEN=1) LIT
!
      DIMENSION MAM(*),NAM(*)
      DIMENSION QLMC(MAXEL1,*),QBML(*),QBMS(*),JYI(*),JYF(*)
!
      DIMENSION LIT(8),nej(2),mej(2)
!
      ALLOCATABLE :: BXIST2(:,:),qnf1(:)
!
      DATA LIT(1),LIT(2),LIT(3),LIT(4)/' ','A','B','C'/
      DATA LIT(5),LIT(6),LIT(7),LIT(8)/'*','a','b','c'/
!
! SUPPRESS COMPILER WARNINGS (SIGH...)
!
      QDUM=QBML(1)
!
!-----------------------------------------------------------------------
!
! some test set-up switches that user joe should not need to touch.
!
! if elastic is dropped here then it has an effect on inelastic
! transitions between terms of same symmetry because they are mixed
!
!old  ione0=0                                   !=0 retain elastic here
!
! if bcor then we have algebraic correlation, and we know how ordered
!
!      bcor=kmax*kcut.ne.kcut*kcut
!
! if becor then we have correlation by energy, and we know not where, so
!
      beqgrpl0=.not.becor                       !false for full li=lf mx
!
! if only algebraic then can reduce memory requirement  NADJ(NCORJ)
!
!      bcorr=bcor.and..not.becor.and.kcutx.ge.0
!
!-----------------------------------------------------------------------
!
      if(btimex)then
        if(abs(modd).le.1)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Starting proc',iam,' for algxfs'          !par
!par        else                                                    !par
          write(iw,*)'Starting algxfs'
!par        endif                                                   !par
        endif
        call nrb_time(timei)
        time0=timei
      endif
!
! INITIALIZATIONS
!
      BFAST=DC(0).LT.DZERO                 !ELSE OPT MEMORY
!***
      QQCUTX=1                          !TBD (OR COULD USE TARGET QQCUT)
!***
      IF(KUTDSK.LT.KMAX)THEN
        IEND=MTGD                                            !FOR DISKDC
        MTGD1=MTGD+1
!TEST CALL DISKDC(IUD,IONE,IZERO,IZERO,IZERO,IZERO,IZERO)!REPOINT
      ENDIF
!
!OLD      MXX=KF                               !SYMLSJ TRANSFER
!OLD      NCHMX=KG                             !  "       "
!
      NF1=NF+1
!
      NSS=JYF(KMAX)
!
      MKT=KUTSSX
      IF((MKT+3)/2.EQ.1)MKT=1+MKT        !ALIGNS DEFAULT KUTSSX=0 AND -1
      IF(-MKT.LT.KMAX)THEN                         !RESET BXIST0 FOR 2FS
        WRITE(MW6,10010)KUTSSX                                  !WARNING
        DO KF=1,KMAX
          DO KG=1,KF
            B2BODY=.FALSE.
            IF(MKT.GE.0.AND.KF.NE.KG)GO TO 10
!            IF(KCFSSX(KF)*KCFSSX(KG).LE.0)THEN !TBD or could use target
            IF(KF.GT.ABS(MKT))GO TO 10
            IF(KG.GT.ABS(MKT))GO TO 10
!            ENDIF
            B2BODY=BXIST0(KG,KF)
   10       BXIST0(KG,KF)=B2BODY
            BXIST0(KF,KG)=B2BODY
          ENDDO
        ENDDO
      ENDIF
!
!  INASTJ0 WAS THE NUMBER OF USER INPUT SYMMETRIES, NOW RE-SET TO
!  LAST SYMMETRY THAT CONTRIBS TO MAXJFS - THUS USER INPUT SHOULD BE
!  IN ASCENDING J. DEFAULT USAGE IS MINJT,MAXJT I.E. INAST0.LE. INPUT.
!  INASTJ IS THE TOTAL NUMBER OF JP SYMMS TO BE USED.
!
      DO J=1,INASTJ
        IJ=JPI(J)/10
        IF(IJ.LE.MAXJFS)INASTJ0=J
      ENDDO
!
! EX-COMMON/DMQSS3/
!
!     IXRSS=MAX(MXRSS0,MXRSS,IXRSS)                !USE LARGEST PREVIOUS
      IXRSS=MAX(MXRSS0,MXRSS)                     !RESET
!      IAXMI=MAX(MAXMI0,MAXMI,IAXMI)               !USE LARGEST PREVIOUS
      IAXMI=MAX(MAXMI0,MAXMI)                     !RESET
!
      ALLOCATE(DSS(IXRSS),MSS(IXRSS),QSS(5,IAXMI),NADR(0:IADJ),         &
     &         STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGXFS: ALLOCATION FAILS FOR  DSS,MSS,QSS,NADR'
        NF=0
        RETURN
      ENDIF
!
! EX-COMMON/DMQSSS/
!
!        IXS2C=MAX(MXS2C0,MXS2C,IXS2C)             !USE LARGEST PREVIOUS
      IXS2C=MAX(MXS2C0,MXS2C)                     !RESET
!        IXS2I=MAX(MXS2I0,MXS2I,IXS2I)             !USE LARGEST PREVIOUS
      IXS2I=MAX(MXS2I0,MXS2I)                     !RESET
!
      ALLOCATE(DSSS(IXS2C),MSSS(IXS2C),QSSS(5,IXS2I),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGXFS: ALLOCATION FAILS FOR  DSSS,MSSS,QSSS'
        NF=0
        GO TO 700
      ENDIF
!
! EX-COMMON/NSTS2/
!
      IXXX2=MAX(IXS2I,IAXMI)
      IXD27=KMAX*KMAX
      ALLOCATE(NADS2(0:IXD27),NSTJ2(IXS2C),NSTJ2D(IXS2C),IORIG2(IXXX2), &
     &         JORIG2(IXS2I),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGXFS: ALLOCATION FAILS FOR NADS2,NSTJ2, ETC'
        NF=0
        GO TO 700
      ENDIF
!
! LOCAL
!
      ALLOCATE(BXIST2(KMAX,KMAX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGXFS: ALLOCATION FAILS FOR BXIST2'
        NF=0
        GO TO 700
      ENDIF
!
      ALLOCATE(qnf1(nss),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGXFS: ALLOCATION FAILS FOR qnf1'
        NF=0
        GO TO 700
      ENDIF
!
!      ALLOCATE(IGRGR(MXORB))
!!
!      DO I=1,MB
!        IGRGR(I)=I                             !FOR BASIS='RLX', UNUSED
!      ENDDO
!
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!
! NOW GENERATE LSJ PARTIAL WAVE ALGEBRA, LOOPING OVER INITIAL AND FINAL
! LS CHANNELS RESOLVED BY CONTINUUM L,S=1/2 COUPLED TO TARGET SYMMETRY
! GROUPS, THEN RESOLVE BY INDIVIDUAL LEVELS.
!
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!
!
      WRITE(MW6,10140)KUTSSX,LIT(QQCUTX)
      WRITE(MW6,10150)MXADJ,MAXJG,MXSYJ,MXSYJ,MAXDK,MAXDK,IXRSS,IAXMI
!
      IF(IADJ.GT.MXADJ)THEN
        IF(MXADJ.GT.0)WRITE(MW6,10160)IADJ,MXADJ
      ENDIF
!
!
      KPI=0
      NL=0
      IRS=0
      MXIRSS=0
      MXNLS=0
      KPI=1
      KPIS=1
!
      NADS2(0)=0
      NADR(0)=0
      NCORJ=0
!
!-----------------------------------------------------------------------
! LOOP OVER TOTAL SYMMETRIES
!-----------------------------------------------------------------------
!
      DO KX=1,INASTJ0
!
        MTJ=JPI(KX)/10
        MTP=JPI(KX)-MTJ*10
        MTP=MTP+MTP
!
        if(mtj.gt.maxjfs)go to 100                  !case non-sequential
!
        MTMJ=MTJ
!t        if(mtj.ne.0)mtmj=mtj-2
!
!        write(mw0,*)kx,nadgj(kx),ncorj
        if(ncorj.ne.nadgj(kx))then
          stop 'ncorj.ne.nadgj(kx)'                    !shouldn't happen
        endif
!
! case user restricts lcondwj, set min/max channel l for this j and skip
! if outside this range. this (skipping, rather than redefining) avoids
! having to redefine in dwxbp as the channels are still indexed but have
! zero interactions. *** user should NOT restrict lcondwj ***
!
        lmin=mtj/2-(lcondwj-1)/2
        lmax=mtj/2+lcondwj/2
!        write(0,*)mtp,mtj,lcondwj,lmin,lmax
        lmin=lmin+lmin
        lmax=lmax+lmax
!
        INASTX=NCHGJ(KX)
!
!-----------------------------------------------------------------------
!
        if(btimex)then
!par        if(iam.ge.0)then                                        !par
!par          write(iwp,*)'Starting proc',iam                       !par&
!par     &              ,'symmetry',kx,':',mtj,mtp/2                !par
!par          call flush(iwp)                                       !par
!par        else                                                    !par
          write(iw,*)'Starting symmetry',kx,' :',mtj,mtp/2
!par        endif                                                   !par
!par!                                                               !par
          time1=dzero
          time2=dzero
          call nrb_time(timei)
          times=timei
        endif
!
!-----------------------------------------------------------------------
!
        DO IXX=1,INASTX                !BEGIN LOOP OVER INITIAL LS SYMMS
!
          IX=JSYMM(IXX,KX)
!
          NCN=NCHG(IX)
!
          IS=LSPI(IX)/10000
          IP=LSPI(IX)-IS*10000
          IL=IP/10
          IP=IP-IL*10
!                                                                 !ALIGN
          IF(MTP.NE.IP+IP)STOP 'IXX ERROR'
          MTS=IS-1
          MTL=IL+IL
!
          DO JXX=1,IXX                   !BEGIN LOOP OVER FINAL LS SYMMS
!
            JX=JSYMM(JXX,KX)
!
            NCNP=NCHG(JX)
!
            ISP=LSPI(JX)/10000
            IPP=LSPI(JX)-ISP*10000
            ILP=IPP/10
            IPP=IPP-ILP*10
!
            IF(MTP.NE.IPP+IPP)STOP 'JXX ERROR'
            MTSP=ISP-1
            MTLP=ILP+ILP
!                                                                 !ALIGN
            IF(MTSP+MTS.EQ.0)GO TO 60  !will need same test on forming H
            IF(MTLP+MTL.EQ.0)GO TO 60  !   ditto
!
            NCH=0
            NCHI=0
            NCHI0=0
!
!          write(mw0,*)'start algxfs',kx,ixx,jxx,ncorj
!
            DO NC0=1,NCN                 !BEGIN LOOP OVER INITIAL GROUPS
              L1=LLCH(1,NC0,IX)
              L2=LLCH(2,NC0,IX)
              NC=ITARG(NC0,IX)
              MC=NSL(NC)
              SA=QSI(NC)
              LA=QLI(NC)
              MCI=NGRPI(NC)
              ND1=NC
!                                                    !PRE-SELECT CONFIGS
              DO KK=1,KMAX
                BXIST1(KK)=KGSL(KK,NC).GT.0         !CF DOES/NOT CONTRIB
              ENDDO
!
              NCHP=0
              NCHIP=0
              NCHIP0=0
!
              if(ix.eq.jx)ncnp=nc0                         !sync with ls
!
              DO ND0=1,NCNP                !BEGIN LOOP OVER FINAL GROUPS
                L1P=LLCH(1,ND0,JX)
                L2P=LLCH(2,ND0,JX)
                ND=ITARG(ND0,JX)
                MCP=NSL(ND)
                SAP=QSI(ND)
                IF(abs(NMETAG(NC))+abs(NMETAG(ND)).EQ.2)GO TO 48
                                                             !LS SELEC
                LAP=QLI(ND)
                MCIP=NGRPI(ND)
                NDP1=ND
!
                BEQGRP=IX.EQ.JX.AND.NC.EQ.ND             !WITHIN A GROUP
!
                DO KF=1,KMAX                                 !INITIALIZE
                  IF(BXIST1(KF))THEN
                    DO KG=1,KMAX
                      BXIST2(KG,KF)=BXIST0(KG,KF)
                    ENDDO
                  ELSE
                    DO KG=1,KMAX
                      BXIST2(KG,KF)=.FALSE.
                    ENDDO
                  ENDIF
                ENDDO
!                                                    !PRE-SELECT CONFIGS
                DO KG=1,KMAX
                  IF(KGSL(KG,ND).LE.0)THEN          !CF DOES NOT CONTRIB
                    DO KF=1,KMAX
                      BXIST2(KG,KF)=.FALSE.
                    ENDDO
                  ENDIF
                ENDDO
!
!------------------------------------------------------------
!  DETERMINE SLATER STATE INTERACTIONS BETWEEN GROUP CHANNELS
!------------------------------------------------------------
!
                NCHI=NCHI0
                DO LI=L1,L2,4               !LOOP OVER INITIAL CHANNEL L
!
                  bskipl=li.lt.lmin.or.li.gt.lmax
!
                  lf2=l2p
                  if(beqgrp)lf2=li
!
                  NCHIP=NCHIP0
                  DO LF=L1P,lf2,4             !LOOP OVER FINAL CHANNEL L
!
                    bskipl=bskipl.or.lf.lt.lmin.or.lf.gt.lmax
!
                    IRSS=0
                    NLS=0
                    J1=2
                    beqgrpl=beqgrpl0.and.beqgrp.and.li.eq.lf
!
                    ncorjt=qptlsj(kx,ixx,jxx,nc0,nd0,li,lf)
                    if(ncorjt.ne.ncorj)then
                      write(mw0,*)kx,ixx,jxx,nc0,nd0,li,lf,ncorj,ncorjt
                      stop 'ncorj mis-match'
                    endif
!
                    KK=0
                    KG2=KMAX
                    DO KF=1,KMAX         !BEGIN LOOP OVER INITIAL CONFGS
!
                      IF(beqgrpl)KG2=KF
                      DO KG=1,KG2          !BEGIN LOOP OVER FINAL CONFGS
                        KK=KK+1
!
                        IF(.NOT.BXIST2(KG,KF))GO TO 42
!
                        if(bskipl)go to 42  !user has restricted lcondwj
!
                        BEQCFS=KF.EQ.KG
                        BEQUAL=BEQGRPL.AND.BEQCFS
!test                    bequal=.false.
                        BEQUALM=BEQUAL
!
                        if(kf.ge.kg)then
                          i1=1
                          i2=2
                          K2=(KF*(KF-1))/2+KG
                        else
                          i1=2
                          i2=1
                          K2=(KG*(KG-1))/2+KF
                        endif
!
! FOR BASIS='RLX' - NOT USED SINCE NO ONE-BODY HERE...
!
!                    DO I=MB+1,MXORB
!                      IGRGR(I)=0
!                    ENDDO
!!
!                    DO I=NF,1,-1
!                      II=QCG(I,KF)
!                      DO L=NF,1,-1
!                        J=QCG(L,KG)
!                        IF(IEQ(J).EQ.IEQ(II))THEN
!                          IF(IGRGR(II).EQ.0)IGRGR(II)=J
!                        ENDIF
!                      ENDDO
!                    ENDDO
!
                        IRSS0=IRSS+1
                        NLS00=NLS
!
                        ICLRR=1
!
!-----------------------------------------------------------------------
! LOOP-OVER ALL POSSIBLE ML,MS, ML',MS' THAT FORM MTML,MTMS, MTML',MTMS'
! AND PICK-OUT THE CORRESPONDING SLATERSTATES, FOR THE KF,KG.
!-----------------------------------------------------------------------
!
                        MTMS=MTS
   12                   MTML=MTMJ-MTMS
                        BLX1=MTMS.NE.-MTS.AND.MTML.NE.MTL
                        IF(MTML.LT.-MTL)GO TO 38
!
                        DVCJ1=VCC(MTL,MTS,MTJ,MTML,MTMS,MTMJ)
!
                        MTMSP=MTSP
   14                   MTMLP=MTMJ-MTMSP
                        BLX2=MTMSP.NE.-MTSP.AND.MTMLP.NE.MTLP
                        IF(MTMLP.LT.-MTLP)GO TO 36
                        if(abs(mtmsp-mtms).gt.4)go to 36
!
                        DVCJ2=VCC(MTLP,MTSP,MTJ,MTMLP,MTMSP,MTMJ)
!
!                   write(mw6,*)mtms,mtml,mtmsp,mtmlp,mtmj,irss
!
                        QML=INT(LA,QP)
   16                   BLXL1=QML.NE.-INT(LA,QP)
                        ML=MTML-INT(QML,SP)
                        IF(ML.GT.LI)GO TO 36
                        IF(-ML.GT.LI)GO TO 34
                        DVCL1=VCC(LA,LI,MTL,INT(QML,SP),ML,MTML)
!
                        QMS=INT(SA,QP)
   18                   BLXS1=QMS.NE.-INT(SA,QP)
                        MS=MTMS-INT(QMS,SP)
                        IF(MS.GT.1)GO TO 34
                        IF(-MS.GT.1)GO TO 32
!
!                   write(mw6,*)sa,'1',mts,qms,ms,mtms,' x  '
!     &                      ,la,li,mtl,qml,ml,mtml
!
                        DVCS1=VCC(SA,IONE,MTS,INT(QMS,SP),MS,MTMS)
                        DVC1=DVCL1*DVCS1*DVCJ1
                        IF(ABS(DVC1).LT.TTYNY)GO TO 32
!
!                    write(mw6,*)sa,'1',mts,qms,ms,mtms,' xx '
!     &                       ,la,li,mtl,qml,ml,mtml
!                    write(mw6,*)dvcs1,dvcl1
!
                        QMLP=INT(LAP,QP)
!ls                    IF(BEQUAL)QMLP=QML
   20                   BLXL2=QMLP.NE.-INT(LAP,QP)
                        MLP=MTMLP-INT(QMLP,SP)
                        IF(MLP.GT.LF)GO TO 32
                        IF(-MLP.GT.LF)GO TO 28
                        DVCL2=VCC(LAP,LF,MTLP,INT(QMLP,SP),MLP,MTMLP)
!
                        QMSP=INT(SAP,QP)
!ls                    IF(BEQUAL)QMSP=QMS
   22                   BLXS2=QMSP.NE.-INT(SAP,QP)
                        MSP=MTMSP-INT(QMSP,SP)
                        IF(MSP.GT.1)GO TO 30
                        IF(-MSP.GT.1)GO TO 28
!
!                    write(mw6,*)sap,'1',mtsp,qmsp,msp,mtmsp,' y  '
!     &                       ,lap,lf,mtlp,qmlp,mlp,mtmlp
!
                        DVCS2=VCC(SAP,IONE,MTSP,INT(QMSP,SP),MSP,MTMSP)
                        DVC2=DVCL2*DVCS2*DVCJ2
!
                        DVC12=DVC1*DVC2
                        IF(ABS(DVC12).LT.TYNY)GO TO 28
                        IF(BEQUAL)THEN
!ls                      IF(QMS.NE.QMSP)DVC12=DVC12+DVC12
!ls                      IF(QML.NE.QMLP)DVC12=DVC12+DVC12
                          BEQUALM=QMS.EQ.QMSP.AND.QML.EQ.QMLP
                        ENDIF
!
!                    write(mw6,*)sap,'1',mtsp,qmsp,msp,mtmsp,' yy '
!     &                       ,lap,lf,mtlp,qmlp,mlp,mtmlp
!                    write(mw6,*)dvcs2,dvcl2
!                    write(mw6,*)dvc12
!
                        BLX=BLXL1.OR.BLXL2.OR.BLXS1.OR.BLXS2.OR.BLX1.OR.&
     &                      BLX2
!
! SET POINTERS THAT SELECT SLATER STATE INTERACTIONS FOR QML & QMLP
!
                        if(beqcfs)then
                          if(qmlp.ge.qml)then
                            i1=1
                            i2=2
                          else
                            i1=2
                            i2=1
                          endif
                        endif
!
                        mej(i1)=qml/2
                        mej(i2)=qmlp/2
                        k1=kptcfm(mej(2),mej(1),k2)
                        mej(2)=mej(2)+1
                        k0=kptcfm(mej(2),mej(1),k2)+1
!
! NAM(J2) IS CONSTRUCTED TO SELECT INITIAL & FINAL STATES
!         HAVING THE CORRECT QML, QMS & QMLP,QMSP.
!
! If non-trivial time taken in this search, do a double sweep as in
!   v22.11. The coding below does seem to inhibit compiler optimization.
!
                        J2=1
                        do k=k0,k1
                          nej(i1)=kinti(k)
                          nej(i2)=kintf(k)
                          j=nej(1)
                          jp=nej(2)
                          jp0=jp
                          kp=k
   24                     IF(QBMS(J).EQ.QMS.AND.QBMS(JP).EQ.QMSP)THEN
                            J2=J2+1
                            if(j2.gt.nss)then
                              write(mw6,*)                              &
     &                                'sr.algxfs: mxst0/nss exceeded...'
                              write(mw0,*)                              &
     &                                'sr.algxfs: mxst0/nss exceeded...'
                              go to 600
                            endif
                            if(beqcfs.and.qmlp.lt.qml)kp=-kp
                            MAM(J2)=kp
                            QLMC(NF1,J)=INT((MS+1)/2+ML,QP)
                            if(j.ne.jp)then
                              QLMC(NF1,JP)=INT((MSP+1)/2+MLP,QP)
                            else
                              qnf1(jp)=INT((msp+1)/2+mlp,QP)
                            endif
                          ENDIF
                          if(beqcfs.and.QML.eq.QMLP.and.j.ne.jp0)then
                            jp=j
                            j=jp0
                            kp=-kp
                            go to 24
                          endif
                        enddo
!
                        IF(J2.LT.J1)GO TO 28
!
!-------------------------------------------------------------
! CALCULATE THE SLATER-STATE INTERACTION BETWEEN CFS KF AND KG
!-------------------------------------------------------------
!
                        if(btimex)call nrb_time(timei)
!
   26                   CALL RESX1(QLMC,MAM,qnf1,MAXEL1)
!
                        if(btimex)then
                          call nrb_time(timef)
                          time1=time1+timef-timei
                        endif
!
                        MXIRSS=MAX(MXIRSS,IRSS)
                        MXNLS=MAX(MXNLS,NLS)
                        IF(IRSS.GT.IXS2C)KPIS=0
                        IF(NLS.GT.IXS2I)KPIS=-1
                        IF(KPIS.LE.0)GO TO 200
                        IF(NF.LT.0)GO TO 600
!
                        IF(ICLRR.EQ.0)GO TO 40
!
!---------------------------------------------------------------------
! IF BLXL,S,1,2=.TRUE. THE TRANSFORMATION TO THE LS,L'S' REPRESENTATION
!                     IS NOT YET COMPLETE.
!---------------------------------------------------------------------
!
   28                   QMSP=QMSP-QTWO
                        IF(BLXS2)GO TO 22
!
   30                   QMLP=QMLP-QTWO
                        IF(BLXL2)GO TO 20
!
   32                   QMS=QMS-QTWO
                        IF(BLXS1)GO TO 18
!
   34                   QML=QML-QTWO
                        IF(BLXL1)GO TO 16
!
!--------------------------------------------------------------
! IF BLX1,2=.TRUE. THE TRANSFORMATION TO THE J,MJ REPRESENTATION
!                 IS NOT YET COMPLETE.
!--------------------------------------------------------------
!
   36                   MTMSP=MTMSP-2
!
                        IF(BLX2)GO TO 14
!
   38                   MTMS=MTMS-2
!
                        IF(BLX1)GO TO 12
!
! CLEAR ARRAYS, IF NOT ALREADY DONE
!
   40                   IF(ICLRR.NE.0)THEN
                          ICLRR=-ICLRR
                          GO TO 26
                        ENDIF
!
   42                   NADS2(KK)=IRSS
!
!        nkk=nads2(kk)-nads2(kk-1)
!        write(mw6,*)'***** kf,kg:',kf,kg,nkk
!        if(nkk.eq.xxx)then      !select particular value for breakpoint
!          write(mw0,*)'we are here'
!        endif
!        do ijk=nads2(kk-1)+1,nads2(kk)
!          write(mw6,777)nstj2(ijk),nstj2d(ijk),msss(ijk),dsss(ijk)
!  777  format(3i5,f12.6)
!        enddo
!        do ijk=nls00+1,nls
!          write(mw6,778)ijk,(qsss(lll,ijk),lll=1,5)
!  778   format(i4,2x,5i4)
!        enddo
!
                      ENDDO                                 !END LOOP KG
!
                    ENDDO                                   !END LOOP KF
!
!------------------------------------------------------------------
! NOW DETERMINE THE INTERACTION BETWEEN TERMS OF THE LSP GROUPS
!------------------------------------------------------------------
!
                    if(btimex)call nrb_time(timei)
!
                    istrt0=0
                    KF0=0
                    DO MD1=1,MC           !BEGIN LOOP OVER INITIAL TERMS
                      J1=MD1+MCI
                      j=jndex(j1)
                      if(kcutx.lt.0)j=abs(j)          !keep corr.-corr.
                      KF=NFK(J1)
!
                      IF(KF.GT.KUTDSK.AND.KF.NE.KF0)THEN
                        NGSYM=KGSL(KF,NC)                 !POS WITHIN CF
                        ISTRT=MTGD1
!
                        CALL DISKDC(IUD,ISTRT,IEND,KF,NGSYM,IONE,IZERO)
!
                        ISTRT0=ISTRT-MTGD1      !ALLOW FOR RE-DEFINITION
                        IF(IEND.LT.0)GO TO 600
                                             !FAIL TO READ REQUIRED DATA
                        KF0=KF
                      ENDIF
!
                      II=NFI(J1)
                      IF(BFAST)THEN
                        J2=JTGD(II)+ISTRT0       !relative start flagged
                        do jj=jyi(kf),jyf(kf)
                          jy=j2+jj
                          if(abs(dc(jy)).lt.tyny)then
                            mam(jj)=0
                          else
                            mam(jj)=jy
                          endif
                        enddo
                      ELSE
                        do jj=jyi(kf),jyf(kf)
                          mam(jj)=0
                        enddo
                        k2=jtgd(ii)                !absolute end flagged
                        if(k2.lt.0)then            !bdisk first
                          k2=-k2
                          k1=mtgd
                        else
                          k1=jtgd(ii-1)            !start
                          k1=abs(k1)              !case bdisk second
                        endif
                        k1=k1+1+istrt0
                        k2=k2+istrt0
                        do k12=k1,k2
                          jj=idc(k12)
                          mam(jj)=k12
                        enddo
                      ENDIF
!
                      istrt=0
                      KG0=0
                      DO MDP1=1,MCP         !BEGIN LOOP OVER FINAL TERMS
                        J1P=MDP1+MCIP
                        IF(beqgrpl.and.J1P.GT.J1-ione0)GO TO 46
!
                        IF(becor)ncorj=ncorj+1
                                          !need for dwxbp reversed symms
!
                        jp=jndex(j1p)
                        IF(j.LT.0.AND.jp.LT.0)GO TO 44
                                         !neglect corr-corr, alg or ener
!
                        KG=NFK(J1P)
!
                        IF(KG.GT.KUTDSK.AND.KG.NE.KG0)THEN
                          LGSYM=KGSL(KG,ND)               !POS WITHIN CF
                          ISTRT=IEND+1
!
                          CALL DISKDC(IUD,ISTRT,IFIN,KG,LGSYM,IONE,     &
     &                                IZERO)
!
                          ISTRT=ISTRT-MTGD1     !ALLOW FOR RE-DEFINITION
                          IF(IFIN.LT.0)GO TO 600
                                             !FAIL TO READ REQUIRED DATA
                          KG0=KG
                        ENDIF
!
                        II=NFI(J1P)
                        IF(BFAST)THEN            !nam not used, only mam
                          J2P=JTGD(II)+ISTRT     !relative start flagged
                        ELSE
                          do jj=jyi(kg),jyf(kg)
                            nam(jj)=0
                          enddo
                          k2=jtgd(ii)              !absolute end flagged
                          if(k2.lt.0)then          !bdisk first
                            k2=-k2
                            k1=mtgd
                          else
                            k1=jtgd(ii-1)          !start
                            k1=abs(k1)            !case bdisk second
                          endif
                          k1=k1+1+istrt
                          k2=k2+istrt
                          do k12=k1,k2
                            jj=idc(k12)
                            nam(jj)=k12
                          enddo
                        ENDIF
!
                        IF(beqgrpl)THEN            !KG.LE.KF HERE
                          KK=(KF*(KF-1))/2+KG
                          if(kf.lt.kg)stop 'algxfs: kf.lt.kg?'
                        ELSE
                          KK=KMAX*(KF-1)+KG
                        ENDIF
!
                        CALL RESX2(mam,nam,KK)
!
                        if(.not.becor)NCORJ=NCORJ+1    !reverse of above
!
                        IF(IRS.GT.IXRSS)KPI=0
                        IF(NL.GT.IAXMI)KPI=-1
                        IF(KPI.LE.0)GO TO 200
                        IF(NF.LT.0)GO TO 600
!
                        IF(MPRINT.GT.0)THEN
                          NCH=NCHI+MD1
                          NCHP=NCHIP+MDP1
                          IF(IRS-IRS0.EQ.5)THEN
                            WRITE(MW6,10060)NCORJ,KX,IX,JX,NCH,NCHP,IRS,&
     &                            NL,(MSS(N),DSS(N),N=IRS0,IRS)
                          ELSEIF(IRS.GE.IRS0)THEN
                            WRITE(MW6,10070)NCORJ,KX,IX,JX,NCH,NCHP,IRS,&
     &                            NL,(MSS(N),DSS(N),N=IRS0,IRS)
                          ENDIF
                          WRITE(MW6,10060)
                        ELSEIF(MPRINT.EQ.0)THEN
                          IF(NCHP.EQ.NCH)WRITE(MW6,10030)NCORJ,KX,IX,JX,&
     &                       NCH,NCHP,IRS,NL
                        ENDIF
!
   44                   NADR(NCORJ)=IRS                 !MUST BE ALLOWED
!
                      ENDDO                   !END LOOP OVER FINAL TERMS
!
   46               ENDDO                   !END LOOP OVER INITIAL TERMS
!
                    if(btimex)then
                      call nrb_time(timef)
                      time2=time2+timef-timei
                    endif
!
                    NCHIP=NCHIP+MCP
                  ENDDO                           !END LOOP OVER FINAL L
!
                  NCHI=NCHI+MC
                ENDDO                           !END LOOP OVER INITIAL L
!
   48           NCHIP0=NCHIP0+((L2P-L1P)/4+1)*MCP
                                                !=NCHIP
              ENDDO                          !END LOOP OVER FINAL GROUPS
!
              NCHI0=NCHI0+((L2-L1)/4+1)*MC    !=NCHI
            ENDDO                          !END LOOP OVER INITIAL GROUPS
!
   60     ENDDO                            !END LOOP OVER FINAL LS SYMMS
!
        ENDDO                            !END LOOP OVER INITIAL LS SYMMS
!
!-----------------------------------------------------------------------
!
        if(btimex)then
          call nrb_time(timef)
          times=timef-times
!
!par        if(iam.ge.0)then                                        !par
!
!
!par!          write(iwp,*)'resx1',time1                            !par
!par!          write(iwp,*)'resx2',time2                            !par
!
!par          write(iwp,*)'Ending proc',iam,'symmetry',kx,':'       !par&
!par     &             ,'time=',nint(times),'sec'                   !par
!par        else                                                    !par
!
!        write(iw,*)'resx1',time1
!        write(iw,*)'resx2',time2
!
          write(iw,*)'Ending symmetry',kx,' :','time=',nint(times),'sec'
!par        endif                                                   !par
        endif
!
!-----------------------------------------------------------------------
!
  100 ENDDO                                 !END LOOP OVER JP SYMMETRIES
!
      IF(IADJ.NE.NCORJ)THEN
        WRITE(MW6,*)'GLOBAL INDEX ERROR:',IADJ,NCORJ      !remove evntly
        GO TO 600
      ENDIF
!      IADJ=NCORJ
!
      CALL DIMUSE('MXRSS',IRS)
      CALL DIMUSE('MAXMI',NL)
      CALL DIMUSE('MXS2C',MXIRSS)
      CALL DIMUSE('MXS2I',MXNLS)
!
! RESULTS
!
      IF(MPRINT.GE.0)WRITE(MW6,10020)IXS2C,IXS2I,MXIRSS,MXNLS
      IF(MPRINT.EQ.0)GO TO 700                                   !RETURN
      IF(MPRINT.GT.0)GO TO 300
!
  200 WRITE(MW6,10070)NCORJ,INASTJ0,IXSYJ,IXSYJ,NCHMXJ,NCHMXJ,IRS,NL
      IF(KPI.LE.0)GO TO 400
!
      WRITE(MW6,10020)IXS2C,IXS2I,MXIRSS,MXNLS
      IF(KPIS.LE.0)GO TO 500
!
      GO TO 700                                                  !RETURN
!
  300 WRITE(MW6,10120)
      M197=197-LCONDWJ-3
      DO L=1,NL
        IF(QSS(5,L).GT.M197)THEN
          WRITE(MW6,10050)L,(QSS(K,L),K=1,5)
        ELSE
          WRITE(MW6,10130)L,(QSS(K,L),K=1,5)
          if(qss(5,l).gt.150)stop 'N&V Index error...'
        ENDIF
      ENDDO
!
      GO TO 700                                    !RETURN
!
! PRINT FAILURE DIAGNOSTIC (DIMENSION FAILURE NOT SEPARATE)
!
  400 IF(KPI.EQ.0)WRITE(MW6,10080)
      IF(KPI.LT.0)WRITE(MW6,10090)
      GO TO 600
  500 IF(KPIS.EQ.0)WRITE(MW6,10100)
      IF(KPIS.LT.0)WRITE(MW6,10110)
!
  600 WRITE(MW6,10040)
      NF=-1                       !<-------------------- ABNORMAL RETURN
!
  700 CONTINUE
!
! IF ACTUAL USAGE IS SUFFICIENTLY SMALLER THAN *INITIAL* ALLOCATION,
! THEN REDUCE USAGE TO ACTUAL - FOR SMALL CASES ON SMALL MEMORY MACHINES
!
      IXXX=(4*MAXMI)/5
      IF(NL.LT.IXXX)THEN
!
!        WRITE(MW6,*)'*** ALGXFS: decreasing MAXMI from ',IAXMI,' to: '
!                   ,NL
!        WRITE(MW0,*)'*** ALGXFS: decreasing MAXMI from ',IAXMI,' to: '
!                  ,NL
!
        CALL RE_ALLOC2(QSS,IONE,IFIVE,IONE,IAXMI,IFIVE,NL,IERR)
!
        IAXMI=NL
!
      ENDIF
!
      IXXX=(4*MXRSS)/5
      IF(IRS.LT.IXXX)THEN
!
!       WRITE(MW6,*)'*** ALGXFS: decreasing MXRSS from ',IXRSS,' to: '
!                 ,IRS
!       WRITE(MW0,*)'*** ALGXFS: decreasing MXRSS from ',IXRSS,' to: '
!                 ,IRS
!
        CALL RE_ALLOC(DSS,IONE,IXRSS,IRS,IERR)
!
        CALL RE_ALLOC(MSS,IONE,IXRSS,IRS,IERR)
!
        IXRSS=IRS
!
      ENDIF
!
! LOCAL
      IF(ALLOCATED(BXIST2))THEN
        DEALLOCATE(BXIST2,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGXFS: DE-ALLOCATION FAILS FOR BXIST2'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! LOCAL
      IF(ALLOCATED(qnf1))THEN
        DEALLOCATE(qnf1,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGXFS: DE-ALLOCATION FAILS FOR qnf1'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NSTS2/
      IF(ALLOCATED(NADS2))THEN
        DEALLOCATE(NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGXFS: DE-ALLOCATION FAILS FOR NADS2,NSTJ2...'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/DMQSSS/
      IF(ALLOCATED(DSSS))THEN
        DEALLOCATE(DSSS,MSSS,QSSS,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGXFS: DE-ALLOCATION FAILS FOR DSSS,MSSS,QSSS'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
      if(btimex)then
        call nrb_time(timef)
        times=timef-time0
!
!        if(abs(modd).le.1)then
!
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Ending proc',iam,' for algxfs:'           !par&
!par     &             ,' time=',nint(times),'sec'                  !par&
!par     &               ,nint(times/60),'min'                      !par
!par          call flush(iw)                                        !par
!par        else                                                    !par
        write(iw,*)'Ending algxfs: time=',nint(times),'sec,     ',      &
     &             nint(times/60),'min'
!par        endif                                                   !par
!        endif
      endif
!
!-----------------------------------------------------------------------
!
      RETURN                      !<-------------------           RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(/' ATTENTION: FINE-STRUCTURE COLLISION ALGEBRA IS ',       &
     &       'RESTRICTED BETWEEN TARGET CFS AS SPECIFIED BY KUTSSX=',I4)
10020 FORMAT(/' SLATER STATE INTERACTION STORAGE (MXS2C,MXS2I) ',I8,I6, &
     &       10X,'USED: ',I8,I6)
10030 FORMAT(I9,I5,2I4,2I5,I9,I6)
10040 FORMAT(' SR.ALGXFS: FAILURE - CASE SKIPPED')
10050 FORMAT(I6,7X,4I5,I7)
10060 FORMAT(I9,I5,2I4,2I5,I9,I6,6(I6,F9.4))
10070 FORMAT(I9,I5,2I4,2I5,I9,I6,6(I6,F9.4)/(47X,6(I6,F9.4)))
10080 FORMAT(' *** STORAGE MAYBE EXCEEDED IN SR.RESX2: INCREASE  MXRSS')
10090 FORMAT(' *** STORAGE MAYBE EXCEEDED IN SR.RESX2: INCREASE  MAXMI')
10100 FORMAT(' *** STORAGE EXCEEDED IN SR.RESX1: INCREASE  MXS2C')
10110 FORMAT(' *** STORAGE EXCEEDED IN SR.RESX1: INCREASE  MXS2I')
10120 FORMAT(/' REFERENCE LIST OF MAGNETIC INTEGRALS N AND V',          &
     &       '  (EXCHANGE LAMBDA = LBD + INT(J))'/' INDEX',5X,          &
     &       'N(    A    B    C    D   2LBD+200)',7X,'INDEX',2X,        &
     &       'V(    A    B    C    D   2LBD+100)')
10130 FORMAT(51X,I6,4X,4I5,I7)
10140 FORMAT(//'  ALGEBRA OF THE MUTUAL SPIN-ORBIT (A), SPIN-OTHER-',   &
     &       'ORBIT (B) AND SPIN-SPIN (C) INTERACTIONS:',10X,'KUTSSX =',&
     &       I3,A1)
10150 FORMAT(I9,I5,2I4,2I5,I9,I6,'  STORAGE RESTRICTIONS FOR ',         &
     &       '(MXADJ,MAXJG,MXSYJ,MXSYJ,MAXDK,MAXDK,MXRSS,MAXMI)'/7X,    &
     &       'NP',2X,'SYJ',2X,'SY',1X,'SYP',3X,'CH',2X,'CHP',7X,'CN',3X,&
     &       'IND',6(3X,'I(Y)  X(A-D)'))
10160 FORMAT('SR.ALGXFS: ALLOCATION INCREASES NUMBER OF FS MATRIX',     &
     &       ' ELEMENTS IADJ =',I10,' .GT. MXAJS=',I10)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE ALGXFS
!
!                             *******************
!
      SUBROUTINE ALGXLS(MAM,NAM,QLMC,QBML,QBMS,JYI,JYF,MAXEL1)
!
!-----------------------------------------------------------------------
!
!  SR.ALGXLS CALCULATES EIE 2-BODY NFS COLLISION ALGEBRA IN LS-COUPLING.
!    IT HAS SIMILARITIES WITH WE'S COLALG (OF COURSE).
!
!  IT IS CALLED BY:
!    SR.ALGX
!
!  IT CALLS:
!    SR.DIMUSE
!    SR.DISKDC
!    SR.FLGLX0
!    SR.FLGLX1
!    SR.FLGLX2
!    SR.FLGLX3
!    SR.NRB_TIME
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!    FN.VCC
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam                            !par
!
      USE COMMON_ALGEB,  ONLY: MPRINT
      USE COMMON_ALGEB,  ONLY: MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD     &
     &                        ,KFBUFF
!!      COMMON /BASIC/NF,KF,KG,J1,J2,J1P,J2P,ND1,NDP1,LI,LF,NGAP
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,J1=>IBSK4,J2=>IBSK5            &
     &              ,J1P=>IBSK6,J2P=>IBSK7,ND1=>IBSK8,NDP1=>IBSK9       &
     &              ,LI=>IBSK10,LF=>IBSK11,IBSK12=>IBSK12
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DC,     ONLY: BFAST,DC,IDC
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL,NAD,IRLAST,IWORD         &
     &                        ,MAXRK0,MAXRL0
      USE COMMON_DXRL,   ONLY: IRK,IRK0,IOS,IOS0
      USE COMMON_DXRLS,  ONLY: DRKS,DEKS,QRLS,NRKS,BFALLS               &
     &                        ,MXRKS0,MXRLS0
      USE COMMON_DXRLS,  ONLY: IRKS,IRKS0,IRLS,IRLS0
      USE COMMON_MINIM,  ONLY: BECOR
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_NSTS,   ONLY: NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT
      USE COMMON_QTG,    ONLY: MTGD,NXLL,NTT,NTG,JTGD,QTGS,QTGL,QTGD    &
     &                        ,NFI,NFK,NFQ
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      use common_misc,   only: ione1,ione0
      use common_misc,   only: iw,iwp,btime,btimex
!
      USE COMMON_NRBBBB, ONLY: BXIST0,BXIST1
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,INAST0=>NASTB                            &
     &                        ,INASTJ0=>NASTJB,LFACT,JFACT              &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDW1, ONLY: MXORB,ma0,mb0
      USE COMMON_NRBDW2, ONLY: LCONDW,MTS,MTSP,MTL,MTLP,MTP,LCONDWJ,MTJ &
     &                        ,LVMIN,LVMAX
      USE COMMON_NRBDW3, ONLY: DVC12,ICLRR,BLX,BEQUALM
      USE COMMON_NRBDW4, ONLY: DSPECE,INDEX,JNDEX,NSPECE,NENERG
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBDWX, ONLY: LLCH,ITARG,NCHG,INASTX,NCHMX
      USE COMMON_NRBFL0, ONLY: KINTI,KINTF,KEN2,KPTCFM,KINT,MPOINT      &
     &                        ,MXSTX0
      USE COMMON_NRBGCF, ONLY: KGSL,KGCF,NKSL
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBIAD, ONLY: IADD
      USE COMMON_NRBKUT, ONLY: KCUTX,LSKUT,NASTK
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBORB, ONLY: IEQ
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M5)
      PARAMETER (TTYNY=TYNY/D1P3)
!
      INTEGER(SP) SA,SAP
!
      DIMENSION MAM(*),NAM(*)
      DIMENSION QLMC(MAXEL1,*),QBML(*),JYI(*),QBMS(*),JYF(*)            &
     &         ,nej(2),mej(2)
!
      ALLOCATABLE :: BXIST2(:,:)
!
!-----------------------------------------------------------------------
!
! some test set-up switches that user joe should not need to touch.
!
! if elastic is dropped here then it has an effect on inelastic
! transitions between terms of same symmetry because they are mixed
!
!old  ione0=0                                    !=0 retain elastic here
!
! if bcor then we have algebraic correlation, and we know how ordered
!
!      bcor=kmax*kcut.ne.kcut*kcut
!
! if becor then we have correlation by energy, and we know not where, so
!
      beqgrpl0=.not.becor                       !false for full li=lf mx
!
! if only algebraic then can reduce memory requirement  NAD(NCOR)
!
!      bcorr=bcor.and..not.becor.and.kcutx.ge.0
!
!-----------------------------------------------------------------------
!
      if(btimex)then
!        if(abs(modd).le.1)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Starting proc',iam,' for algxls'          !par
!par        else                                                    !par
        write(iw,*)'Starting algxls'
!par        endif                                                   !par
!        endif
        call nrb_time(timei)
        time0=timei
      endif
!
! INITIALIZATIONS
!
      BFAST=DC(0).LT.DZERO                 !ELSE OPT MEMORY
!
      IF(KUTDSK.LT.KMAX)THEN
        IEND=MTGD                                            !FOR DISKDC
        MTGD1=MTGD+1
!TEST CALL DISKDC(IUD,IONE,IZERO,IZERO,IZERO,IZERO,IZERO)!REPOINT
      ENDIF
!
      KOLDOO=KUTOOX
      BKUTOO=KUTOOX.NE.0
!      BDLBD=ABS(MODD).LT.2.OR.BKUTOO
!
      BLP=MPRINT.GT.0
!
      NSS=JYF(KMAX)
!
      NF1=NF+1
!      KSP=NF1-(NF1/2)*2                    !TEST ONLY
!
!OLD      INASTX=KF                                      !SYMLS TRANSFER
!OLD      NCHMX=KG                                       !  "       "
!
      IF(MAXLT.LT.0)THEN
        MTLO1=-1
        MTLO2=-1
      ELSE
        MTLO1=MAX(MAXLX,IONE,MINLT-1)
        MTLO1=2*MTLO1+2                         !SCALE FROM ONE L PER PI
        MTLO2=MTLO1+2
      ENDIF
!
! SET POINTERS TO ML BOUNDARIES
!
!
! EX-COMMON/NRBFL0/
!
      IXD02=QCL0/2
      IXD03=IXD02+1
      IXD19=(KMAX*(KMAX+1))/2
!
      IXSTX=MAX(MXSTX0,MXSTX)                      !RESET
      ALLOCATE(KINTI(IXSTX),KINTF(IXSTX),KEN2(IXSTX),                   &
     &         KPTCFM(-IXD02:IXD03,-IXD02:IXD03,0:IXD19),               &
     &         MPOINT(-IXD02:IXD03,KMAX),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGXLS: ALLOCATION FAILS FOR KPTCFM,MPOINT ETC.'
        NF=0
        GO TO 700
      ENDIF
!
      DO K=1,KMAX
        J=JYI(K)
        ML0=QBML(J)
        ML=ML0/2
        J=J-1
        DO M=IXD03,ML,-1
          MPOINT(M,K)=J
        ENDDO
        DO J=JYI(K),JYF(K)
          ML=QBML(J)
          IF(ML.LT.ML0)THEN
            ML0=ML0/2
            ML1=1+ML/2
            DO M=ML0,ML1,-1
              MPOINT(M,K)=J-1
            ENDDO
            ML0=ML
          ENDIF
        ENDDO
        ML=ML/2
        MPOINT(ML,K)=JYF(K)
        ML=ML-1
        DO M=ML,-IXD02,-1
          MPOINT(M,K)=JYF(K)
        ENDDO
      ENDDO
!
! SET-UP POINTERS TO SLATER-STATE INTERACTIONS
!
      KK=0
      KINT=0
      KPTCFM(IXD03,IXD02,1)=0
!
      DO KF=1,KMAX
        DO KG=1,KF
          KK=KK+1
!
          IF(BXIST0(KG,KF))THEN
            CALL FLGLX0(KK,QLMC,MAXEL1)
            IF(NF.LE.0)GO TO 700
          ELSE
            DO M=IXD02,-IXD02,-1
              DO MP=IXD02,-IXD02,-1
                KPTCFM(MP,M,KK)=KINT
              ENDDO
            ENDDO
          ENDIF
!
!          write(mw0,*)'*** kg, kf, kint:',kg,kf,kint
!
          IF(KK.GT.1)KPTCFM(IXD03,IXD02,KK)=KPTCFM(-IXD02,-IXD02,KK-1)
!
          MPP=-IXD02
          DO M=IXD02-1,-IXD02,-1
            IF(KF.EQ.KG)MPP=M+1
            KPTCFM(IXD03,M,KK)=KPTCFM(MPP,M+1,KK)
!            kptcfm(ixd03,m,kk)=kptcfm(m,ixd03,kk)
          ENDDO
!
! checks and debug print (remove/comment-out eventually)
!
!          do m=ixd02,-ixd02,-1
!            if(kf.eq.kg)mpp=m
!            do mp=ixd02,mpp,-1
!              do k=kptcfm(mp+1,m,kk)+1,kptcfm(mp,m,kk)
!                if(k.gt.mxstx)stop 'increase mxstx'
!                j=kinti(k)
!                jd=kintf(k)
!                if(qbml(jd).ne.2*mp.or.qbml(j).ne.2*m)then
!                  write(mw6,*)kg,jd,mp,qbml(jd)/2,' cf j ml qbml',
!     &                      kf,j,m,qbml(j)/2,'    kint=',k
!                  stop 'algxls: ml-mismatch'
!               endif
!              enddo
!            enddo
!          enddo
!
        ENDDO
      ENDDO
!
      CALL DIMUSE('MXSTX',KINT)
!
      IF(KINT.GT.IXSTX)THEN                        !SHOULDN'T HAPPEN NOW
        WRITE(MW6,*)'SR:ALGXLS: INCREASE MXSTX TO:',KINT
        WRITE(MW0,*)'INCREASE MXSTX TO:',KINT
        GO TO 600
      ENDIF
!
! EX-COMMON/DXRL/
!
!      IAXRK=MAX(MAXRK0,MAXRK,IAXRK)               !USE LARGEST PREVIOUS
      IAXRK=MAX(MAXRK0,MAXRK)                     !RESET
!      IAXRL=MAX(MAXRL0,MAXRL,IAXRL)               !USE LARGEST PREVIOUS
      IAXRL=MAX(MAXRL0,MAXRL)                     !RESET
      IL=ABS(MAXLT)
!
      ALLOCATE(DRK(IAXRK),QRL(5,IAXRL),NRK(IAXRK),NAD(0:IADD),          &
     &         IRLAST(0:IL),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGXLS: ALLOCATION FAILS FOR  DRK,QRL,NRK,NAD'
        NF=0
        RETURN
      ENDIF
!
      IRLAST=0                                                  !INITIAL
!
! EX-COMMON/NRBNF1/
      IRKO=1
      IF(BKUTOO)IRKO=IAXRK                                        !MXRKO
      ALLOCATE(DEK(IRKO),BFALL(IRKO),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGXLS: ALLOCATION FAILS FOR  DEK, BFALL'
        NF=0
        RETURN
      ENDIF
!
! EX-COMMON/DXRLS/
!
!      IXRKS=MAX(MXRKS0,MXRKS,IXRKS)               !USE LARGEST PREVIOUS
      IXRKS=MAX(MXRKS0,MXRKS)                     !RESET
!      IXRLS=MAX(MXRLS0,MXRLS,IXRLS)               !USE LARGEST PREVIOUS
      IXRLS=MAX(MXRLS0,MXRLS)                     !RESET
!
      IXROS=1
      IF(BKUTOO)IXROS=IXRKS                                       !MXROS
      ALLOCATE(DRKS(IXRKS),DEKS(IXROS),QRLS(5,IXRLS),NRKS(IXRKS),       &
     &         BFALLS(IXROS),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGXLS: ALLOCATION FAILS FOR  DRKS,DEKS,QRLS ETC'
        NF=0
        GO TO 700
      ENDIF
!
! EX-COMMON/NSTS/
!
      IXXXX=MAX(IXRLS,IAXRL)
      IXD27=KMAX*KMAX
      ALLOCATE(NADS(-1:IXD27),NSTJ(IXRKS),NSTJD(IXRKS),IORIG(IXXXX),    &
     &         JORIG(IXRLS),JPLANT(IXRLS),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGXLS: ALLOCATION FAILS FOR NADS,NSTJ,IORIG ETC'
        NF=0
        GO TO 700
      ENDIF
!
! LOCAL
      ALLOCATE(BXIST2(KMAX,KMAX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGXLS: ALLOCATION FAILS FOR BXIST2'
        NF=0
        GO TO 700
      ENDIF
!
!      ALLOCATE(IGRGR(MXORB))
!!
!      DO I=1,MB
!        IGRGR(I)=I                             !FOR BASIS='RLX', UNUSED
!      ENDDO
!
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!
! NOW GENERATE PARTIAL WAVE ALGEBRA, LOOPING OVER INITIAL AND FINAL
! CHANNELS RESOLVED BY CONTINUUM L,S=1/2 COUPLED TO TARGET SYMMETRY
! GROUPS, THEN RESOLVE BY INDIVIDUAL TERMS.
!
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!
      IF(.NOT.BKUTOO)WRITE(MW6,10060)MAXAD,MAXSL,MAXDI,MAXDI,IAXRK,     &
     &                               IAXRL,MXDFS
      IF(BKUTOO)WRITE(MW6,10070)MAXAD,MAXSL,MAXDI,MAXDI,IAXRK,IAXRL,    &
     &                          MXDFS,KUTOOX
!
      JOS=0
      J=IADD                 !NNN
      IF(IADD.GT.MAXAD)THEN
        IF(MAXAD.GT.0)WRITE(MW6,10050)IADD,MAXAD
      ENDIF
!
      JOS=1
      IRK=0
      IRL=0
      NAD(0)=0
      NCOR=0
!
      MXIRKS=0
      MXIRLS=0
      JOSS=1
      NADS(0)=0
!
!-----------------------------------------------------------------------
! LOOP OVER TOTAL SYMMETRIES
!-----------------------------------------------------------------------
!
      DO IX=1,INASTX
!
        IS=LSPI(IX)/10000
        IP=LSPI(IX)-IS*10000
        IL=IP/10
        IP=IP-IL*10
!
        nwt=is
        if(il.gt.maxlx)nwt=-2*is+2
!
!-----------------------------------------------------------------------
!
        if(btimex)then
!par          if(abs(modd).gt.1)then                                !par
!par            if(iam.ge.0)then                                    !par
!par              write(iwp,*)'Starting proc',iam                   !par&
!par     &                  ,'algxls symmetry',ix,':',nwt,il,ip     !par
!par              call flush(iwp)                                   !par
!par            else                                                !par
          write(iw,*)'Starting algxls symmetry',ix,':',nwt,il,ip
!par            endif                                               !par
!par          endif                                                 !par
          time1=dzero
          time2=dzero
          call nrb_time(timei)
          times=timei
        endif
!
!-----------------------------------------------------------------------
!
!                                                                 !ALIGN
        MTS=IS-1
        MTL=IL+IL
        MTP=IP+IP
!
        MTML=MTL               !0                     !TEST ONLY, SLOW!!
        MTMS=MTS               !KSP          !*MUST* ADJUST VCG MS.ge.-1
!
        IF(BKUTOO.AND.IL.GT.MAXLOO)THEN
          KUTOOX=0
          BKUTOO=.FALSE.
        ENDIF
!
!        write(mw0,*)ix,nadg(ix),ncor
        if(ncor.ne.nadg(ix))stop 'ncor.ne.nadg(ix)'    !shouldn't happen
!
        NCN=NCHG(IX)
!
        NCHI=0
        NCHI0=0
!
        DO NC0=1,NCN                     !BEGIN LOOP OVER INITIAL GROUPS
          L1=LLCH(1,NC0,IX)
          L2=LLCH(2,NC0,IX)
          NC=ITARG(NC0,IX)
          MC=NSL(NC)
          SA=QSI(NC)
          LA=QLI(NC)
          MCI=NGRPI(NC)
          ND1=NC
!                                                    !PRE-SELECT CONFIGS
          DO KK=1,KMAX
            BXIST1(KK)=KGSL(KK,NC).GT.0             !CF DOES/NOT CONTRIB
          ENDDO
!
          NCHIP=0
          NCHIP0=0
!
          DO ND0=1,NC0                     !BEGIN LOOP OVER FINAL GROUPS
            L1P=LLCH(1,ND0,IX)
            L2P=LLCH(2,ND0,IX)
            ND=ITARG(ND0,IX)
            MCP=NSL(ND)
            SAP=QSI(ND)
            IF(ABS(SA-SAP).GT.2)GO TO 30                 !unnecessary...
            IF(NMETAG(NC)+NMETAG(ND).EQ.2)GO TO 30
            LAP=QLI(ND)
            MCIP=NGRPI(ND)
            NDP1=ND
!
            BEQGRP=NC.EQ.ND                              !WITHIN A GROUP
!
            DO KF=1,KMAX                                     !INITIALIZE
              IF(BXIST1(KF))THEN
                DO KG=1,KMAX
                  BXIST2(KG,KF)=BXIST0(KG,KF)
                ENDDO
              ELSE
                DO KG=1,KMAX
                  BXIST2(KG,KF)=.FALSE.
                ENDDO
              ENDIF
            ENDDO
!                                                    !PRE-SELECT CONFIGS
            DO KG=1,KMAX
              IF(KGSL(KG,ND).LE.0)THEN              !CF DOES NOT CONTRIB
                DO KF=1,KMAX
                  BXIST2(KG,KF)=.FALSE.
                ENDDO
              ENDIF
            ENDDO
!
!------------------------------------------------------------
!  DETERMINE SLATER STATE INTERACTIONS BETWEEN GROUP CHANNELS
!------------------------------------------------------------
!
            NCHI=NCHI0
            DO LI=L1,L2,4                   !LOOP OVER INITIAL CHANNEL L
!
              lf2=l2p
              if(beqgrp)lf2=li
!
              NCHIP=NCHIP0
              DO LF=L1P,lf2,4                 !LOOP OVER FINAL CHANNEL L
!
                IRKS=0
                IRLS=0
                JPLANT(1)=0
                J1=2
                beqgrpl=beqgrpl0.and.beqgrp.and.li.eq.lf
!
                KK=0
                KG2=KMAX
                DO KF=1,KMAX             !BEGIN LOOP OVER INITIAL CONFGS
!
                  IF(beqgrpl)KG2=KF
                  DO KG=1,KG2              !BEGIN LOOP OVER FINAL CONFGS
                    KK=KK+1
!
                    IF(.NOT.BXIST2(KG,KF))GO TO 24
!
                    BEQCFS=KF.EQ.KG
                    BEQUAL=BEQGRPL.AND.BEQCFS
!test                   bequal=.false.
                    BEQUALM=BEQUAL
!
                    if(kf.ge.kg)then
                      i1=1
                      i2=2
                      K2=(KF*(KF-1))/2+KG
                    else
                      i1=2
                      i2=1
                      K2=(KG*(KG-1))/2+KF
                    endif
!
! FOR BASIS='RLX' - NOT USED SINCE NO ONE-BODY HERE...
!
!                    DO I=MB+1,MXORB
!                      IGRGR(I)=0
!                    ENDDO
!!
!                    DO I=NF,1,-1
!                      II=QCG(I,KF)
!                      DO L=NF,1,-1
!                        JJ=QCG(L,KG)
!                        IF(IEQ(JJ).EQ.IEQ(II))THEN
!                          IF(IGRGR(II).EQ.0)IGRGR(II)=JJ
!                        ENDIF
!                      ENDDO
!                    ENDDO
!
                    IRKS0=IRKS+1
                    IRLS0=IRLS
!
                    ICLRR=1
!
!-------------------------------------------------------------
! NOW LOOP-OVER ALL POSSIBLE ML,MS,ML',MS' THAT FORM MTML,MTMS
! AND PICK-OUT THE CORRESPONDING SLATERSTATES, FOR THE KF,KG.
!-------------------------------------------------------------
!
                    QML=INT(LA,QP)
    2               BLXL1=QML.NE.-INT(LA,QP)
                    ML=MTML-INT(QML,SP)
                    IF(ML.GT.LI)GO TO 22
                    IF(-ML.GT.LI)GO TO 20
                    DVCL1=VCC(LA,LI,MTL,INT(QML,SP),ML,MTML)
!
                    QMS=INT(SA,QP)
    4               BLXS1=QMS.NE.-INT(SA,QP)
                    MS=MTMS-INT(QMS,SP)
                    IF(MS.GT.1)GO TO 20
                    IF(-MS.GT.1)GO TO 18
!
!                   write(mw6,*)sa,'1',mts,qms,ms,mtms,' x  '
!     &                      ,la,li,mtl,qml,ml,mtml
!
                    DVCS1=VCC(SA,IONE,MTS,INT(QMS,SP),MS,MTMS)
                    DVC1=DVCL1*DVCS1
                    IF(ABS(DVC1).LT.TTYNY)GO TO 18
!
!                    write(mw6,*)sa,'1',mts,qms,ms,mtms,' xx '
!     &                       ,la,li,mtl,qml,ml,mtml
!                    write(mw6,*)dvcs1,dvcl1
!
                    QMLP=INT(LAP,QP)
                    IF(BEQUAL)QMLP=QML
    6               BLXL2=QMLP.NE.-INT(LAP,QP)
                    MLP=MTML-INT(QMLP,SP)
                    IF(MLP.GT.LF)GO TO 18
                    IF(-MLP.GT.LF)GO TO 14
                    DVCL2=VCC(LAP,LF,MTL,INT(QMLP,SP),MLP,MTML)
!
                    QMSP=INT(SAP,QP)
                    IF(BEQUAL)QMSP=QMS
    8               BLXS2=QMSP.NE.-INT(SAP,QP)
                    MSP=MTMS-INT(QMSP,SP)
                    IF(MSP.GT.1)GO TO 16
                    IF(-MSP.GT.1)GO TO 14
!
!                    write(mw6,*)sap,'1',mts,qmsp,msp,mtms,' y  '
!     &                       ,lap,lf,mtl,qmlp,mlp,mtml
!
                    DVCS2=VCC(SAP,IONE,MTS,INT(QMSP,SP),MSP,MTMS)
                    DVC2=DVCL2*DVCS2
!
                    DVC12=DVC1*DVC2
                    IF(ABS(DVC12).LT.TYNY)GO TO 14
                    IF(BEQUAL)THEN
                      IF(QMS.NE.QMSP)DVC12=DVC12+DVC12
                      IF(QML.NE.QMLP)DVC12=DVC12+DVC12
                      BEQUALM=QMS.EQ.QMSP.AND.QML.EQ.QMLP
                    ENDIF
!
!                    write(mw6,*)sap,'1',mts,qmsp,msp,mtms,' yy '
!     &       x               ,lap,lf,mtl,qmlp,mlp,mtml
!                    write(mw6,*)dvcs2,dvcl2
!                    write(mw6,*)dvc12
!
                    BLX=BLXL1.OR.BLXL2.OR.BLXS1.OR.BLXS2
!
! SET POINTERS THAT SELECT SLATER STATE INTERACTIONS FOR QML & QMLP
!
                    if(beqcfs)then
                      if(qmlp.ge.qml)then
                        i1=1
                        i2=2
                      else
                        i1=2
                        i2=1
                      endif
                    endif
!
                    mej(i1)=qml/2
                    mej(i2)=qmlp/2
                    k1=kptcfm(mej(2),mej(1),k2)
                    mej(2)=mej(2)+1
                    k0=kptcfm(mej(2),mej(1),k2)+1
!
! MAM(J2) IS CONSTRUCTED TO SELECT INITIAL & FINAL STATES
!         HAVING THE CORRECT QML, QMS & QMLP,QMSP.
!
! If non-trivial time taken in this search, do a double sweep as in
!   v22.11. The coding below does seem to inhibit compiler optimization.
!
!             write(mw6,*)qml,qms,' ml ms ',qmlp,qmsp,'   k0 k1  ',k0,k1
!
                    J2=1
                    do k=k0,k1
                      nej(i1)=kinti(k)
                      nej(i2)=kintf(k)
                      j=nej(1)
                      jp=nej(2)
                      jj=jp
                      kp=k
   10                 IF(QBMS(J).EQ.QMS.AND.QBMS(JP).EQ.QMSP)THEN
                        J2=J2+1
                        if(j2.gt.nss)then
                          write(mw6,*)'sr.algxls: mxst0/nss exceeded...'
                          write(mw0,*)'sr.algxls: mxst0/nss exceeded...'
                          go to 600
                        endif
                        if(beqcfs.and.qmlp.lt.qml)kp=-kp
                        MAM(J2)=kp
                        QLMC(NF1,J)=INT((MS+1)/2+ML,QP)
                        QLMC(NF1,JP)=INT((MSP+1)/2+MLP,QP)
                      ENDIF
                      if(beqcfs.and.QML.eq.QMLP.and.j.ne.jj)then
                        jp=j
                        j=jj
                        kp=-kp
                        go to 10
                      endif
                    enddo
!
                    IF(J2.LT.J1)GO TO 14
!
!-------------------------------------------------------------
! CALCULATE THE SLATER-STATE INTERACTION BETWEEN CFS KF AND KG
!-------------------------------------------------------------
!
                    if(btimex)call nrb_time(timei)
!
   12               CALL FLGLX1(QLMC,MAM,MAXEL1)
!
                    if(btimex)then
                      call nrb_time(timef)
                      time1=time1+timef-timei
                    endif
!
                    MXIRKS=MAX(MXIRKS,IRKS)
                    MXIRLS=MAX(MXIRLS,IRLS)
                    IF(IRLS.GT.IXRLS)JOSS=-1
                    IF(IRKS.GT.IXRKS)JOSS=0
                    IF(JOSS.LE.0)GO TO 100     !DIMENSION EXCEEDED
                    IF(NF.LE.0)GO TO 600
!
                    IF(ICLRR.EQ.0)GO TO 22
!
!---------------------------------------------------------------
! IF BLX=.TRUE. THE TRANSFORMATION TO THE LS,L'S' REPRESENTATION
!              IS NOT YET COMPLETE.
!---------------------------------------------------------------
!
   14               QMSP=QMSP-QTWO
                    IF(BLXS2)GO TO 8
!
   16               QMLP=QMLP-QTWO
                    IF(BLXL2)GO TO 6
!
   18               QMS=QMS-QTWO
                    IF(BLXS1)GO TO 4
!
   20               QML=QML-QTWO
                    IF(BLXL1)GO TO 2
!
! CLEAR ARRAYS, IF NOT ALREADY DONE
!
   22               IF(ICLRR.NE.0)THEN
                      ICLRR=-ICLRR
                      GO TO 12
                    ENDIF
!
   24               NADS(KK)=IRKS
!
!        write(mw6,*)'***** kf,kg:',kf,kg,nads(kk)-nads(kk-1)
!        do ijk=nads(kk-1)+1,nads(kk)
!          write(mw6,777)nstj(ijk),nstjd(ijk),nrks(ijk),drks(ijk)
!  777  format(3i5,f12.6)
!        enddo
!        do ijk=1,irls
!          write(mw6,778)ijk,(qrls(lll,ijk),lll=1,5)
!  778   format(i4,2x,5i4)
!        enddo
                  ENDDO                                     !END LOOP KG
!
                ENDDO                                       !END LOOP KF
!
!------------------------------------------------------------------
! NOW DETERMINE THE INTERACTION BETWEEN TERMS OF THE LSP GROUPS
!------------------------------------------------------------------
!
                if(btimex)call nrb_time(timei)
!
                istrt0=0
                KF0=0
                DO MD1=1,MC               !BEGIN LOOP OVER INITIAL TERMS
                  J1=MD1+MCI
                  j=jndex(j1)
                  if(kcutx.lt.0)j=abs(j)              !keep corr.-corr.
                  KF=NFK(J1)
!
                  IF(KF.GT.KUTDSK.AND.KF.NE.KF0)THEN
                    NGSYM=KGSL(KF,NC)                     !POS WITHIN CF
                    ISTRT=MTGD1
!
                    CALL DISKDC(IUD,ISTRT,IEND,KF,NGSYM,IONE,IZERO)
!
                    ISTRT0=ISTRT-MTGD1          !ALLOW FOR RE-DEFINITION
                    IF(IEND.LT.0)GO TO 600   !FAIL TO READ REQUIRED DATA
                    KF0=KF
                  ENDIF
!
                  II=NFI(J1)
                  IF(BFAST)THEN
                    J2=JTGD(II)+ISTRT0           !relative start flagged
                    do jj=jyi(kf),jyf(kf)
                      jx=j2+jj
                      if(abs(dc(jx)).lt.tyny)then
                        mam(jj)=0
                      else
                        mam(jj)=jx
                      endif
                    enddo
                  ELSE
                    do jj=jyi(kf),jyf(kf)
                      mam(jj)=0
                    enddo
                    k2=jtgd(ii)                    !absolute end flagged
                    if(k2.lt.0)then                !bdisk first
                      k2=-k2
                      k1=mtgd
                    else
                      k1=jtgd(ii-1)                !start
                      k1=abs(k1)                  !case bdisk second
                    endif
                    k1=k1+1+istrt0
                    k2=k2+istrt0
                    do k12=k1,k2
                      jj=idc(k12)
                      mam(jj)=k12
                    enddo
                  ENDIF
!
                  istrt=0
                  KG0=0
                  DO MDP1=1,MCP             !BEGIN LOOP OVER FINAL TERMS
                    J1P=MDP1+MCIP
                    IF(beqgrpl.and.J1P.GT.J1-ione0)GO TO 28
!
                    jp=jndex(j1p)
                    if(j.lt.0.and.jp.lt.0)then      !neglect corr.-corr.
                      if(becor)then
                        ncor=ncor+1  !needed for bp, but not strictly ls
                        go to 26
                      endif
                      go to 28
                    endif
!
                    KG=NFK(J1P)
!
                    IF(KG.GT.KUTDSK.AND.KG.NE.KG0)THEN
                      LGSYM=KGSL(KG,ND)                   !POS WITHIN CF
                      ISTRT=IEND+1
!
                      CALL DISKDC(IUD,ISTRT,IFIN,KG,LGSYM,IONE,IZERO)
!
                      ISTRT=ISTRT-MTGD1         !ALLOW FOR RE-DEFINITION
                      IF(IFIN.LT.0)GO TO 600 !FAIL TO READ REQUIRED DATA
                      KG0=KG
                    ENDIF
!
                    II=NFI(J1P)
                    IF(BFAST)THEN
                      J2P=JTGD(II)+ISTRT         !relative start flagged
!                      do jj=jyi(kg),jyf(kg)  !slower, no gain in flglx2
!                        if(abs(dc(j2p+jj)).lt.tyny)then
!                          nam(jj)=0
!                        else
!                          nam(jj)=j2p+jj
!                        endif
!                      enddo
                    ELSE
                      do jj=jyi(kg),jyf(kg)
                        nam(jj)=0
                      enddo
                      k2=jtgd(ii)                  !absolute end flagged
                      if(k2.lt.0)then              !bdisk first
                        k2=-k2
                        k1=mtgd
                      else
                        k1=jtgd(ii-1)              !start
                        k1=abs(k1)                !case bdisk second
                      endif
                      k1=k1+1+istrt
                      k2=k2+istrt
                      do k12=k1,k2
                        jj=idc(k12)
                        nam(jj)=k12
                      enddo
                    ENDIF
!
                    IF(beqgrpl)THEN                       !KG.LE.KF HERE
                      KK=(KF*(KF-1))/2+KG
                      if(kf.lt.kg)stop 'algxls: kf.lt.kg?'
                    ELSE
                      KK=KMAX*(KF-1)+KG
                    ENDIF
!
                    CALL FLGLX2(mam,nam,KK)
!
                    NCOR=NCOR+1                        !reverse of above
!
                    IF(IRL.GT.IAXRL)JOS=-1
                    IF(IRK.GT.IAXRK)JOS=0
                    IF(JOS.LE.0)GO TO 100            !DIMENSION EXCEEDED
                    IF(NF.LE.0)GO TO 600
!
                    IF(BLP)THEN                        !.AND.IRK.GE.IRK0
                      NCH=NCHI+MD1
                      NCHP=NCHIP+MDP1
                      IF(IRK-IRK0.NE.5)THEN
                        WRITE(MW6,10020)NCOR,IX,NCH,NCHP,IRK,IRL,       &
     &                                  (NRK(I),DRK(I),I=IRK0,IRK)
                      ELSE
                        WRITE(MW6,10010)NCOR,IX,NCH,NCHP,IRK,IRL,       &
     &                                  (NRK(I),DRK(I),I=IRK0,IRK)
                      ENDIF
                      IF(BKUTOO)WRITE(MW6,10030)                        &
     &                                (NRK(I),DEK(I),I=IRK0,IRK)
                      WRITE(MW6,10020)
                    ENDIF
!
!                  write(72,*)ix,md1,mdp1,j,jp,ncor,irk
   26               NAD(NCOR)=IRK
!
                  ENDDO                     !END LOOP OVER FINAL TERMS
!
   28           ENDDO                       !END LOOP OVER INITIAL TERMS
!
                if(btimex)then
                  call nrb_time(timef)
                  time2=time2+timef-timei
                endif
!
                NCHIP=NCHIP+MCP
              ENDDO                               !END LOOP OVER FINAL L
!
              NCHI=NCHI+MC
            ENDDO                               !END LOOP OVER INITIAL L
!
   30       NCHIP0=NCHIP0+((L2P-L1P)/4+1)*MCP   !=NCHIP
          ENDDO                              !END LOOP OVER FINAL GROUPS
!
          NCHI0=NCHI0+((L2-L1)/4+1)*MC        !=NCHI
        ENDDO                              !END LOOP OVER INITIAL GROUPS
!
        IRLAST(IL)=IRL                         !POINT TO END FOR THIS IL
!
        IF(MTL.LT.MTLO1)NCOR1=NCOR
        IF(MTL.LT.MTLO2)NCOR2=NCOR
!
        KUTOOX=KOLDOO
        BKUTOO=KUTOOX.NE.0
!
!-----------------------------------------------------------------------
!
        if(btimex)then
          call nrb_time(timef)
          times=timef-times
!
!par          if(abs(modd).gt.1)then                                !par
!
!par            if(iam.ge.0)then                                    !par
!
!par!              write(iwp,*)'flglx1',time1                       !par
!par!              write(iwp,*)'flglx2',time2                       !par
!
!par              write(iwp,*)'Ending proc',iam                     !par&
!par     &                 ,'algxls symmetry',ix,':',' nchan=',nchi !par&
!par     &                 ,'time=',nint(times),'sec'               !par
!par            else                                                !par
!
          write(iw,*)'  flglx1 time=',nint(time1),'sec'
          write(iw,*)'  flglx2 time=',nint(time2),'sec'
!
          write(iw,*)'Ending algxls symmetry ',ix,':',' nchan=',nchi,   &
     &               'time=',nint(times),'sec'
!par            endif                                               !par
!par          endif                                                 !par
        endif
!
!-----------------------------------------------------------------------
!
      ENDDO                                    !END LOOP OVER SYMMETRIES
!
!
!-------------------------------------------------------------------
!
! NOW EXCHANGE CAN BE NEGLECTED, ADD-IN HIGHER-L DIRECT VIA SYMMETRY
! RELATION.
!
!-------------------------------------------------------------------
!
      MTLN=0
      IFLAG1=0
      IFLAG2=0
!
      DO IX=INASTX+1,INAST
!
        if(btimex.and.ix.eq.inastx+1)then
!
!par        if(abs(modd).gt.1)then                                  !par
!par          if(iam.ge.0)then                                      !par
!par            write(iw,*)'Proc',iam                               !par&
!par     &                ,'Scaling loop:',mtlo1/2,mtlo2/2          !par
!par          else                                                  !par
!
          write(iw,*)'Scaling loop:',mtlo1/2,mtlo2/2
!par          endif                                                 !par
!par        endif                                                   !par
        endif
!
        IS=LSPI(IX)/10000
        IP=LSPI(IX)-IS*10000
        IL=IP/10
        IP=IP-IL*10
!
        if(btimex)then
!par        if(abs(modd).gt.1)then                                  !par
          write(iw,*)'Symmetry ',ix,':',-2*is+2,il,ip
!par        endif                                                   !par
        endif
!                                                                 !ALIGN
        MTS=IS-1
        MTL=IL+IL
        MTP=IP+IP
!
        IF(BKUTOO.AND.IL.GT.MAXLOO)THEN
          KUTOOX=0
          BKUTOO=.FALSE.
          CALL DIMUSE('MXRKO',IRK)
          CALL DIMUSE('MXRLO',IRL)
          CALL DIMUSE('MXROS',MXIRKS)
        ENDIF
!
        IF(MTL.GT.MTLN)THEN
          MTLN=MTL
          IF(MOD(MTLO1,IFOUR).EQ.MOD(MTL,IFOUR))THEN
            IFLAG1=ABS(IFLAG1)+1
            IFLAG2=-ABS(IFLAG2)
            NCORX=NCOR1
            MTLO=MTLO1
          ELSEif(mod(mtlo2,ifour).eq.mod(mtl,ifour))then
            IFLAG2=ABS(IFLAG2)+1
            IFLAG1=-ABS(IFLAG1)
            NCORX=NCOR2
            MTLO=MTLO2
          else
            stop 'algxls: index error on flgl symmetry set-up'
          ENDIF
        ENDIF
!
!        write(mw0,*)ix,nadg(ix),ncor
        if(ncor.ne.nadg(ix))stop 'nx ncor.ne.nadg(ix)' !shouldn't happen
!
        NCN=NCHG(IX)
!
        NCHI=0
        NCHI0=0
!
        DO NC0=1,NCN                     !BEGIN LOOP OVER INITIAL GROUPS
          L1=LLCH(1,NC0,IX)
          L2=LLCH(2,NC0,IX)
          NC=ITARG(NC0,IX)
          MC=NSL(NC)
          SA=QSI(NC)
          LA=QLI(NC)
          MCI=NGRPI(NC)
!
          NCHIP=0
          NCHIP0=0
!
          DO ND0=1,NC0                     !BEGIN LOOP OVER FINAL GROUPS
            L1P=LLCH(1,ND0,IX)
            L2P=LLCH(2,ND0,IX)
            ND=ITARG(ND0,IX)
            MCP=NSL(ND)
            SAP=QSI(ND)
            IF(ABS(SA-SAP).GT.2)GO TO 40   !unnecessary...
            IF(NMETAG(NC)+NMETAG(ND).EQ.2)GO TO 40
            LAP=QLI(ND)
            MCIP=NGRPI(ND)
            BEQGRP=NC.EQ.ND                             !WITHIN A GROUP
!
            NCHI=NCHI0
            DO LI=L1,L2,4                   !LOOP OVER INITIAL CHANNEL L
!
              lf2=l2p
              if(beqgrp)lf2=li
!
              NCHIP=NCHIP0
              DO LF=L1P,Lf2,4                 !LOOP OVER FINAL CHANNEL L
!
                beqgrpl=beqgrpl0.and.beqgrp.and.li.eq.lf
!
                DO MD1=1,MC               !BEGIN LOOP OVER INITIAL TERMS
                  J1=MD1+MCI
                  j=jndex(j1)
                  if(kcutx.lt.0)j=abs(j)              !keep corr.-corr.
!
                  DO MDP1=1,MCP             !BEGIN LOOP OVER FINAL TERMS
                    J1P=MDP1+MCIP
                    IF(beqgrpl.and.J1P.GT.J1-ione0)GO TO 34
!
                    jp=jndex(j1p)
                    if(j.lt.0.and.jp.lt.0)then      !neglect corr.-corr.
                      if(becor)then
                        ncor=ncor+1
                        ncorx=ncorx+1
                        go to 32
                      endif
                      go to 34
                    endif
!
                    NCORX=NCORX+1
                    if(ncor+1.eq.iadd)ncorx=-ncorx            !flag last
!
                    CALL FLGLX3(IFLAG1,IFLAG2,LA,LAP,LI,LF,MTL,MTLO,    &
     &                          NCORX)
!
                    NCOR=NCOR+1
!
                    IF(IRL.GT.IAXRL)JOS=-1
                    IF(IRK.GT.IAXRK.OR.NCORX.EQ.0)JOS=0
                    IF(JOS.LE.0)GO TO 100            !DIMENSION EXCEEDED
                    IF(NF.LE.0)GO TO 600
!
                    IF(BLP)THEN                        !.AND.IRK.GE.IRK0
                      NCH=NCHI+MD1
                      NCHP=NCHIP+MDP1
                      IF(IRK-IRK0.NE.5)THEN
                        WRITE(MW6,10020)NCOR,IX,NCH,NCHP,IRK,IRL,       &
     &                                  (NRK(I),DRK(I),I=IRK0,IRK)
                      ELSE
                        WRITE(MW6,10010)NCOR,IX,NCH,NCHP,IRK,IRL,       &
     &                                  (NRK(I),DRK(I),I=IRK0,IRK)
                      ENDIF
                      IF(BKUTOO)WRITE(MW6,10030)                        &
     &                                (NRK(I),DEK(I),I=IRK0,IRK)
                      WRITE(MW6,10020)
                    ENDIF
!
!                                   write(72,*)ix,md1,mdp1,j,jp,ncor,irk
   32               NAD(NCOR)=IRK
!
                  ENDDO                       !END LOOP OVER FINAL TERMS
!
   34           ENDDO                       !END LOOP OVER INITIAL TERMS
!
                NCHIP=NCHIP+MCP
              ENDDO                               !END LOOP OVER FINAL L
!
              NCHI=NCHI+MC
            ENDDO                               !END LOOP OVER INITIAL L
!
   40       NCHIP0=NCHIP0+((L2P-L1P)/4+1)*MCP   !=NCHIP
          ENDDO                              !END LOOP OVER FINAL GROUPS
!
          NCHI0=NCHI0+((L2-L1)/4+1)*MC        !=NCHI
        ENDDO                              !END LOOP OVER INITIAL GROUPS
!
        IRLAST(IL)=IRL                         !POINT TO END FOR THIS IL
!
        KUTOOX=KOLDOO
        BKUTOO=KUTOOX.NE.0
!
      ENDDO                                 !END LOOP OVER NX SYMMETRIES
!
! RESULTS
!
      IF(IADD.NE.NCOR)THEN
        WRITE(MW6,*)'SR.ALGXLS: GLOBAL INDEX ERROR:',IADD,NCOR     !test
        GO TO 600
      ENDIF
!      write(mw0,*)iadd
!      IADD=NCOR
!
!
      IF(IRK.NE.0)CALL DIMUSE('MAXRK',IRK)
      IF(IRL.NE.0)CALL DIMUSE('MAXRL',IRL)
      IF(MXIRKS.GT.0)CALL DIMUSE('MXRKS',MXIRKS)
      IF(MXIRLS.GT.0)CALL DIMUSE('MXRLS',MXIRLS)
!
      IF(BKUTOO)THEN
        IF(IRK.NE.0)CALL DIMUSE('MXRKO',IRK)
        IF(IRL.NE.0)CALL DIMUSE('MXRLO',IRL)
        IF(MXIRKS.GT.0)CALL DIMUSE('MXROS',MXIRKS)
      ENDIF
!
  100 IF(.NOT.BLP.OR.JOS.LE.0.OR.JOSS.LE.0)THEN
        WRITE(MW6,10020)NCOR,INAST,NCHMX,NCHMX,IRK,IRL
        IF(JOS.LT.0)GO TO 300
        IF(JOS.EQ.0)GO TO 200
        WRITE(MW6,10040)IXRKS,IXRLS,MXIRKS,MXIRLS,mxstx,kint
        IF(JOSS.LT.0)GO TO 400
        IF(JOSS.EQ.0)GO TO 500
        WRITE(MW6,10160)MPRINT
      ELSE
!
! PRINT SLATER INTEGRAL (ADRESS REFERENCE) LIST
!
        WRITE(MW6,10040)IXRKS,IXRLS,MXIRKS,MXIRLS,mxstx,kint
        IF(IRL.GT.0)THEN
          IF(BKUTOO)WRITE(MW6,10140)KUTOOX
          IF(.NOT.BKUTOO)WRITE(MW6,10130)
          DO L=1,IRL
            WRITE(MW6,10150)L,(QRL(I,L),I=1,5)
          ENDDO
        ENDIF
      ENDIF
!
      GO TO 700                                                  !RETURN
!
!     E R R O R   M E S S A G E S
!
  200 WRITE(MW6,10080)
      IF(IRL.LE.IAXRL)GO TO 600
  300 WRITE(MW6,10110)
  400 WRITE(MW6,10120)
      GO TO 600
  500 WRITE(MW6,10090)
!
  600 WRITE(MW6,10100)
      NF=-1                                                       !ABORT
!
  700 CONTINUE
!
! IF ACTUAL USAGE IS SUFFICIENTLY SMALLER THAN *INITIAL* ALLOCATION,
! THEN REDUCE USAGE TO ACTUAL - FOR SMALL CASES ON SMALL MEMORY MACHINES
!
      IXXX=(4*MAXRL)/5
      IF(IRL.LT.IXXX)THEN
!
!       WRITE(MW6,*)'*** ALGXLS: decreasing MAXRL from ',IAXRL,' to: '
!                 ,IRL
!       WRITE(MW0,*)'*** ALGXLS: decreasing MAXRL from ',IAXRL,' to: '
!                 ,IRL
!
        CALL RE_ALLOC2(QRL,IONE,IFIVE,IONE,IAXRL,IFIVE,IRL,IERR)
!
        IAXRL=IRL
!
      ENDIF
!
      IXXX=(4*MAXRK)/5
      IF(IRK.LT.IXXX)THEN
!
!       WRITE(MW6,*)'*** ALGXLS: decreasing MAXRK from ',IAXRK,' to: '
!                 ,IRK
!       WRITE(MW0,*)'*** ALGXLS: decreasing MAXRK from ',IAXRK,' to: '
!                 ,IRK
!
        CALL RE_ALLOC(DRK,IONE,IAXRK,IRK,IERR)
        IF(BKUTOO)THEN
          CALL RE_ALLOC(DEK,IONE,IAXRK,IRK,IERR)           !KEEP IN SYNC
          CALL RE_ALLOC(BFALL,IONE,IAXRK,IRK,IERR)         !KEEP IN SYNC
        ENDIF
!
        CALL RE_ALLOC(NRK,IONE,IAXRK,IRK,IERR)
!
        IAXRK=IRK
!
      ENDIF
!
! LOCAL
      IF(ALLOCATED(BXIST2))THEN
        DEALLOCATE(BXIST2,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGXLS: DE-ALLOCATION FAILS FOR BXIST2'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(NADS))THEN
        DEALLOCATE(NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGXLS: DE-ALLOCATION FAILS FOR NADS,NSTJ, ETC'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(DRKS))THEN
        DEALLOCATE(DRKS,DEKS,QRLS,NRKS,BFALLS,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'ALGXLS: DE-ALLOCATION FAILS FOR DRKS,DEKS, ETC'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
      if(btimex)then
        call nrb_time(timef)
        times=timef-time0
!
!        if(abs(modd).le.1)then
!
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Ending proc',iam,' for algxls:'           !par&
!par     &             ,' time=',nint(times),'sec'                  !par&
!par     &               ,nint(times/60),'min'                      !par
!par          call flush(iw)                                        !par
!par        else                                                    !par
        write(iw,*)'Ending algxls: time=',nint(times),'sec,     ',      &
     &             nint(times/60),'min'
!par        endif                                                   !par
!        endif
      endif
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(I8,I3,2I5,I8,I5,6(I6,F11.6))
10020 FORMAT(I8,I3,2I5,I8,I5,6(I6,F11.6)/(34X,6(I6,F11.6)))
10030 FORMAT((34X,6(I6,F11.6)))
10040 FORMAT(/' SLATER STATE INTERACTION STORAGE (MXRKS,MXRLS) ',I8,I6, &
     &       10X,'USED: ',I8,I6/34X,'(MXSTX)',7X,I8,16X,'USED: ',I8)
10050 FORMAT('SR.ALGXLS: ALLOCATION INCREASES NUMBER OF LS MATRIX',     &
     &       ' ELEMENTS IADD =',I10,' .GT. MAXAD =',I10)
10060 FORMAT(//'  SLATER COEFFICIENTS  F(A,...)  FOR CONSTRUCTING  ',   &
     &       '( CH !  H  ! CHP ) = SUM( F(A,...) * R(A,...) )'/I8,I3,   &
     &       2I5,I8,I5,' STORAGE RESTRICTIONS FOR ',                    &
     &       '(MAXAD,MAXSL,MAXDI,MAXDI,MAXRK,MAXRL), MXDFS=',           &
     &       I3/'    NCYC SY   CH  CHP     MNF  MNR',                   &
     &       6(3X,'I(R)  F(A,...)'))
10070 FORMAT(//'  SLATER COEFFICIENTS  F(A,...)  FOR CONSTRUCTING  ',   &
     &       '( CH !  H  ! CHP ) = SUM( F(A,...) * R(A,...) )'/I8,I3,   &
     &       2I5,I8,I5,' STORAGE RESTRICTIONS FOR ',                    &
     &       '(MAXAD,MAXSL,MAXDI,MAXDI,MAXRK,MAXRL), MXDFS=',I3,5X,     &
     &       '***** KUTOOX=',I2,                                        &
     &       ' *****'/'    NCYC SY   CH  CHP     MNF  MNR',             &
     &       6(3X,'I(R)  F(A,...)'))
10080 FORMAT(/' SR.ALGXLS: *MAXRK TOO SMALL, ARRAYS DRK AND NRK ')
10090 FORMAT(/' SR.ALGXLS: *MXRKS TOO SMALL, ARRAYS DRKS AND NRKS ')
10100 FORMAT(' SR.ALGXLS: FAILURE - CASE SKIPPED')
10110 FORMAT(/' SR.ALGXLS: *MAXRL TOO SMALL, ARRAYS DRL AND QRL')
10120 FORMAT(/' SR.ALGXLS: *MXRLS TOO SMALL, ARRAYS DRLS AND QRLS')
10130 FORMAT(/' I(R)  R(  A,  B,   C,  D,  2LBD )=SLATER-INTEGRALS ',   &
     &       ' REFERENCE LIST  (EXCHANGE LAMBDA = LBD + LTOT)')
10140 FORMAT(//' I(R)  R(  A,  B,   C,  D,  2LBD )=SLATER-INTEGRALS',   &
     &     ' AND ETA( A, B, C, D, 2LBD) REFERENCE LIST (LBDX=LBD+LTOT),'&
     &     ,' KUTOOX=',I2)
10150 FORMAT(I5,2X,2(I5,I4),I7,F13.5,2F19.5,6X,2I4,5X,'E',I1,I6)
10160 FORMAT(/' *** PRINTOUT OF COEFFICIENTS SUPPRESSED - MPRINT',      &
     &       '(MODULO 5)=',I2/)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE ALGXLS
!
!                             *******************
!
      FUNCTION ARGAM(EL,A)
!
!-----------------------------------------------------------------------
!
!  BADNELL & BURGESS D.A.M.T.P. CAMBRIDGE
!
!  FN.ARGAM CALCULATES ARGGAMMA(EL+1+I*A),
!  WHERE EL+1 IS NOT LESS THAN ZERO
!
!  IT IS CALLED BY:
!    SR.ASSX
!    FN.FDIP2
!    SR.PHASEX
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (D21=21)
      PARAMETER (D210=210)
      PARAMETER (D250=250)
      PARAMETER (D2520=2520)
      PARAMETER (D35=35)
      PARAMETER (D45=45)
      PARAMETER (D63=63)
      PARAMETER (D105=105)
      PARAMETER (D315=315)
!
!-----------------------------------------------------------------------
!
      F=ABS(A)
      F=D250*F**DQUART-A*A
      J1=0
      C=EL+DONE
      D=C*C
      Z=DZERO
!
      IF(D.LT.F)THEN
        F=SQRT(F)
        J1=INT(F-C+DONE,SP)
!
        DO J=1,J1
          D=J-1
          D=C+D
          D=A/D
          D1=ABS(D)
          IF(D1.LT.D1M1)THEN
            D1=D*D
            D2=-D35*D1+D45
            D2=-D1*D2+D63
            D2=-D1*D2+D105
            D1=D-D*D1*D2/D315
          ELSE
            D1=ATAN(D)
          ENDIF
          Z=Z+D1
        ENDDO
      ENDIF
!
      D=J1
      D=C+D
      D0=D*D
      U=A*A
      D1=DONE/(D0+U)
      D2=D1*D1
      D3=DTEN*D0*D0-D20*D0*U+DTWO*U*U
      D3=D3*D2-D21*D0+DSEVEN*U
      D3=D3*D2+D210
      D1=A*D3*D1/D2520
!
      ARGAM=-Z+DHALF*A*LOG(D0+U)+(D-DHALF)*ATAN(A/D)-A-D1
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION ARGAM
!
!                             *******************
!
      SUBROUTINE ASS2PX(X1,H,X,F0,F1,P0,P1,G0,G1,EI0,EJ0,CI0,CJ0,QI,QJ  &
     &,UI,UJ,Z0,NI,REM)
!
!-----------------------------------------------------------------------
!
!  BADNELL AND BURGESS D.A.M.T.P. CAMBRIDGE
!
!  SR.ASS2PX CALCS LONG RANGE INTEGRAL OUT TO POINT WHERE CAN USE AMP.-
!  PHASE METHOD IN SR.ASSX. MODIFIED VERSION OF A. BURGESS'S SR.ASS2.
!  THIS VERSION EVALUATES INTEGRAL G*P WHERE P IS THE DERIVATIVE OF F.
!
!  IT IS CALLED BY:
!    SR.RK4PI
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
      REAL(WP) QI,QJ
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (D5M4=DFIVE*D1M4)
!
!-----------------------------------------------------------------------
!
      TKIJ=ABS(SQRT(EI0)-SQRT(EJ0))
      TEST=(DONE-Z0)*D5M4
      T=DONE
      IF(NI.LE.-1)T=D100
      IF(TKIJ.LT.TEST/T)TKIJ=D1P6
!OLD      TEST=TEST*DTEN
      IF(TKIJ.LT.TEST)TKIJ=TEST
!
      if(-z0.lt.d5m4)then
        eztst=d100
      elseif(ei0/z0**2.lt.d5m4)then
        eztst=-d5m4*z0
      else
        eztst=-ei0/z0
      endif
!
      HH=H*H
      H1=HH/DTWELV
      REM=DZERO
      X=X1
      A3=P1*G1*X**NI
!
      IF(BREL)THEN
        EI=EI0+DQUART*DALF*EI0*EI0
        EJ=EJ0+DQUART*DALF*EJ0*EJ0
        ZI=Z0+DHALF*DALF*Z0*EI0
        ZJ=Z0+DHALF*DALF*Z0*EJ0
        CI=CI0-DALF*Z0*Z0
        CJ=CJ0-DALF*Z0*Z0
! CHANGE NORM BACK TO THAT OF ORIGINAL EQUATION/SOLUTION: 1+(E+V)*D4
! (LIKELY OVER-KILL SINCE UNAFFECTED BY A CONSTANT FACTOR, ONLY ANY
!  REMAINING ASYMPTOTIC R-DEPENDENCE - SET BNORM=.TRUE. TO TEST.)
        BNORM=.FALSE.                           !.TRUE.        !TEST
        IF(BNORM)THEN
          D4=DQUART*DALF
          Z2=Z0+Z0
          T0=DONE/(X-H)
          TF0=DONE+D4*(EI0-Z2*T0)
          TG0=DONE+D4*(EJ0-Z2*T0)
          TF0=SQRT(TF0)
          TG0=SQRT(TG0)
          F0=F0/TF0
          P0=P0/TF0                                  !NEGLECT F0
          G0=G0/TG0
          T1=DONE/X
          TF1=DONE+D4*(EI0-Z2*T1)
          TG1=DONE+D4*(EJ0-Z2*T1)
          TF1=SQRT(TF1)
          TG1=SQRT(TG1)
          F1=F1/TF1
          P1=P1/TF1
          G1=G1/TG1
        ENDIF
      ELSE
        D4=DQUART*DALF                 !JUST SUPPRESS NOT INIT. WARNINGS
        Z2=Z0+Z0                       !JUST SUPPRESS NOT INIT. WARNINGS
        EI=EI0
        EJ=EJ0
        ZI=Z0
        ZJ=Z0
        CI=CI0
        CJ=CJ0
        BNORM=.FALSE.
      ENDIF
!
      ZI2=ZI+ZI
      ZJ2=ZJ+ZJ
      CI2=CI+CI
      CJ2=CJ+CJ
!
      T=DONE/(X-H)
      VI=EI-(ZI2+(CI+(QI+UI*T)*T)*T)*T
      V0=VI
      U0=-F0*(ZI2+CI2*T)*T*T
      VJ=EJ-(ZJ2+(CJ+(QJ+UJ*T)*T)*T)*T
      TI=F0*(DONE+VI*H1)
      TJ=G0*(DONE+VJ*H1)
      T=DONE/X
      VI=EI-(ZI2+(CI+(QI+UI*T)*T)*T)*T
      VP=VI
      UP=-F1*(ZI2+CI2*T)*T*T
      VJ=EJ-(ZJ2+(CJ+(QJ+UJ*T)*T)*T)*T
      TI=(DONE+H1*VI)*F1-TI
      TJ=(DONE+H1*VJ)*G1-TJ
      AI=F1*(DONE+H1*VI)
      AJ=G1*(DONE+H1*VJ)
!
  100 DO I=1,2
        TI=TI-HH*VI*F1
        TJ=TJ-HH*VJ*G1
        AI=AI+TI
        AJ=AJ+TJ
        X=X+H
        T=DONE/X
        VI=EI-(ZI2+(CI+(QI+UI*T)*T)*T)*T
        VJ=EJ-(ZJ2+(CJ+(QJ+UJ*T)*T)*T)*T
        VM=V0
        V0=VP
        VP=VI
        PM=P0
        F0=F1
        P0=P1
        G0=G1
        F1=AI/(DONE+H1*VI)
        UM=U0
        U0=UP
        UP=-F1*(ZI2+CI2*T)*T*T
        TT=(DTWO-DTEN*H1*V0)*P0-(DONE+H1*VM)*PM
        P1=(TT+(UP+DTEN*U0+UM)*H1)/(DONE+H1*VI)
!        AP=P1*(DONE+H1*VI)
        G1=AJ/(DONE+H1*VJ)
      ENDDO
!
      A1=A3
      A2=P0*G0*(X-H)**NI
      A3=P1*G1*X**NI
!
      IF(BNORM)THEN
        T0=DONE/(X-H)
        TF0=DONE+D4*(EI0-Z2*T0)
        TG0=DONE+D4*(EJ0-Z2*T0)
        T1=T
        TF1=DONE+D4*(EI0-Z2*T1)
        TG1=DONE+D4*(EJ0-Z2*T1)
        A2=A2*SQRT(TF0*TG0)
        A3=A3*SQRT(TF1*TG1)
      ENDIF
!
      REM=REM+A1+DFOUR*A2+A3
!                                      CHECK CONVERGENCE
      IF(TKIJ*X.LT.D20)GO TO 100
      IF((VJ*X*X-CJ2).LT.D60)GO TO 100
      IF((VI*X*X-CI2).LT.D60)GO TO 100
      if(eztst*x.lt.dten)go to 100
!
      IF(BNORM)THEN                !CONVERT TO FINAL NORM
        F0=F0*SQRT(TF0)
        P0=P0*SQRT(TF0)
        G0=G0*SQRT(TG0)
        F1=F1*SQRT(TF1)
        P1=P1*SQRT(TF1)
        G1=G1*SQRT(TG1)
      ENDIF
!
      REM=H*REM/DTHREE
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE ASS2PX
!
!                             *******************
!
      SUBROUTINE ASS2X(X1,H,X,F0,F1,G0,G1,EI0,EJ0,CI0,CJ0,QI,QJ,UI,UJ,Z0&
     &,NI,REM)
!
!-----------------------------------------------------------------------
!
!  BADNELL AND BURGESS D.A.M.T.P. CAMBRIDGE
!
!  SR.ASS2X CALCS LONG RANGE INTEGRAL OUT TO POINT WHERE CAN USE AMP-
!  PHASE METHOD IN ASSX. MODIFIED VERSION OF A. BURGESS'S SR.ASS2.
!
!  IT IS CALLED BY:
!    SR.RK4PI
!    SR.RKINT
!    SR.SLATR
!    SR.SLATRI
!    SR.YLAMKX
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
      REAL(WP) QI,QJ
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (D5M4=DFIVE*D1M4)
!
!-----------------------------------------------------------------------
!
      TKIJ=ABS(SQRT(EI0)-SQRT(EJ0))
      TEST=(DONE-Z0)*D5M4
      T=DONE
      IF(NI.LE.-1)T=D100
      IF(TKIJ.LT.TEST/T)TKIJ=D1P6
!OLD      TEST=TEST*DTEN
      IF(TKIJ.LT.TEST)TKIJ=TEST
!
      HH=H*H
      H1=HH/DTWELV
      REM=DZERO
      X=X1
      A3=F1*G1*X**NI
!
      IF(BREL)THEN
        EI=EI0+DQUART*DALF*EI0*EI0
        EJ=EJ0+DQUART*DALF*EJ0*EJ0
        ZI=Z0+DHALF*DALF*Z0*EI0
        ZJ=Z0+DHALF*DALF*Z0*EJ0
        CI=CI0-DALF*Z0*Z0
        CJ=CJ0-DALF*Z0*Z0
! CHANGE NORM BACK TO THAT OF ORIGINAL EQUATION/SOLUTION: 1+(E+V)*D4
! (LIKELY OVER-KILL SINCE UNAFFECTED BY A CONSTANT FACTOR, ONLY ANY
!  REMAINING ASYMPTOTIC R-DEPENDENCE - SET BNORM=.TRUE. TO TEST.)
        BNORM=.FALSE.                           !.TRUE.        !TEST
        IF(BNORM)THEN
          D4=DQUART*DALF
          Z2=Z0+Z0
          T0=DONE/(X-H)
          TF0=DONE+D4*(EI0-Z2*T0)
          TG0=DONE+D4*(EJ0-Z2*T0)
          TF0=SQRT(TF0)
          TG0=SQRT(TG0)
          F0=F0/TF0
          G0=G0/TG0
          T1=DONE/X
          TF1=DONE+D4*(EI0-Z2*T1)
          TG1=DONE+D4*(EJ0-Z2*T1)
          TF1=SQRT(TF1)
          TG1=SQRT(TG1)
          F1=F1/TF1
          G1=G1/TG1
        ENDIF
      ELSE
        D4=DQUART*DALF                 !JUST SUPPRESS NOT INIT. WARNINGS
        Z2=Z0+Z0                       !JUST SUPPRESS NOT INIT. WARNINGS
        EI=EI0
        EJ=EJ0
        ZI=Z0
        ZJ=Z0
        CI=CI0
        CJ=CJ0
        BNORM=.FALSE.
      ENDIF
!
      ZI2=ZI+ZI
      ZJ2=ZJ+ZJ
      CI2=CI+CI
      CJ2=CJ+CJ
!
      T=DONE/(X-H)
      VI=EI-(ZI2+(CI+(QI+UI*T)*T)*T)*T
      VJ=EJ-(ZJ2+(CJ+(QJ+UJ*T)*T)*T)*T
      TI=F0*(DONE+VI*H1)
      TJ=G0*(DONE+VJ*H1)
      T=DONE/X
      VI=EI-(ZI2+(CI+(QI+UI*T)*T)*T)*T
      VJ=EJ-(ZJ2+(CJ+(QJ+UJ*T)*T)*T)*T
      TI=(DONE+H1*VI)*F1-TI
      TJ=(DONE+H1*VJ)*G1-TJ
      AI=F1*(DONE+H1*VI)
      AJ=G1*(DONE+H1*VJ)
!
  100 DO I=1,2
        TI=TI-HH*VI*F1
        TJ=TJ-HH*VJ*G1
        AI=AI+TI
        AJ=AJ+TJ
        X=X+H
        T=DONE/X
        VI=EI-(ZI2+(CI+(QI+UI*T)*T)*T)*T
        VJ=EJ-(ZJ2+(CJ+(QJ+UJ*T)*T)*T)*T
        F0=F1
        G0=G1
        F1=AI/(DONE+H1*VI)
        G1=AJ/(DONE+H1*VJ)
      ENDDO
!
      A1=A3
      A2=F0*G0*(X-H)**NI
      A3=F1*G1*X**NI
!
      IF(BNORM)THEN
        T0=DONE/(X-H)
        TF0=DONE+D4*(EI0-Z2*T0)
        TG0=DONE+D4*(EJ0-Z2*T0)
        T1=T
        TF1=DONE+D4*(EI0-Z2*T1)
        TG1=DONE+D4*(EJ0-Z2*T1)
        A2=A2*SQRT(TF0*TG0)
        A3=A3*SQRT(TF1*TG1)
      ENDIF
!
      REM=REM+A1+DFOUR*A2+A3
!                                      CHECK CONVERGENCE
      IF(TKIJ*X.LT.D20)GO TO 100
      IF((VJ*X*X-CJ2).LT.D60)GO TO 100
      IF((VI*X*X-CI2).LT.D60)GO TO 100
!
      IF(BNORM)THEN                !CONVERT TO FINAL NORM
        F0=F0*SQRT(TF0)
        G0=G0*SQRT(TG0)
        F1=F1*SQRT(TF1)
        G1=G1*SQRT(TG1)
      ENDIF
!
      REM=H*REM/DTHREE
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE ASS2X
!
!                             *******************
!
      SUBROUTINE ASSX(X,N,TI,TJ,EI0,EJ0,Z0,LI0,LJ0,ci,cj,QI,QJ,UI,UJ    &
     &               ,REM)
!
!-----------------------------------------------------------------------
!
!  BADNELL & BURGESS D.A.M.T.P. CAMBRIDGE
!
!  SR.ASSX CALCS LONG-RANGE INTEGRAL FROM X TO INFINITY, N=-(LAMBDA+1).
!
!  CASE EI .NE. EJ AMP. PHASE METHOD.
!  CASE EI=EJ PHI+ AMP. PHASE METHOD, PHI- SUBSTITUTION & SIMPSONS RULE.
!  BASED ON A. BURGESS'S SR.ASS, MODIFIED AND EXTENDED TO TREAT EI=EJ.
!
!  IT IS CALLED BY:
!    SR.RK4PI
!    SR.RKINT
!    SR.SLATR
!    SR.SLATRI
!    SR.YLAMKX
!
!  IT CALLS:
!    SR.DNAMP
!    SR.DNAQ
!    SR.DNPROD
!    FN.PHASEX
!
!-----------------------------------------------------------------------
!
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
      REAL(WP) QI,QJ
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (NMAX=10)
      PARAMETER (N2MX=2*NMAX)
      PARAMETER (MAXNST=65)
!
      PARAMETER (D5M4=DFIVE*D1M4)
      PARAMETER (D32M7=32*D1M7)
!
      DIMENSION AI(N2MX),AJ(N2MX),Y(N2MX),C(N2MX),D(N2MX),E(N2MX)       &
     &,F(N2MX),G(N2MX),H(N2MX),R(MAXNST),P(N2MX),V(N2MX),W(N2MX)
!
!-----------------------------------------------------------------------
!
      IF(LI0+LJ0.EQ.0.OR.LI0.LT.0.OR.LJ0.LT.0)THEN
                                                  !NO LONG RANGE CONTRIB
        REM=DZERO                                 !BAIL OUT
        RETURN
      ENDIF
!
      ELI=LI0
      ELJ=LJ0
!
      TEST=D32M7
      TKIJ=ABS(SQRT(EI0)-SQRT(EJ0))
      PI=ACOS(-DONE)
!
!  for SUN S11 bug: if sub argument is ci0,cj0; ci,cj re-instated at end
!
      ci0=ci
      cj0=cj
!
      IF(BREL)THEN
        EI=EI0+DQUART*DALF*EI0*EI0
        EJ=EJ0+DQUART*DALF*EJ0*EJ0
        ZI=Z0+DHALF*DALF*Z0*EI0
        ZJ=Z0+DHALF*DALF*Z0*EJ0
        CI=CI0-DALF*Z0*Z0
        CJ=CJ0-DALF*Z0*Z0
        LI=-LI0-1
        LJ=-LJ0-1
      ELSE
        EI=EI0
        EJ=EJ0
        ZI=Z0
        ZJ=Z0
        CI=CI0
        CJ=CJ0
        LI=LI0
        LJ=LJ0
      ENDIF
!
      PHI=PHASEX(EI,CI,QI,UI,LI,ZI,X)+TI*PI
      PHJ=PHASEX(EJ,CJ,QJ,UJ,LJ,ZJ,X)+TJ*PI
!
      CALL DNAMP(AI0,AI,EI,CI,QI,UI,ZI,X,NMAX,IFIVE)
      CALL DNAMP(AJ0,AJ,EJ,CJ,QJ,UJ,ZJ,X,NMAX,IFIVE)
!
!      fnorm=ai0*sin(phi)
!      gnorm=aj0*sin(phj)
!
      ETIJ=(TI-TJ)*PI
!
      CALL DNAQ(AI0,AI,Y0,Y,-DTWO,NMAX,ITWO)
      CALL DNAQ(AJ0,AJ,C0,C,-DTWO,NMAX,ITWO)
!
      D0=Y0+C0
      DO I=1,NMAX
        D(I)=Y(I)+C(I)
      ENDDO
!
      CALL DNAQ(D0,D,V0,V,-DONE,NMAX,ITHREE)
      CALL DNPROD(AI0,AI,AJ0,AJ,D0,D,NMAX)
!
      E0=X**N
      DEN=N
      E(1)=DEN*E0/X
      DO I=2,NMAX
        DEN=DEN-DONE
        E(I)=DEN*E(I-1)/X
      ENDDO
!
      CALL DNPROD(D0,D,E0,E,F0,F,NMAX)
      CALL DNPROD(V0,V,F0,F,E0,E,NMAX)
!
      H0=E0
      IMAX=NMAX-1
!
      DO I=1,IMAX
        E0=E(1)
        JMAX=NMAX-I
        DO J=1,JMAX
          E(J)=E(J+1)
        ENDDO
!
        CALL DNPROD(V0,V,E0,E,W0,W,JMAX)
!
        E0=W0
        DO J=1,JMAX
          E(J)=W(J)
        ENDDO
        H(I)=E0
      ENDDO
!
      H(NMAX)=V0*E(1)
      S=-DONE
      U=H0
      R3=U
      T1=ABS(R3)
      I=0
!
  100 I=I+2
      IF(I.GT.NMAX)GO TO 200
      T2=ABS(H(I))
      IF(T2.GT.T1)GO TO 200
      U=S*H(I)
      R3=R3+U
      S=-S
      T1=T2
      GO TO 100
!
  200 R3=R3-DHALF*U
      S=-DONE
      U=H(1)
      R4=U
      T1=ABS(R4)
      I=1
!
  300 I=I+2
      IF(I.GT.NMAX)GO TO 400
      T2=ABS(H(I))
      IF(T2.GT.T1)GO TO 400
      U=S*H(I)
      R4=R4+U
      S=-S
      T1=T2
      GO TO 300
!
  400 R4=R4-DHALF*U
      S2=SIN(PHI+PHJ)
      C2=COS(PHI+PHJ)
      RRP=R3*S2+R4*C2
!
      TEZT=D5M4*(DONE-Z0)
      IF(TKIJ.LT.TEZT)GO TO 1000
      IF(TKIJ.GT.DTEN*TEZT)GO TO 500
      IF(N.LE.-1)GO TO 1000
!
! SLOW CONVERGENCE IN CASE EI-EJ SMALL BUT NON-ZERO, RM BETTER EVALUATED
! IN ASS2. CASE ONLY ARISES IF ONE OF THE INTERPOLATION ENERGIES
! IS CLOSE TO ZERO (=ZERO IS NO PROBLEM). CHOOSING INTERPOLATION
! ENERGY=ZERO OR .GT. 4.E-4*(ASYMPTOTIC CHARGE +1)**2
! IS MUCH MORE FASTER AND ACCURATE.
!
      REM=RRP/DTWO
      GO TO 1200                                                 !RETURN
!
  500 C0=Y0-C0
      DO I=1,NMAX
        C(I)=Y(I)-C(I)
      ENDDO
!
      CALL DNAQ(C0,C,Y0,Y,-DONE,NMAX,ITHREE)
!
      CALL DNPROD(Y0,Y,F0,F,D0,D,NMAX)
!
      G0=D0
      IMAX=NMAX-1
!
      DO I=1,IMAX
        D0=D(1)
        JMAX=NMAX-I
        DO J=1,JMAX
          D(J)=D(J+1)
        ENDDO
!
        CALL DNPROD(Y0,Y,D0,D,P0,P,JMAX)
!
        D0=P0
        DO J=1,JMAX
          D(J)=P(J)
        ENDDO
        G(I)=D0
      ENDDO
!
      G(NMAX)=Y0*D(1)
      S=DONE
      U=-G0
      R1=U
      T1=ABS(R1)
      I=0
!
  600 I=I+2
      IF(I.GT.NMAX)GO TO 700
      T2=ABS(G(I))
      IF(T2.GT.T1)GO TO 700
      U=S*G(I)
      R1=R1+U
      S=-S
      T1=T2
      GO TO 600
!
  700 R1=R1-DHALF*U
      S=DONE
      U=-G(1)
      R2=U
      T1=ABS(R2)
      I=1
!
  800 I=I+2
      IF(I.GT.NMAX)GO TO 900
      T2=ABS(G(I))
      IF(T2.GT.T1)GO TO 900
      U=S*G(I)
      R2=R2+U
      S=-S
      T1=T2
      GO TO 800
!
  900 R2=R2-DHALF*U
      S1=SIN(PHI-PHJ)
      C1=COS(PHI-PHJ)
      RRM=R1*S1+R2*C1
      REM=(RRM+RRP)/DTWO
!
      GO TO 1200                                                 !RETURN
!
! CALCS INTEGRAL [X,INFINITY) OF:
! AMP1(R)*AMP2(R)*COS(PH2-PH1)/(2*R**(LAM+1)
! FOR EI=EJ WITH SUB:
! U=(DARSIN((DTWO/R-Z2L)/DEL)+SI)/DTL (AS DEFINED BELOW.)
!
 1000 TL=(CI+CJ)/DTWO
      DTL=SQRT(TL)
      PH0=(ELJ-ELI)*PI
      Z2=-ZI-ZI
      Z2L=Z2/TL
      DEL=SQRT(DFOUR*EI/TL+Z2L*Z2L)
      SI=PI/DTWO
      IF(EI.GT.DZERO)SI=ASIN(Z2L/DEL)
      N2=N+2
      AM=DZERO
      IF(N2.EQ.0)AM=DONE
!
      IF(EI.GT.D1M10)THEN
        DEI=SQRT(EI)
        ZE=ZI/DEI
        AGI=ARGAM(ELI,ZE)
        AGJ=ARGAM(ELJ,ZE)
        PH0=PH0/DTWO+AGI-AGJ
      ENDIF
!
      RRM=DZERO
      R(1)=AM*COS(PH0+ETIJ)
      CU=EI+Z2/X-TL/(X*X)
      IF(CU.LT.DZERO)GO TO 1300                                   !ABORT
!
      CU=SQRT(CU)
      R(3)=AI0*AJ0*COS(PHI-PHJ)*CU*X**N2
      NST=1
      HT=(ASIN((DTWO/X-Z2L)/DEL)+SI)/DTL
!
 1100 RM0=RRM
      NST=NST+NST
      HT=HT/DTWO
      NS2=NST+2
      RRM=R(1)
      UH=HT
!
      DO K=4,NS2,2
        XH=DTWO/(Z2L+DEL*SIN(UH*DTL-SI))
        CU=EI+Z2/XH-TL/(XH*XH)
        IF(CU.LT.DZERO)GO TO 1300                                 !ABORT
        CU=SQRT(CU)
!
        CALL DNAMP(AI1,AI,EI,CI,QI,UI,ZI,XH,NMAX,IFIVE)
        CALL DNAMP(AJ1,AJ,EJ,CJ,QJ,UJ,ZJ,XH,NMAX,IFIVE)    !EI=EJ, ZI=ZJ
!
        PI1=PHASEX(EI,CI,QI,UI,LI,ZI,XH)
        PJ1=PHASEX(EJ,CJ,QJ,UJ,LJ,ZJ,XH)
!
        R(K-2)=AI1*AJ1*COS(PI1-PJ1+ETIJ)*CU*XH**N2
        UH=UH+HT+HT
      ENDDO
!
      DO K=4,NST,2
        RRM=RRM+DFOUR*R(K-2)+DTWO*R(K-1)
      ENDDO
!
      RRM=(RRM+DFOUR*R(NST)+R(NST+1))*HT/DTHREE
!
      IF(ABS(RRM-RM0).GT.TEST)THEN                !NOT YET CONVERGED
        NSN=NST+NST
        IF(NSN.LT.MAXNST)THEN
          NSN=NSN+3
          DO K=1,NST
            R(NSN-K-K)=R(NS2-K)
          ENDDO
          GO TO 1100                              !NEXT ITERATION
        ENDIF
        IF(ABS(RRM).GT.DONE)WRITE(MW6,10010)TEST,RM0,RRM   !FAILURE
      ENDIF
!
      REM=(RRM+RRP)/DTWO                          !CONVERGED RESULT
!
 1200 CONTINUE
!
      IF(BREL)THEN                                !CORRECT NORMALIZATION
        TF=DONE+DQUART*DALF*EI0   !       -2*z0/x)
        TG=DONE+DQUART*DALF*EJ0   !       -2*z0/x)
        TF=SQRT(TF)
        TG=SQRT(TG)
        REM=REM*TF*TG
!        fnorm=fnorm*tf
!        gnorm=gnorm*tg
      ENDIF
!                                            !re-instate for SUN S11 bug
      ci=ci0
      cj=cj0
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
 1300 REM=RRP/DTWO                                !RM NOT CONVERGED
      GO TO 1200                                                 !RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT('*****WARNING IN SR.ASSX, LONG-RANGE INTEGRALS HAVE FAILED'&
     &       ,'TO CONVERGE TO WITHIN',                                  &
     &       1PE8.1/' FOR EI=EJ, CHECK WHETHER ',                       &
     &       'ACCURACY IS SUFFICIENT, RM0=',E14.7,3X,'RM=',E14.7)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE ASSX
!
!                             *******************
!
      SUBROUTINE BDCF3(F,E,N,L,Z,J0,J1,X)
!
!-----------------------------------------------------------------------
!
!     ALAN BURGESS, D.A.M.T.P. CAMBRIDGE
!
!  SR.BDCF3 EVALUATES A BOUND COULOMB FUNCTION FROM SERIES.
!  IT CAN USE EXTENDED PRECISION LOCALLY, IF XP=16 IN MODULE PRECSN,
!  AND THE F2008 GAMMA INTRINSIC IS AVAILABLE.
!
!  IT IS CALLED BY:
!    SR.RADIAL
!
!  IT CALLS:
!    FN.GAMA
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      REAL(XP) AMAX,A,S,T,TB,TT1,TT2
!      REAL(XP) TT3
!      real(xp) el,gnu,t1,t2,t3,r,th,tk,tt,c
!
! LARGEST EXP ARGUMENT FOR XP=4,8,16
      PARAMETER (DEXP0=D88*(XP/4)**3*(1+nint(real(XP)/16)))
!
! LARGEST GAMMA ARGUMENT FOR XP=4,8,16
      PARAMETER (SUPFCT=33*((XP/4)**2+(XP-4)/4)*(1+9*nint(real(XP)/16)))
!
      DIMENSION F(J1),X(J1)
!
      DATA BFIRST/.TRUE./
!
!-----------------------------------------------------------------------
!
      EL=L
      GNU=-Z/SQRT(-E)
      T1=GNU+EL+DONE
!
! N.B. CANCELLATION ERROR KICKS-IN BEFORE GAMMA ARGUMENT TOO LARGE
!
      IF(T1.GT.SUPFCT)THEN
        IF(XP.NE.WP)THEN
          WRITE(MW6,*)'****ERROR: BDCF3, N+L TOO LARGE FOR GAMMA'
          WRITE(MW0,*)'****ERROR: BDCF3, N+L TOO LARGE FOR GAMMA'
          IF(XP.LT.16)THEN
            WRITE(MW6,*)'****SET XP=16 IN MODULE PRECSN'
            WRITE(MW0,*)'****SET XP=16 IN MODULE PRECSN'
          ENDIF
        ELSE
          WRITE(MW6,*)'****ERROR: BDCF3, N+L TOO LARGE FOR GAMA'
          WRITE(MW0,*)'****ERROR: BDCF3, N+L TOO LARGE FOR GAMA'
          IF(XP.LT.16)THEN
            WRITE(MW6,*)'****SET WP=16 OR USE F2008 GAMMA WITH XP=16...'
            WRITE(MW0,*)'****SET WP=16 OR USE F2008 GAMMA WITH XP=16...'
          ENDIF
        ENDIF
        L=-1
        J=J0
        GO TO 200
      ENDIF
!
      AMAX=HUGE(A)/DTEN**(XP/4)
!
      T2=GNU-EL
      IF(T2.LT.DHALF)T2=DONE                           !SAFE LOWER BOUND
!
      IF(XP.NE.WP)THEN
!
! USE F2008 INTRINSIC, AS GAMA IS WP NOT XP
!
        IF(B_F2008)THEN
!
          WRITE(MW6,*)'****BDCF3: UNCOMMENT F2008 GAMMA FOR XP.NE.WP'
          WRITE(MW0,*)'****BDCF3: UNCOMMENT F2008 GAMMA FOR XP.NE.WP'
          L=-1
          J=J0
          GO TO 200
!
!          TT1=T1
!          TT2=T2
!          TT3=SQRT(GAMMA(TT1))
!          TT3=TT3*SQRT(GAMMA(TT2))
!          TB=SQRT(-Z)/(TT3*GNU)
!
        ELSE
!
          WRITE(MW6,*)'****BDCF3: REQUIRES F2008 GAMMA FOR XP.NE.WP'
          WRITE(MW0,*)'****BDCF3: REQUIRES F2008 GAMMA FOR XP.NE.WP'
          L=-1
          J=J0
          GO TO 200
!
        ENDIF
!
      ELSE
!
! USE GAMA UNTIL CAN BE REPLACED BY F2008 GAMMA
!
        IF(B_F2008.AND.BFIRST)THEN
          WRITE(MW6,*)'****BDCF3: UNCOMMENT TO USE F2008 GAMMA'
          WRITE(MW0,*)'****BDCF3: UNCOMMENT TO USE F2008 GAMMA'
          BFIRST=.FALSE.
        ENDIF
!
        T1=GAMA(T1)
        T2=GAMA(T2)
        T3=SQRT(T1)
        T3=T3*SQRT(T2)
        TB=SQRT(-Z)/(T3*GNU)
!
      ENDIF
!
      ISGN=1-2*mod(abs(N-L+1),ITWO)        !(-1)**(N-L+1)
      TB=TB*ISGN
!
      DO J=J0,J1
!
        R=-Z*X(J)
        T=DTWO*R/GNU
        T3=DONE/T
        S=DONE
        A=DONE
        K0=INT(GNU+GNU+D3HALF+T,SP)        !REAL(T,WP)
        TH=K0
        TH=GNU+GNU+DONE+T-TH
!
        DO K=1,K0
          TK=K
          TT=(TK-GNU+EL)*(GNU-TK+EL+DONE)*T3/TK
          IF(TT.EQ.DZERO)GO TO 50
          IF(ABS(DONE/TT).LT.ABS(A/AMAX))GO TO 100
!          A=A*TT                       !MORE CANCELLATION
          A=A*(TK-GNU+EL)*(GNU-TK+EL+DONE)*T3/TK
          TT1=ABS(A)
          TT2=ABS(S)*T3/TK
!          IF(TT2.GT.TT1*D1P12)GO TO 50
          IF(TT1/TT2.LT.D1M12)GO TO 50
          S=S+A
        ENDDO
!
        T1=(GNU-EL)*(GNU+EL+DONE)
        T2=-DTWO*GNU*T1
        C=-DHALF+                                                       &
     &    D8TH*T3*((DTWO*TH-DONE)+(TH*TH-D3HALF*TH+DQUART-DTWO*T1)*T3)
        S=S+C*A
   50   IF(DHALF*T.GT.DEXP0)GO TO 200
        F(J)=(T**GNU)*S*EXP(-DHALF*T)*TB
!
      ENDDO
!
      RETURN
!
  100 CONTINUE
!
      WRITE(MW6,*)'****ERROR: BDCF3, EXPANSION FAILED TO CONVERGE'
      WRITE(MW0,*)'****ERROR: BDCF3, EXPANSION FAILED TO CONVERGE'
      L=-1
      J=J0
!
  200 DO I=J,J1
        F(I)=DZERO
      ENDDO
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE BDCF3
!
!                             *******************
!
      FUNCTION SBESS(L,X,JSWITCH)
!
!-----------------------------------------------------------------------
!
!  FN.SBESS EVALUATES A SPHERICAL BESSEL FUNCTION OF KIND DEFINED BY:
!
!  JSWITCH= 1 FOR FIRST KIND
!         = 2 FOR SECOND KIND
!         =-1 FOR MODIFIED FIRST KIND
!         =-2 FOR MODIFIED SECOND KIND
!         =-3 FOR MODIFIED THIRD KIND
!
!  L=ORDER
!  X=ARGUEMENT
!  SBESS=_L(X) SAID BESSEL.
!
!  IT IS CALLED BY:
!    SR.RADBP1
!    SR.RK4PI
!    SR.RKINT
!    FN.SBESSP
!    SR.YLAMKR
!
!  IT CALLS:
!    FN.SBESSJ
!    FN.SBESSY
!    FN.SBESSI
!    FN.SBESSN
!    FN.SBESSK
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
      IF(JSWITCH.EQ.1)THEN
        SBESS=SBESSJ(L,X)
      ELSEIF(JSWITCH.EQ.2)THEN
        SBESS=SBESSY(L,X)
      ELSEIF(JSWITCH.EQ.-1)THEN
        SBESS=SBESSI(L,X)
      ELSEIF(JSWITCH.EQ.-2)THEN
        SBESS=SBESSN(L,X)
      ELSEIF(JSWITCH.EQ.-3)THEN
        SBESS=SBESSK(L,X)
      ELSE
        STOP 'BESSEL FUNCTION KIND NOT FOUND'
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION SBESS
!
!                             *******************
!
      FUNCTION SBESSP(L,X,JSWITCH)
!
!-----------------------------------------------------------------------
!
!  FN.SBESSP EVALUATES THE DERIVATIVE OF SPHERICAL BESSEL FUNCTION,
!  USING ABRAMOWITZ & STEGUN 10.1.20 & 10.2.19, DEFINED BY:
!
!  JSWITCH= 1 FOR FIRST KIND
!         = 2 FOR SECOND KIND
!         =-1 FOR MODIFIED FIRST KIND
!         =-2 FOR MODIFIED SECOND KIND
!         =-3 FOR MODIFIED THIRD KIND
!
!  L=ORDER
!  X=ARGUEMENT
!  SBESSP='_L(X) SAID BESSEL.
!
!  IT IS CALLED BY:
!    SR.RK4PI
!    SR.RKINT
!
!  IT CALLS:
!    FN.SBESS
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
      SBESSP=-SIGN(IONE,MOD(JSWITCH,ITHREE))*SBESS(L+1,X,JSWITCH)
!
      IF(L.EQ.0)RETURN
!
      SBESSP=(L*SBESS(L-1,X,JSWITCH)+(L+1)*SBESSP)/(2*L+1)
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION SBESSP
!
!                             *******************
!
      FUNCTION SBESSJ(L,X)
!
!-----------------------------------------------------------------------
!
!  FN.SBESSJ EVALUATES A SPHERICAL BESSEL FUNCTION OF THE FIRST KIND,
!  AS DEFINED BY ABRAMOWITZ & STEGUN 10.1.1
!
!  L=ORDER
!  X=ARGUEMENT
!  SBESSJ=J_L(X) SAID BESSEL.
!
!  IT IS CALLED BY:
!    FN.SBESS
!    FN.SBESSY
!
!  IT CALLS:
!    FN.SBESSY
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (JMAX=6)
!
      parameter (iacc=40)
      parameter (sbigno=d1p10)
      parameter (sbigni=d1m10)
!
!-----------------------------------------------------------------------
!
      IF(L.LT.0)THEN
        LP=-L-1
        SBESSJ=SBESSY(LP,X)*(1-2*mod(-L,ITWO))
        GO TO 100
      ENDIF
!
! START WITH POWER SERIES
!
      SBJ=DONE
      SBJ0=DONE
      L2=L+L
      T2=-X*X/2
      DO J=1,JMAX
        SBJ0=SBJ0*T2/(J*(2*(L+J)+1))
        SBJ=SBJ+SBJ0
        IF(ABS(SBJ0).LT.ABS(SBJ)*D1M5)THEN
          IF(L.GT.0)SBJ=SBJ*X**L
          DO I=2,L2,2
            SBJ=SBJ/(I+1)
          ENDDO
          SBESSJ=SBJ
          GO TO 100   !CONVERGED
        ENDIF
!      write(mw6,*)'L=',l,' X=',x
      ENDDO
!
! NOT CONVERGED, LOOK FOR QUICK RETURN (SAFE TO DO SO NOW)
!
      SBESSJ=SIN(X)/X
      IF(L.EQ.0)GO TO 100
!
      SBESSJ0=SBESSJ
      SBESSJ=(SBESSJ0-COS(X))/X
      IF(L.EQ.1)GO TO 100
!
      SBESSJ1=SBESSJ
!
! ELSE USE RECURRENCE RELATION
!
      T=ABS(X)
      N=INT(T,SP)
      N=N+1
!
      IF(N.GT.L)THEN                !RECUR UPWARDS FROM J0 AND J1
!
        DO I=2,L
          SBESSJ2=(2*I-1)*SBESSJ1/X-SBESSJ0
          SBESSJ0=SBESSJ1
          SBESSJ1=SBESSJ2
        ENDDO
!
        SBESSJ=SBESSJ2
!
      ELSE                          !RECUR DOWNWARDS FROM ASYMTOPIA (JM)
!
        t=REAL(iacc*l,WP)
        t=sqrt(t)
        m=2*((l+INT(t,SP))/2)
!        m=2*((l+int(sqrt(float(iacc*l))))/2)
!
        SBNORM0=SBESSJ0
        SBESSJ=DZERO
        SBESSJ2=DZERO
        SBESSJ1=sbigni                !DONE
!
        DO I=m,0,-1
          SBESSJ0=(2*I+3)*SBESSJ1/X-SBESSJ2
          IF(ABS(SBESSJ0).GT.sbigno)THEN
            SBESSJ0=SBESSJ0*sbigni
            SBESSJ1=SBESSJ1*sbigni
            SBESSJ=SBESSJ*sbigni
          ENDIF
          IF(I.EQ.L)SBESSJ=SBESSJ0
          SBESSJ2=SBESSJ1
          SBESSJ1=SBESSJ0
        ENDDO
        SBESSJ=SBESSJ*SBNORM0/SBESSJ0   !NORMALIZE
!
      ENDIF
!
!-----------------------------------------------------------------------
!
  100 RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION SBESSJ
!
!                             *******************
!
      FUNCTION SBESSY(L,X)
!
!-----------------------------------------------------------------------
!
!  FN.SBESSY EVALUATES SPHERICAL BESSEL FUNCTION OF THE SECOND KIND,
!  AS DEFINED BY ABRAMOWITZ & STEGUN 10.1.1
!
!  L=ORDER
!  X=ARGUEMENT
!  SBESSY=Y_L(X) SAID BESSEL.
!
!  IT IS CALLED BY:
!    FN.SBESS
!    FN.SBESSJ
!
!  IT CALLS:
!    FN.SBESSJ
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (XMIN=D1M300)
      PARAMETER (TYMAX=D1P300)
!
      PARAMETER (NMAX=6)
!
!-----------------------------------------------------------------------
!
      IF(L.LT.0)THEN
        LP=-L-1
        SBESSY=SBESSJ(LP,X)*(1-2*mod(LP,ITWO))
        GO TO 100
      ENDIF
!
! CHECK X NOT TOO SMALL
!
      IF(ABS(X)**(L+1).LT.XMIN)THEN
        SBESSY=TYMAX
        GO TO 100
      ENDIF
!
! START WITH POWER SERIES
!
      SBY=DONE
      SBY0=DONE
      L2=L+L
      T2=-X*X/2
      DO N=1,NMAX
        SBY0=-SBY0*T2/(N*(2*(L-N)+1))
        SBY=SBY+SBY0
        IF(ABS(SBY0).LT.ABS(SBY)*D1M5)THEN
          SBY=-SBY/X**(L+1)
          DO I=2,L2,2
            SBY=SBY*(I-1)
          ENDDO
          SBESSY=SBY
          GO TO 100   !CONVERGED
        ENDIF
      ENDDO
!
! NOT CONVERGED, LOOK FOR QUICK RETURN (SAFE TO DO SO NOW)
!
      SBESSY=-COS(X)/X
      IF(L.EQ.0)GO TO 100
!
      SBESSY0=SBESSY
      SBESSY=(SBESSY0-SIN(X))/X
      IF(L.EQ.1)GO TO 100
!
! ELSE USE RECURRENCE RELATION
!
      SBESSY1=SBESSY
      DO I=2,L
        SBESSY2=(2*I-1)*SBESSY1/X-SBESSY0
        SBESSY0=SBESSY1
        SBESSY1=SBESSY2
      ENDDO
!
      SBESSY=SBESSY2
!
!-----------------------------------------------------------------------
!
  100 RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION SBESSY
!
!                             *******************
!
      FUNCTION SBESSI(L,X)
!
!-----------------------------------------------------------------------
!
!  FN.SBESSI EVALUATES MODIFIED SPHERICAL BESSEL FUNCTION OF FIRST KIND,
!  AS DEFINED BY ABRAMOWITZ & STEGUN 10.2.2
!
!  L=ORDER
!  X=ARGUEMENT
!  SBESSI=I_L(X) SAID BESSEL.
!
!  IT IS CALLED BY:
!    FN.SBESS
!    FN.SBESSN
!
!  IT CALLS:
!    FN.SBESSN
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (XMAX=700)
      PARAMETER (TIMAX=D1P300)
!
      PARAMETER (JMAX=6)
!
      parameter (iacc=40)
      parameter (sbigni=d1m10)
!
!-----------------------------------------------------------------------
!
      IF(L.LT.0)THEN
        LP=-L-1
        SBESSI=SBESSN(LP,X)
        GO TO 100
      ENDIF
!
! CHECK X NOT TOO LARGE
!
      IF(ABS(X).GT.XMAX)THEN
        SBESSI=TIMAX
        GO TO 100
      ENDIF
!
! START WITH POWER SERIES
!
      SBI=DONE
      SBI0=DONE
      L2=L+L
      T2=X*X/2
      DO J=1,JMAX
        SBI0=SBI0*T2/(J*(2*(L+J)+1))
        SBI=SBI+SBI0
        IF(ABS(SBI0).LT.ABS(SBI)*D1M5)THEN
          IF(L.GT.0)SBI=SBI*X**L
          DO I=2,L2,2
            SBI=SBI/(I+1)
          ENDDO
          SBESSI=SBI
          GO TO 100   !CONVERGED
        ENDIF
!      write(mw6,*)'L=',l,' X=',x
      ENDDO
!
! NOT CONVERGED, LOOK FOR QUICK RETURN (SAFE TO DO SO NOW)
!
      SBESSI=SINH(X)/X
      IF(L.EQ.0)GO TO 100
!
      SBESSI0=SBESSI
      SBESSI=(-SBESSI0+COSH(X))/X
      IF(L.EQ.1)GO TO 100
!
      SBESSI1=SBESSI
!
! ELSE USE RECURRENCE RELATION
!
      T=ABS(X)
      N=INT(T,SP)
      N=N+1
!
      IF(N.GT.L)THEN                !RECUR UPWARDS FROM I0 AND I1
!
        DO I=2,L
          SBESSI2=-(2*I-1)*SBESSI1/X+SBESSI0
          SBESSI0=SBESSI1
          SBESSI1=SBESSI2
        ENDDO
!
        SBESSI=SBESSI2
!
      ELSE                          !RECUR DOWNWARDS FROM ASYMTOPIA (IM)
!
        t=REAL(iacc*l,WP)
        t=sqrt(t)
        m=2*((l+INT(t,SP))/2)
!        m=2*((l+int(sqrt(float(iacc*l))))/2)
!
        SBNORM0=SBESSI0
        SBESSI=DZERO
        SBESSI2=DZERO
        SBESSI1=sbigni                !DONE
!
        DO I=m,0,-1
          SBESSI0=(2*I+3)*SBESSI1/X+SBESSI2
          IF(I.EQ.L)SBESSI=SBESSI0
          SBESSI2=SBESSI1
          SBESSI1=SBESSI0
        ENDDO
        SBESSI=SBESSI*SBNORM0/SBESSI0   !NORMALIZE
!
      ENDIF
!
!-----------------------------------------------------------------------
!
  100 RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION SBESSI
!
!                             *******************
!
      FUNCTION SBESSN(L,X)
!
!-----------------------------------------------------------------------
!
!  FN.SBESSN EVALUATES MODIFIED SPHERICAL BESSEL FUNCTION OF SECOND KIND
!  AS DEFINED BY ABRAMOWITZ & STEGUN 10.2.3
!
!  L=ORDER
!  X=ARGUEMENT
!  SBESSN=N_L(X) SAID BESSEL.
!
!  IT IS CALLED BY:
!    FN.SBESS
!    FN.SBESSI
!
!  IT CALLS:
!    FN.SBESSI
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (XMAX=700)
      PARAMETER (XMIN=D1M300)
      PARAMETER (TNMAX=D1P300)
!
      PARAMETER (NMAX=6)
!
!-----------------------------------------------------------------------
!
      IF(L.LT.0)THEN
        LP=-L-1
        SBESSN=SBESSI(LP,X)
        GO TO 100
      ENDIF
!
! CHECK X NOT TOO SMALL
!
      IF(ABS(X)**(L+1).LT.XMIN)THEN
        SBESSN=TNMAX
        GO TO 100
      ENDIF
!
! CHECK X NOT TOO LARGE
!
      IF(ABS(X).GT.XMAX)THEN
        SBESSN=TNMAX
        GO TO 100
      ENDIF
!
! START WITH POWER SERIES
!
      SBN=DONE
      SBN0=DONE
      L2=L+L
      T2=X*X/2
      DO N=1,NMAX
        SBN0=-SBN0*T2/(N*(2*(L-N)+1))
        SBN=SBN+SBN0
        IF(ABS(SBN0).LT.ABS(SBN)*D1M5)THEN
          SBN=SBN/X**(L+1)*(1-2*mod(L,ITWO))
          DO I=2,L2,2
            SBN=SBN*(I-1)
          ENDDO
          SBESSN=SBN
          GO TO 100   !CONVERGED
        ENDIF
      ENDDO
!
! NOT CONVERGED, LOOK FOR QUICK RETURN (SAFE TO DO SO NOW)
!
      SBESSN=COSH(X)/X
      IF(L.EQ.0)GO TO 100
!
      SBESSN0=SBESSN
      SBESSN=(-SBESSN0+SINH(X))/X
      IF(L.EQ.1)GO TO 100
!
! ELSE USE RECURRENCE RELATION
!
      SBESSN1=SBESSN
      DO I=2,L
        SBESSN2=-(2*I-1)*SBESSN1/X+SBESSN0
        SBESSN0=SBESSN1
        SBESSN1=SBESSN2
      ENDDO
!
      SBESSN=SBESSN2
!
!-----------------------------------------------------------------------
!
  100 RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION SBESSN
!
!                             *******************
!
      FUNCTION SBESSK(L,X)
!
!-----------------------------------------------------------------------
!
!  FN.SBESSK EVALUATES MODIFIED SPHERICAL BESSEL FUNCTION OF THIRD KIND,
!  AS DEFINED BY ABRAMOWITZ & STEGUN 10.2.4 - OTHERS DIFFER BY 2/PI.
!
!  L=ORDER
!  X=ARGUEMENT
!  SBESSK=K_L(X) SAID BESSEL.
!
!  IT IS CALLED BY:
!    FN.SBESS
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (XMIN=D1M60)
      PARAMETER (TKMAX=D1P300)
!
!-----------------------------------------------------------------------
!
! CHECK X NOT TOO SMALL
!
      IF(ABS(X).LT.XMIN)THEN
        SBESSK=TKMAX
        GO TO 100
      ENDIF
!
! LOOK FOR QUICK RETURN
!
      SBESSK=DHALF*XPI*EXP(-X)/X
      IF(L.EQ.0)GO TO 100
!
      LP=ABS(L)
!
      SBESSK0=SBESSK
      SBESSK=SBESSK0*(DONE+DONE/X)
      IF(LP.EQ.1)GO TO 100
!
! ELSE USE RECURRENCE RELATION
!
      SBESSK1=SBESSK
      DO I=2,LP
        SBESSK2=(2*I-1)*SBESSK1/X+SBESSK0
        IF(ABS(SBESSK2).GT.TKMAX)THEN
          SBESSK=TKMAX
          GO TO 100
        ENDIF
        SBESSK0=SBESSK1
        SBESSK1=SBESSK2
      ENDDO
!
      SBESSK=SBESSK2
!
!-----------------------------------------------------------------------
!
  100 RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION SBESSK
!
!                             *******************
!
      SUBROUTINE BORN(LAM,K1,K2,K3,K4,LL,LIMR,MENGB,MV0,MV1,V0,V1       &
     &               ,XBINT,XOINT,TM2)
!
!-----------------------------------------------------------------------
!
!  ADAPTED SR.BORN FROM ALAN BURGESS, DAMTP CAMBRIDGE:
!
!  COMPUTES THE BORN INTEGRALS SPECIFIED IN THE APPENDIX TO
!  BURGESS, CHIDICHIMO AND TULLY (J.PHYS.B,30,33-57,1997).
!
!  N.B. ID SETS THE MAXIMUM NUMBER OF POINTS USED FOR TABULATION OF
!  RADIAL FUNCTIONS, AND FOR THE INTEGRATIONS OVER R AND OVER K.
!  THE VALUE OF ID MUST BE A POWER OF 2, AND BE AT LEAST 2**M0
!  WHERE M0 IS THE NUMBER OF ROMBERG ITERATIONS.
!
!  IT IS CALLED BY:
!    SR.RKINT
!
!  IT CALLS;
!    SR.NORMS
!    SR.PNL
!    SR.ROMB
!
!-----------------------------------------------------------------------
!
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!      PARAMETER (M0=12)
      PARAMETER (MID=12)         !DO NOT SET LESS THAN M0
      PARAMETER (ID=2**MID)      !N.B. MAXB1 LARGE
!
      PARAMETER (D5M4=DFIVE*D1M4)
!
      DIMENSION LIMR(*),LL(*),XBINT(*),V0(*),V1(*)
!
      ALLOCATABLE :: F1(:),F2(:),F12(:),F34(:),P1(:),P2(:),S3(:)
!
!-----------------------------------------------------------------------
!
      IPS=0
      IF(KCUT.GT.0)THEN
        IF(DADJUS(K1).LT.DZERO)IPS=IPS+1
        IF(DADJUS(K2).LT.DZERO)IPS=IPS+1
        IF(DADJUS(K3).LT.DZERO)IPS=IPS+1
        IF(DADJUS(K4).LT.DZERO)IPS=IPS+1
      ENDIF
!
      IF((IPS.LE.0.OR.IPS.LE.2.AND.LAM.LE.2).AND.                       &
     &   (MENGB.EQ.1.OR.LAM.EQ.0))THEN  !INFINITE ENERGY / OMG TO 4 S.F.
        M0=10
        TOLR=D1M5
      ELSE                                !FINITE ENERGY / OMG TO 3 S.F.
        IF(IPS.LE.2.OR.IPS.LE.4.AND.LAM.EQ.0)THEN
          M0=5
          TOLR=D5M4
        ELSE
          M0=4
          TOLR=D1M3
        ENDIF
      ENDIF
!
!      M0=12
!      TOLR=1.D-7           !HIGH PRECISION CHECK OF BORN INTEGRALS
!
      IF(2**M0.GT.ID)THEN
        WRITE(MW6,*)' *** SR.BORN: ERROR, NOT ENOUGH POINTS FOR ROMBERG'&
     &              ,' ITERATIONS 2**M0 .GT. ID'
        WRITE(MW0,*)' *** SR.BORN: ERROR, NOT ENOUGH POINTS FOR ROMBERG'&
     &              ,' ITERATIONS 2**M0 .GT. ID'
        LAM=-1
        RETURN
      ENDIF
!
! LOCAL
      ALLOCATE(F1(0:ID),F2(0:ID),F12(0:ID),F34(0:ID),P1(0:ID),P2(0:ID), &
     &         S3(0:ID),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.BORN: ALLOCATION FAILS'
        LAM=-1
        RETURN
      ENDIF
!
      BCF=K3.NE.K1.OR.K4.NE.K2
!
      I1=ID
      M=MAX(LIMR(K1),LIMR(K2))
      IF(DX(LIMR(K1)+LIMR(K2)-M)*D1PT5.GT.DX(M))I1=I1/2
      R1=DX(M)
      H1=R1/I1
!
      CALL PNL(I1,H1,LL(K1),DX,DPNL(1,K1),LIMR(K1),F1)
      CALL PNL(I1,H1,LL(K2),DX,DPNL(1,K2),LIMR(K2),F2)
!
      CALL NORMS(I1,H1,LAM,F1,F2,F12,XB11,XB22,XB12,TM12,VM12)
!
      TM2=DZERO
      IF(LAM.EQ.1)TM2=TM12*TM12/DNINE
      IF(BCF)THEN
        I2=ID
        M=MAX(LIMR(K3),LIMR(K4))
        IF(DX(LIMR(K3)+LIMR(K4)-M)*D1PT5.GT.DX(M))I2=I2/2
        R2=DX(M)
        H2=R2/I2
!
        CALL PNL(I2,H2,LL(K3),DX,DPNL(1,K3),LIMR(K3),F1)
        CALL PNL(I2,H2,LL(K4),DX,DPNL(1,K4),LIMR(K4),F2)
!
        CALL NORMS(I2,H2,LAM,F1,F2,F34,XB33,XB44,XB34,TM34,VM34)
!
        IF(LAM.EQ.1)TM2=SQRT(TM2*TM34*TM34/DNINE)
      ELSE
        R2=R1
        I2=I1
        DO I=1,I1
          F34(I)=F12(I)
        ENDDO
        VM34=VM12
      ENDIF
!
      VM=(VM12+VM34)*DHALF
      IF(MENGB.GT.1)THEN                  !FINITE ENERGY CASE
        IE=0
        DO J0=1,MV0
          J11=J0+1
          DO J1=J11,MV1
            IE=IE+1
!
            CALL ROMB(ID,BCF,LAM,R1,I1,F12,R2,I2,F34,VM,V0(J0),V1(J1),  &
     &                M0,F1,F2,S3,P1,P2,XBINT(IE),XOINT,EB,EO,TOLR,TM2)
!
            IF(TOLR.LT.DZERO)THEN
              WRITE(MW6,*)                                              &
     &              ' *** SR.BORN: OVERFLOW ERROR, REDUCE MAX MULTIPOLE'
              WRITE(MW0,*)                                              &
     &              ' *** SR.BORN: OVERFLOW ERROR, REDUCE MAX MULTIPOLE'
              LAM=-1
              RETURN
            ENDIF
!
            IF(LAM.EQ.1)XBINT(IE)=XBINT(IE)                             &
     &                            +TM2*LOG((V0(J0)+VM)/(V1(J1)+VM))
                                                       !OMIT LOG(V1/V0)
!     &      XBINT(IE)+TM2*LOG(V1(J1)*(V0(J0)+VM)/(V0(J0)*(V1(J1)+VM)))
          ENDDO
        ENDDO
      ELSE                              !INFINITE ENERGY CASE
!
        CALL ROMB(ID,BCF,LAM,R1,I1,F12,R2,I2,F34,VM,V0(1),V1(1),M0,F1,  &
     &            F2,S3,P1,P2,XBINT(1),XOINT,EB,EO,TOLR,TM2)
!
      ENDIF
!
      DEALLOCATE(F1,F2,F12,F34,P1,P2,S3,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.BORN: DE-ALLOCATION FAILS'
        LAM=-1
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE BORN
!
!                             *******************
!
      SUBROUTINE BRNINT(BPRNT0,NLAGB,MXNXB,MV0,MV1,DRY,V0,V1,XB,XS      &
     &                 ,DB0,DB1,OMG1,OBO,OMEGA)
!
!-----------------------------------------------------------------------
!
! SR.BRNINT INTERPOLATES BORN OMEGAS.
!
!  IT IS CALLED BY:
!    SR.CARATE
!    SR.DIAGFS
!    SR.DIAGON
!
!  IT CALLS:
!
!  IT CONTAINS:
!    FN.IROW
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION V0(*),V1(*),XB(*),XS(0:*),DB0(*),DB1(*),OMEGA(0:*)      &
     &         ,OBO(*)
!
      DATA BFLAG/.TRUE./
!
!-----------------------------------------------------------------------
!
!      IROW(ILI,ILF,IONE1,NENG)=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE1))/2
!
!-----------------------------------------------------------------------
!
      NPB=NLAGB/2
      MV11=MV1-1
!
      DO NX=1,MXNXB
        XE=SQRT(XB(NX)*DRY)
        TKMIN=XE*(DONE-XS(NX))
        TKMAX=XE*(DONE+XS(NX))
!
! find tkmin interp. points
!
        IF(TKMIN.LT.V0(1))THEN
!            write(mw0,*)'tkmin out of bounds (lower)',tkmin,v0(1)
!test            stop 'tkmin out of bounds (lower)'
          NB01=1
          NB02=NLAGB
          GO TO 50
        ENDIF
        IF(TKMIN.GT.D1PT2*V0(MV0))THEN
          IF(BPRNT0)THEN
            write(mw6,*)'tkmin out of bounds (upper)',tkmin,v0(mv0)
            write(mw6,*)                                                &
     &             'Upper-state above the ionization limit? SET KCUT !!'
            IF(BFLAG)THEN
              write(mw0,*)                                              &
     &             'Upper-state above the ionization limit? SET KCUT !!'
              BFLAG=.FALSE.
            ENDIF
          ENDIF
!old             nlagb=-1
!old             return
!test            stop 'tkmin out of bounds (upper)'
          NB02=MV0
          NB01=NB02-NLAGB+1
          GO TO 50
        ENDIF
!
        DO L=1,MV0
          IF(V0(L).GT.TKMIN)THEN
            NB02=L+NPB-1
            NB01=L-NPB
            IF(NB01.LE.0)THEN
              NB02=NLAGB
              NB01=1
            ELSEIF(NB02.GT.MV0)THEN
              NB02=MV0
              NB01=NB02-NLAGB+1
            ENDIF
            GO TO 50
          ENDIF
        ENDDO
        NB02=MV0
        NB01=NB02-NLAGB+1
! WEIGHTS
   50   DO L=NB01,NB02
          DD0=DONE
          DO M=NB01,NB02
            IF(L.NE.M)THEN
              DD0=DD0*(TKMIN-V0(M))
              DD0=DD0/(V0(L)-V0(M))
            ENDIF
          ENDDO
          DB0(L)=DD0
        ENDDO
!
! find tkmax interp. points
!
        IF(TKMAX.LT.V1(1))THEN
!            write(mw0,*)'tkmax out of bounds (lower)',tkmax,v1(1)
!test            stop 'tkmax out of bounds (lower)'
          NB11=1
          NB12=NLAGB
          GO TO 100
        ENDIF
        DO L=1,MV11
          IF(V1(L).GT.TKMAX)THEN
            NB12=L+NPB-1
            NB11=L-NPB
            IF(NB11.LE.0)THEN
              NB11=1
              NB12=NLAGB
            ELSEIF(NB12.GT.MV11)THEN
              NB12=MV11
              NB11=NB12-(NLAGB-1)+1
            ENDIF
            GO TO 100
          ENDIF
        ENDDO
        IF(TKMAX.GT.D1PT2*V1(MV11))THEN
          IF(BPRNT0)THEN
            write(mw6,*)'tkmax out of bounds (upper)',tkmax,v1(mv11)
            write(mw6,*)'Is this a K-shell excitation?'
          ENDIF
!test            stop 'tkmax out of bounds (upper)'
          NB12=MV1
          NB11=NB12-1
        ELSE
          NB12=MV1
          NB11=NB12-(NLAGB-1)+1
        ENDIF
! WEIGHTS
  100   DO L=NB11,NB12
          DD0=DONE
          DO M=NB11,NB12
            IF(L.NE.M)THEN
              DD0=DD0*(TKMAX-V1(M))
              DD0=DD0/(V1(L)-V1(M))
            ENDIF
          ENDDO
          DB1(L)=DD0
        ENDDO
!
! INTERPOLATE BORN INTEGRAL OVER K_MIN AND K_MAX MOM. TRANSFER LIMITS.
!
        XOBO=DZERO
        DO I0=NB01,NB02
          DO I1=NB11,NB12
            IF(I1.GT.I0)THEN
              IE=IROW(I0,I1,IONE,MV1)
              XOBO=XOBO+DB0(I0)*DB1(I1)*OBO(IE)
            ELSEIF(I1.LT.I0)THEN
              IE=IROW(I1,I0,IONE,MV1)
              XOBO=XOBO-DB0(I0)*DB1(I1)*OBO(IE)
            ENDIF
          ENDDO
        ENDDO
        XOBO=XOBO+OMG1*LOG(TKMAX/TKMIN)   !IF(NGROUP.EQ.1)
        OMEGA(NX)=XOBO          !INTERPOLATED BORN INTGRAL
      ENDDO
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION IROW(ILI,ILF,IONE1,NENG)
!
      INTEGER (SP) ILI,ILF,IONE1,NENG,IROW
!
      IROW=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE1))/2
!
      END FUNCTION IROW
!-----------------------------------------------------------------------
!
      END SUBROUTINE BRNINT
!
!***********************************************************************
!
! BOX FUNCTION GENERATOR PACKAGE (J. BURNS & N. R. BADNELL, UNPUBLISHED)
!
!***********************************************************************
!
      SUBROUTINE BXCUNT(IN_INT,IANSTEPS,DTF,DARFUNC,ISIZE,INODES)
!
!-----------------------------------------------------------------------
!
!  SR.BXCUNT COUNTS THE NUMBER OF NODES TO SEE IF WE HAVE THE REQUIRED
!  ORBITAL.
!
!  IT IS CALLED BY:
!    SR.BXSCHN
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION IANSTEPS(*)
!
      DIMENSION DARFUNC(*)
!
!-----------------------------------------------------------------------
!
      IINDEX=2
      INODES=0
!
      DO II=1,IN_INT
        DO IN=2,IANSTEPS(II)
          IF(IINDEX.GE.(ISIZE-10))THEN
            IF(ABS(DARFUNC(IINDEX)).LT.DTF)THEN
              DF1=DZERO
            ELSE
              DF1=DARFUNC(IINDEX)
            ENDIF
!
            IF(ABS(DARFUNC(IINDEX-1)).LT.DTF)THEN
              DF2=DZERO
            ELSE
              DF2=DARFUNC(IINDEX-1)
            ENDIF
            DM=DF1*DF2
          ELSE
            DM=DARFUNC(IINDEX)*DARFUNC(IINDEX-1)
          ENDIF
!
          IF(DM.LT.DZERO)THEN        !WE FLIPPED SIGN
            INODES=INODES+1
          ENDIF
          IINDEX=IINDEX+1
          IF(IINDEX.GE.ISIZE)GO TO 100
        ENDDO
      ENDDO
!
  100 CONTINUE
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE BXCUNT
!
!                             *******************
!
      SUBROUTINE BXDFKK(DZ,DL,DE,DR,DFKK)
!
!-----------------------------------------------------------------------
!
!  SR.BXDFKK DETERMINES THE KINETIC-PLUS-NUCLEAR OPERATOR (FOR BOX USE).
!
!  IT IS CALLED BY:
!    SR.BXNUMV
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
      DFKK=(-(DL*(DL+DONE)/(DR*DR)))+(DTWO*DZ/DR)+DE
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE BXDFKK
!
!                             *******************
!
      SUBROUTINE BXINFL(IN_INT,IANSTEPS,DZ,DL,DE,DR1,DR2,DAR,IRN)
!
!-----------------------------------------------------------------------
!
!  SR.BXINFL DETERMINES THE INNER POINT OF INFLECTION.
!  IRN IS USED TO RETURN THE INDEX OF THE R VALUE CLOSEST TO BUT
!  NOT GREATER THAN THE POSITION OF THE INNER POINT OF INFLECTION
!
!  IT IS CALLED BY:
!    SR.BXNUMV
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION IANSTEPS(*)
!
      DIMENSION DAR(*)
!
!-----------------------------------------------------------------------
!
      DR1=(-DZ+SQRT(DZ**2+DE*DL*(DL+DONE)))/DE
      DR2=(-DZ-SQRT(DZ**2+DE*DL*(DL+DONE)))/DE
!
      IF(DR1.LT.DZERO)THEN
        DPT_INFL=DR2
      ELSEIF(DR2.LT.DZERO)THEN
        DPT_INFL=DR1
      ELSE
        IF(DR1.LT.DR2)THEN
          DPT_INFL=DR1
        ELSE
          DPT_INFL=DR2
        ENDIF
      ENDIF
!
      IF(DPT_INFL.LT.0)THEN
        DPT_INFL=0
        IN=0
        RETURN
      ENDIF
!
      DPT_INFL=DPT_INFL/DFOUR
      IINDEX=1
!
      DO II=1,IN_INT
        DO IN=1,IANSTEPS(II)
          IF(DAR(IINDEX).GT.DPT_INFL)THEN
            IRN=IINDEX-1
            GO TO 100
          ENDIF
          IINDEX=IINDEX+1
        ENDDO
      ENDDO
!
  100 CONTINUE
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE BXINFL
!
!                             *******************
!
      SUBROUTINE BXINT(IN_INT,IANSTEPS,DASTEPSIZE,IR0,DAF1,DAF2,DSUM)
!
!-----------------------------------------------------------------------
!
!  SR.BXINT USES SIMPSONS RULE TO INTEGRATE THE PRODUCT OF TWO FUNCTIONS
!  ON A RADIAL MESH OF INCREASING STEPSIZE.
!
!  IT IS CALLED BY:
!    SR.BXNORM
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION IANSTEPS(*)
!
      DIMENSION DASTEPSIZE(*),DAF1(*),DAF2(*)
!
!-----------------------------------------------------------------------
!
      IRM=IR0-1
      IINDEX=0
      DSUM=DZERO
      D_TSUM=DZERO
!
      DO II=1,IN_INT
!
        IF(II.NE.1)THEN
          DT=DAF1(IINDEX)*DAF2(IINDEX)        !IFAC=1
          D_TSUM=DT
        ELSE
          D_TSUM=DZERO
        ENDIF
!
        IFAC=ITWO
!
        DO IN=2,IANSTEPS(II)
          IINDEX=IINDEX+1
!
          IF(IFAC.EQ.ITWO)THEN
            IFAC=IFOUR
          ELSE
            IFAC=ITWO
          ENDIF
!
          DT=IFAC*DAF1(IINDEX)*DAF2(IINDEX)
          D_TSUM=D_TSUM+DT
          IF(IINDEX.EQ.IRM)GO TO 50
        ENDDO
!
   50   IINDEX=IINDEX+1
!
        DT=DAF1(IINDEX)*DAF2(IINDEX)          !IFAC=1
        D_TSUM=D_TSUM+DT
!
        DSUM=DSUM+D_TSUM*DASTEPSIZE(II)/DTHREE
!
        IF(IINDEX.EQ.IR0)GO TO 100            !WE ARE DONE
!
      ENDDO
!
!-----------------------------------------------------------------------
!
  100 RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE BXINT
!
!                             *******************
!
      SUBROUTINE BXNORM(IN_INT,IANSTEPS,DASTEPSIZE,IR0,DARFUNC)
!
!-----------------------------------------------------------------------
!
!  SR.BXNORM NORMALIZES BOX FUNCTIONS, TO UNITY.
!
!  IT IS CALLED BY:
!    SR.BXSCHN
!
!  IT CALLS:
!    SR.BXINT
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION IANSTEPS(*)
!
      DIMENSION DASTEPSIZE(*),DARFUNC(*)
!
!-----------------------------------------------------------------------
!
      CALL BXINT(IN_INT,IANSTEPS,DASTEPSIZE,IR0,DARFUNC,DARFUNC,DA)
!
      DA=SQRT(DA)
!
      IINDEX=1
      DO II=1,IN_INT
        DO IN=1,IANSTEPS(II)
          DARFUNC(IINDEX)=DARFUNC(IINDEX)/DA
          IINDEX=IINDEX+1
        ENDDO
      ENDDO
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE BXNORM
!
!                             *******************
!
      SUBROUTINE BXNUMV(IN_INT,IANSTEPS,DASTEPSIZE,ISTOP,DZ,DL,         &
     &                  DE,DARFUNC,DAR)
!
!-----------------------------------------------------------------------
!
!  SR.BXNUMV CARRIES-OUT A NUMEROV INTEGRATION TO DETERMINE BOX ORBITALS
!
!  IT IS CALLED BY:
!    SR.BXSRCH
!
!  IT CALLS:
!    SR.BXDFKK
!    SR.BXINFL
!    SR.BXPWRS
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION IANSTEPS(*)
!
      DIMENSION DASTEPSIZE(*),DARFUNC(*),DAR(*)
!
!-----------------------------------------------------------------------
!
      CALL BXINFL(IN_INT,IANSTEPS,DZ,DL,DE,DR1,DR2,DAR,IRN)
!
      IF((IRN.LE.0).OR.(NINT(DL,SP).EQ.0))IRN=50 !RSET IRN TO SOMETHING
!                                                !SENSIBLE
!
! ***************************
!      FORCE IRN
!      IRN=8
! ***************************
!
!      DARFUNC(0)=DZERO
      DO IN=1,IRN                   !FILL OUT DARFUNC USING POWER SERIES
        CALL BXPWRS(DZ,DL,DE,DAR(IN),I100,DPWRS)
        DARFUNC(IN)=DPWRS
      ENDDO
!
      ISTART_INT=1                         !INITIALISE STARTING INTERVAL
!
      II=1                               !KEEP TRACK OF CURRENT INTERVAL
      ISTART_PT=IRN          !START POINT IS WHERE THE POWER SERIES ENDS
!
!                          THIS LOOP FINDS THE INTERVAL AND THE POSITION
!                       WITHIN IT AT WHICH THE PT OF INFLECTION OCCURS -
!                        THIS WILL BE THE STARTING PT OF THE INTEGRATION
  100 IF(ISTART_PT.GT.IANSTEPS(II))THEN
        ISTART_PT=ISTART_PT-IANSTEPS(II)
        II=II+1
        GO TO 100
      ENDIF
!
      ISTART_INT=II                         !STORE THE STARTING INTERVAL
      IINDEX=IRN                                  !STORE STARTING IINDEX
!
!-----------------------------------------------------------------------
!
      DO II=ISTART_INT,IN_INT           !WE START INTEGRATION FROM WHERE
!
        DHH=DASTEPSIZE(II)**2              !THE POWER SERIES WAS STOPPED
!
        DO IN=ISTART_PT,(IANSTEPS(II)-1)       !CONTINUE THE INTEGRATION
!                                        ! FOR THE REST OF THIS INTERVAL
          IF(IN.EQ.0)THEN
            IM=IINDEX-2
          ELSE
            IM=IINDEX-1
          ENDIF
          IC=IINDEX
          IP=IINDEX+1
!
          CALL BXDFKK(DZ,DL,DE,DAR(IP),DKK_P)
          CALL BXDFKK(DZ,DL,DE,DAR(IC),DKK_C)
          CALL BXDFKK(DZ,DL,DE,DAR(IM),DKK_M)
!
          DARFUNC(IP)=DTWO*(DONE-((DFIVE*DHH)/DTWELV)*DKK_C)*DARFUNC(IC)
          DARFUNC(IP)=DARFUNC(IP)-DARFUNC(IM)*(DONE+(DHH/DTWELV)*DKK_M)
          DARFUNC(IP)=DARFUNC(IP)/(DONE+((DHH/DTWELV)*DKK_P))
!
          IINDEX=IINDEX+1
          IF(IINDEX.GE.ISTOP)GO TO 200
        ENDDO
!
        ISTART_PT=0                   !FOR ALL INTERVALS AFTER THE FIRST
!                                          !(NOT NESSECARILY INTERVAL 1)
!                               !WE SET I3START_PT=0 SO TWO NEW STARTING
!                                  !POINTS ARE TAKING FROM PREV INTERVAL
!
      ENDDO
!
!-----------------------------------------------------------------------
!
  200 RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE BXNUMV
!
!                             *******************
!
      SUBROUTINE BXPWRS(DZ,DL,DE,DR,II,DSUM)
!
!-----------------------------------------------------------------------
!
!  SR.BXPWRS DETERMINES A POWER SERIES OF A FUNCTION OF FORM SUM(CN*R^N)
!  NOTE: SET BB TO TRUE IF YOU WANT THE INTEGRATION TO ASSUME
!  THE INTIAL VALUE AT THE ORIGIN IS ZERO
!
!  IT IS CALLED BY:
!    SR.BXNUMV
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
      DT=D1M40
!
      DC0=DONE
      DC1=-DZ*DC0/(DL+DONE)
!
      DFIRST_R=DR**(NINT(DL,SP)+1)
      DSUM=DC0*DFIRST_R+DC1*DFIRST_R*DR
!
      DCUR_R=DFIRST_R*DR
!
      DCM1=DC1
      DCM2=DC0
!
      DN=DTWO
      BB=.TRUE.
!
  100 CONTINUE
!
      DC=-(DTWO*DZ*DCM1+DE*DCM2)
!                         !DC=DC/((DN+2.0D00)*(DN+(2.0D00*DL)+3.0D00))
      DC=DC/(DN*(DN+DTWO*DL+DONE))
!
      DCUR_R=DCUR_R*DR
      DCUR_TERM=DC*DCUR_R
!
      DSUM=DSUM+DCUR_TERM
!
      DCM2=DCM1
      DCM1=DC
!
      DN=DN+DONE
!
      IF(DN.GT.II)THEN
!
        BB=.FALSE.
!        DNTERMS=DN
      ELSE
        IF(ABS(DCUR_TERM).LT.ABS(DT*DSUM))THEN
          IF(DC.NE.DZERO)THEN
            BB=.FALSE.
!            DNTERMS=DN
          ENDIF
        ENDIF
      ENDIF
!
      IF(BB)GO TO 100            !ELSE WE ARE DONE - DSUM
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE BXPWRS
!
!                             *******************
!
      SUBROUTINE BXSCHN(IN_INT,IANSTEPS,DASTEPSIZE,DZ,                  &
     &                  IN,IL,DE,DARFUNC,DR,IR0,IM0)
!
!-----------------------------------------------------------------------
!
!  SR.BXSCHN IS THE *** MAIN DRIVER FOR BOX ORBITAL GENERATION: ***
!
!  IT SEARCHES FOR THE BOXED STATE WITH Q. NO N,L,Z,E ETC...
!  ADDED DR0 (29_09_04),CAN BE ANYWHERE IN MESH
!
!  IT IS CALLED BY:
!    SR.RADIAL
!
!  IT CALLS:
!    SR.BXCUNT
!    SR.BXNORM
!    SR.BXSRCH
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION IANSTEPS(*)
!
      DIMENSION DASTEPSIZE(*),DARFUNC(*),DR(*)
!
!-----------------------------------------------------------------------
!
      PI=ACOS(-DONE)
!
      IF(DE.GT.DZERO)THEN                                   !CHECK MESH
        DT=SQRT(DE)
        DT=PI/DT
        DT=DT/(DR(IR0)-DR(IR0-1))
        IF(DT.LT.DTWELV)THEN
          WRITE(MW6,*)'*** BXSCHN: INCREASE MSTEP TO:',IM0+1
          WRITE(MW0,*)'*** BXSCHN: RADIAL MESH TOO COARSE'
          IL=-999
          RETURN
        ENDIF
      ENDIF
!
      DT=D1M6                                   !CONVERGE E-ENERGY TO DT
      DTF=D1M9                               !CONVERGE E-FUNCTION TO DTF
!
      DL=IL
      DN=IN
      INODES=IN-IL-1
!
!-----------------------------------------------------------------------
!
      DR0=DR(IR0)
!                                                             !ISIZE=IR0
!
      IF(DE.GT.-D99*DZ**2)THEN
!                      FIND THE FIRST BOXED STATE NEAR THE INITIAL GUESS
        DE0=DE
      ELSE
!                                                  MAKE AN INITIAL GUESS
        IF(IN.GT.2)THEN
          DE0=(PI*DZ*DN**2)/(2*2*DR0)
        ELSE
          DE0=-(DZ**2)/(DN**2)
        ENDIF
!                  DE0=DE0/2.0D00
!
      ENDIF
!
      DDE=ABS(DE0)/D1P2
!
      D_DE_COARSE=DE0/DTEN
!
!                IF(DE0.LT.DONE)D_DE_COARSE=DONE
!
      CALL BXSRCH(IN_INT,IANSTEPS,DASTEPSIZE,DZ,DL,DE0,DE,DDE,DT,DTF,   &
     &            DARFUNC,DR,IR0)
!
      CALL BXCUNT(IN_INT,IANSTEPS,DTF,DARFUNC,IR0,ICNODES)
!
!  DETERMINE WHICH DIRECTION IN ENERGY IT NEEDS TO GO
!  TO FIND THE CORRECT FUNCTION
!
      IF(ICNODES.LT.INODES)THEN      !NEED TO GO UP
        D_DE_COARSE=ABS(D_DE_COARSE)
        DDE=ABS(DDE)
        IDIR=1
      ELSEIF(ICNODES.GT.INODES)THEN  !NEED TO GO DOWN
        D_DE_COARSE=-ABS(D_DE_COARSE)
        DDE=-ABS(DDE)
        IDIR=-1
      ELSE                           !WE ARE DONE
        GO TO 200                    !NORMALIZE
      ENDIF
!
  100 CONTINUE
!
      DE0=DE0+D_DE_COARSE
!
      CALL BXSRCH(IN_INT,IANSTEPS,DASTEPSIZE,DZ,DL,DE0,DE,DDE,DT,DTF,   &
     &            DARFUNC,DR,IR0)
!
      CALL BXCUNT(IN_INT,IANSTEPS,DTF,DARFUNC,IR0,ICNODES)
!
! FIND THAT DIRECTION WE NEED TO GO IN NOW
!
      IF(ICNODES.LT.INODES)THEN
        IF(IDIR.EQ.-1)THEN
          DE0=DE0+ABS(D_DE_COARSE)
          D_DE_COARSE=D_DE_COARSE/DTWO
        ENDIF
        GO TO 100
      ELSEIF(ICNODES.GT.INODES)THEN
        IF(IDIR.EQ.1)THEN
          DE0=DE0-ABS(D_DE_COARSE)
          D_DE_COARSE=D_DE_COARSE/DTWO
        ENDIF
        GO TO 100
      ELSE
!        WE ARE DONE
      ENDIF
!
  200 CALL BXNORM(IN_INT,IANSTEPS,DASTEPSIZE,IR0,DARFUNC)
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE BXSCHN
!
!                             *******************
!
      SUBROUTINE BXSRCH(IN_INT,IANSTEPS,DASTEPSIZE,DZ,DL,DE0,           &
     &                  DE,DDE,DT,DTF,DARFUNC,DR,IR0)
!
!-----------------------------------------------------------------------
!
!  SR.BXSRCH SEARCHES FOR A FUNCTION WHICH IS 0 AT R0.
!
!   E0 IS INTIAL ENERGY
!   DE IS THE ENERGY STEPSIZE
!   T IS THE THRESHOLD VALUE FOR DE
!   ISIZE IS THE ISIZE OF THE R AND RFUNC ARRAY
!
!  IT IS CALLED BY:
!    SR.BXSCHN
!
!  IT CALLS:
!    SR.BXNUMV
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION IANSTEPS(*)
!
      DIMENSION DARFUNC(*),DR(*),DASTEPSIZE(*)
!
!-----------------------------------------------------------------------
!
      DE=DE0
      CALL BXNUMV(IN_INT,IANSTEPS,DASTEPSIZE,IR0,DZ,DL,DE,DARFUNC,DR)
!
      D_DE=DDE
      DS=1
      IF(DARFUNC(IR0).LT.0)DS=-1
!
!      ICNT=0
      ICNT_TOT=0
!
  100 CONTINUE
!
!      ICNT=ICNT+1
      ICNT_TOT=ICNT_TOT+1
!
!      IF(ICNT.GE.1000)THEN
!        ICNT=0
!               PRINT *,"SEARCHING...",ICNT_TOT," : E=",DE," DE=",D_DE
!
!      ENDIF
!
      IF(ICNT_TOT.GE.10000)THEN
        WRITE(MW6,*)"SR.BXSRHC: FAIL TO CONVERGE ENERGY... ITERATIONS=",&
     &              ICNT_TOT," : E=",DE," DE=",D_DE
        STOP "SR.BXSRHC: FAILURE TO CONVERGE ENERGY..."
!        NF=-1                            !SHOULD FOLLOW NORNAL EXIT:TBD
!
      ENDIF
!
      DE=DE+D_DE
!
      CALL BXNUMV(IN_INT,IANSTEPS,DASTEPSIZE,IR0,DZ,DL,DE,DARFUNC,DR)
!
      IF((DARFUNC(IR0)*DS).LT.0)THEN                !WE FLIPPED SIGN
        DE=DE-D_DE
        D_DE=D_DE/DTWO
      ENDIF
!
!       CONVERGE ON E    AND   CONVERGE ON F AS WELL
      IF((ABS(D_DE).GT.DT).OR.(ABS(DARFUNC(IR0)).GT.DTF))GO TO 100
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE BXSRCH
!
!                             *******************
!
      SUBROUTINE CADWX(FRX,PSHFTX,DRLX,MDIM0,MDIM1,MDIM2,MDIM3,MDIM4    &
     &                ,MDIM5)
!
!-----------------------------------------------------------------------
!
!  SR.CADWX CALCULATES EIE 2-BODY NR COLLISION STRENGTHS IN CA-COUPLING
!
!  IT IS CALLED BY:
!    SR.DWX
!
!  IT CALLS:
!    SR.DATE_AND_TIME (SYSTEM)
!    SR.NRB_TIME
!    FN.QBINOM
!    SR.RADCNX
!    SR.SLATRX
!    SR.TOP1
!    SR.TOP2
!    FN.XINT
!
!  IT CONTAINS:
!    FN.IROW
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam,comm_barrier               !par&
!par     &                          ,sp_mpi,izero_mpi               !par
!par      use mpi, only : mpi_real4,mpi_real8,mpi_integer           !par&
!par     &               ,mpi_sum,mpi_comm_world                    !par
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL,NAD,IPLANT_RL,n8
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_MINIM,  ONLY: BECOR
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      use common_misc,   only: badas
      use common_misc,   only: ione1,ione0
      use common_misc,   only: iw,iwp,btime,btimex
!
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,INAST0=>NASTB                            &
     &                        ,INASTJ0=>NASTJB,LFACT,JFACT              &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDW1, ONLY: MXORB,ma0,mb0,MSTAT
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
      USE COMMON_NRBDW4, ONLY: DSPECE,INDEX,JNDEX,NSPECE,NENERG
      USE COMMON_NRBDW5, ONLY: DYY,MENG,NLAG
      USE COMMON_NRBDW6, ONLY: QPOS,QPOS0
      USE COMMON_NRBDW7, ONLY: MNDEX,MRNDX,MTRAN,mlim
      USE COMMON_NRBDW8, ONLY: DYY0,IYY0,MENG0
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBDWX, ONLY: LLCH,ITARG,NCHG
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBIAD, ONLY: IADD
      USE COMMON_NRBKUT, ONLY: KCUTX,LSKUT,NASTK
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBORB, ONLY: IEQ
      USE COMMON_NRBREL, ONLY: BREL
      USE COMMON_NRBRN3, ONLY: MXNXB,MXNXB1
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (MXLEN=200)                                 !CARD LENGTH
!
!par!                                                               !par
!par      integer(sp_mpi) itmp4,ier4,my_mpi_real                    !par
!par!                                                               !par
!par      real(rp) omsend,omrecv                                    !par
!
      REAL(RP) OMEGA,E1M30
      PARAMETER (E1M30=1.E-30_RP)
      PARAMETER (XBTEST=DFIVE)          !APPLY btop ONLY FOR X.GT.XBTEST
!
      INTEGER(SP) QBINOM                       !DO NOT USE SHORT INTEGER
!
      CHARACTER(LEN=3) IEXP,IEXP0,IEXP1
      CHARACTER(LEN=4) CARD4
      CHARACTER(LEN=5) XMANT,XMANT0,XMANT1
      CHARACTER(LEN=8) DATE
      CHARACTER(LEN=15) F767
      CHARACTER(LEN=29) F713
      CHARACTER(LEN=35) F762
      CHARACTER(LEN=44) F761
      CHARACTER(LEN=MXLEN) CARD
!
!
      ALLOCATABLE :: OMEGA(:,:),OMGINF(:),KACT(:,:),KTMP(:)
!par      allocatable :: omsend(:),omrecv(:)                        !par
!
      ALLOCATABLE :: IEXP(:),XMANT(:)
      ALLOCATABLE :: OMP(:),RHO1(:) ,TMP1(:,:),TMP2(:,:)
      ALLOCATABLE :: DWRK(:),IWRK3(:),IWRK4(:)
!
      DIMENSION FRX(MDIM1,MDIM2,MDIM3),PSHFTX(MDIM2,MDIM3),PSHFT0(0:20) &
     &         ,DRLX(MDIM4,MDIM0,0:MDIM5)
      DIMENSION DZLX(1),DXTWOX(1),DETAX(1)   !DUMMY, SUPPRESS COMP WARNS
!
!-----------------------------------------------------------------------
!
!      IROW(ILI,ILF,IONE1,NENG)=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE1))/2
!
!-----------------------------------------------------------------------
!
! flag write of cross sections to adf04ca instead of collision strengths
! - this is for test purposes only.
!
      bcrossx=.false.                !.true.
!
      if(bcrossx)then
!
        write(mw0,*)' *** Attention, adf04ca contains cross sections!'
        write(mw6,*)' *** Attention, adf04ca contains cross sections!'
!
        xconv=done                   !pi*a_0^2
        xconv=xconv*acos(-done)      !a_0^2
        xconv=xconv*28.003D0         !Mbarns
        xconv=xconv*1.D6             !barns
!
      endif
!
! historically (e.g. .le. v29.x) omegas normalized s.t. to convert to
! cross section they are divided by stat.weight of the active pair of
! the lower config of the transition - because ca does not depend on
! spectators. but, this is non-obvious to users (adas) of adf04.
! now (e.g. .ge. v30.x) omegas are normalized s.t. to convert to cross
! section they are divided by the total stat. weight of the lower config
! as is written in the adf04 config/energy list at the topof adf04.
! a side benefit is that these omegas match ls/ic omegas summed over
! all initial & final terms/levels (configuration and spin-orbit mixing
! excepted, of course). if cross sections are output then can use either
!
      bwgttot=.not.bcrossx                !omegas now weighted by config
!
! flag write of "OMEGA" file - this is by final scattered energy and so
! *not* directly usable by R-matrix utility codes such as xtrct/adasexj.
! this is somewhat historic as adasexj *does* read/process dw adf04 file
!
      bomega=.false.
!
! some test set-up switches that user joe should not need to touch.
!
      bht=.false.                  !.true. for bht(1970) test comparison
!
! set (approx) unitarity switch
!
      bunit=.true.
      if(bht)bunit=.false.
!par!                                                               !par
!par      if(rp.eq.4)then                                           !par
!par        my_mpi_real=mpi_real4                                   !par
!par      elseif(rp.eq.8)then                                       !par
!par        my_mpi_real=mpi_real8                                   !par
!par      else                                                      !par
!par        if(iam.eq.0)write(iw,*)'error rp precsion =',rp         !par
!par        go to 5500                                              !par
!par      endif                                                     !par
!
!-----------------------------------------------------------------------
!
      btimep=btimex                                        !for iam.ne.0
      if(btimex)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Starting proc',iam,' for cadwx'           !par
!par        else                                                    !par
        write(iw,*)'Starting cadwx'
!par        endif                                                   !par
        call nrb_time(timei)
        time0=timei
      endif
!
! INITIALIZATIONS
!
      PI=ACOS(-DONE)
      TPI=DTWO*PI
!
      BPRNT2=JPRINT.GE.2                    !FOR DETAILED OMEGA PRINTOUT
      BPRNT3=JPRINT.GE.3                      !FOR DETAILED RHO PRINTOUT
      BPRNT0=JPRINT.NE.-3
      BPRNT1=JPRINT.EQ.1       !PRINT CHANNEL INFO AGAIN
!
      IF(NZION.EQ.MION)THEN
        NZA=0
        DZ2=DONE
      ELSE
        NZA=NZION-MION
        DZ2=NZA*NZA
      ENDIF
!
      LOLD=-1                                          !INITIAL FOR QPOS
      LSTORE=0                                 !TRIVIAL INTEGRAL STORAGE
!
      IF(MAXLT.GE.0)THEN
        IF(LRGLAM.GT.MAXLT)THEN
          WRITE(MW0,*)'*** SR.CADWX: LRGLAM.GT.MAXLT, SO NO TOP-UP'
          LRGLAM=-1
        ELSE
          IF(LRGLAM.EQ.-999)LRGLAM=MAXLT
        ENDIF
        IF(LRGLAM.EQ.0)LRGLAM=-1
      ENDIF
!
      IF(LRGLAM.GE.0)THEN        !SET L WHERE DIPOLE TOP-UP NEEDS CHECKS
        LRGLMN=LRGLAM-QCL0                    !QCL0=2*NXLL - SET IN ALGX
      ELSE
        LRGLMN=1000
      ENDIF
!
      btop=btop.and.lrglam.ge.0
!
! SMALL LOCAL MEMORY
!
      MXD4=MAX(MENG,10_SP)+3
      ALLOCATE(IEXP(0:MXD4),XMANT(0:MXD4))
      ALLOCATE(OMP(MENG),RHO1(MENG),TMP1(MENG,MENG),TMP2(MENG,MENG))
!
! LOOK FOR LAST SPECTROSCOPIC ENERGY
!
!      NSPECL=0
!      DO N=1,NENERG
!        NSPECL=MAX(NSPECL,JNDEX(N))
!      ENDDO
!
! USE ROWWISE TO SIMPLY REDUCE NDIM2 IF NMETA.LT.NSPECE
!
      nmin=min(NMETA,NSPECE)
      NOMWRT=IROW(nmin,NSPECE,ione1,NSPECE)                     !ROWWISE
      NOMWR0=NOMWRT
!test    if(ione1.eq.1)nomwr0=nomwr0+nmin      !incase ione1=0 in carate
!
!
      BTHRSH=LVMAX.GE.0
      IF(BTHRSH)THEN
        MOGGY=LVMAX+1-LVMIN
      ELSE
        MOGGY=MENG0
      ENDIF
!
      ALLOCATE(OMGINF(NOMWR0),OMEGA(MOGGY,NOMWRT),STAT=IERR)
!par!                                                               !par
!par      allocate(omsend(nomwrt),omrecv(nomwrt),stat=ierr)         !par
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CADWX: ALLOCATION FAILS FOR OMEGA'
        NF=0
        GO TO 600
      ENDIF
!
      DO N=1,NOMWRT
        OMGINF(N)=DZERO
        DO M=1,MOGGY
          OMEGA(M,N)=0
        ENDDO
      ENDDO
!
! RECOVER INFINITE ENERGY INFO (ROWWISE)
!
      IF(IUNIT(MRW23).EQ.0)THEN                !ADF04 WILL BE INCOMPLETE
        WRITE(MW6,*)'NO INFINITE ENERGY FILE="OMGINFCA"...'
        WRITE(MW0,*)'NO INFINITE ENERGY FILE ON UNIT=MRW23'
        IF(LRGLAM.GE.0)THEN
          WRITE(MW6,*)'NO INFINITE ENERGY FILE INFO, CANNOT TOP-UP'
          WRITE(MW0,*)'NO INFINITE ENERGY FILE INFO, CANNOT TOP-UP'
          NF=-1
          GO TO 400
        ELSE
          GO TO 100
        ENDIF
      ELSEIF(IUNIT(MRW23).LT.0)THEN
        OPEN(MRW23,FILE='OMGINFCA',STATUS='OLD',ERR=100)
        IUNIT(MRW23)=1
      ELSE                               !SERIAL SHOULD NOT BE HERE
        REWIND(MRW23)                       !BUT PAR ALREADY OPEN
!par        if(iam.eq.0)then                                        !par
        stop 'cadwx: omginfca confusion'
!par        endif                                                   !par
      ENDIF
!
      READ(MRW23,*)NZDUM,MDUM
      READ(MRW23,*)NSPEC0,MENGB,NOMWR0
!
      IF(NSPEC0.NE.NSPECE)THEN                   !SHOULD NOT HAPPEN, NOW
        WRITE(MW6,*)'CADWX: INFINITE ENERGY TARGET MISMATCH',NSPEC0,    &
     &              NSPECE
        WRITE(MW0,*)'CADWX: INFINITE ENERGY TARGET MISMATCH'
        NF=-1
        GO TO 400
      ENDIF
!
      ALLOCATE(DWRK(NSPEC0),IWRK3(NSPEC0),IWRK4(NSPEC0))
!
      READ(MRW23,*)(IWRK3(I),IWRK4(I),I=1,NSPEC0)
      READ(MRW23,10040)(DWRK(I),I=1,NSPEC0)
!
! optionally recover spec energy subset from omginf,
! and retain full-set in denerg back in algx.
!
!      do i=1,nspec0
!        dwrk(i)=dwrk(i)*dz2
!      enddo
!
      iflag=0
      if(nomwrt.ne.nomwr0)then       !should not happen in non-test mode
        if(ione1.eq.0)then                             !elastic in cadwx
          if(nomwrt-nmin.ne.nomwr0)then
            write(mw6,*)'cadwx: infinite energy omega mismatch',nomwrt, &
     &                  nomwr0
            write(mw0,*)'cadwx: infinite energy omega mismatch'
            nf=-1
            go to 400
          else                                   !case ione1=1 in carate
            iflag=1
          endif
        else                                         !inelastic in cadwx
          if(nomwrt+nmin.ne.nomwr0)then
            write(mw6,*)'cadwx: infinite energy omega mismatch',nomwrt, &
     &                  nomwr0
            write(mw0,*)'cadwx: infinite energy omega mismatch'
            nf=-1
            go to 400
          else                                   !case ione1=0 in carate
            iflag=2
          endif
        endif
      endif
!
      F713='(1PE14.8,6E11.3/(14X,6E11.3))'        !SUPPRESS IFORT REMARK
!
      READ(MRW23,F713)EINF,(OMGINF(I),I=1,NOMWR0)
!par!                                                               !par
!par      if(iam.ne.0)then                                          !par
!par        IUNIT(MRW23)=-1                                         !par
!par        CLOSE(MRW23)                                            !par
!par      endif                                                     !par
!
      if(iflag.eq.1)then                          !make room for elastic
        n=nomwrt+1
        nshft=nmin
        do i=nmin,1,-1
          do j=nspec0,i+1,-1
            n=n-1
            omginf(n)=omginf(n-nshft)
          enddo
          n=n-1
          omginf(n)=done                             !flag poss. allowed
          nshft=nshft-1
        enddo
        if(n.ne.1)stop 'iflag=1 nshft error'
      elseif(iflag.eq.2)then                               !drop elastic
        n=0
        nshft=1
        do i=1,nmin
          do j=i+1,nspec0
            n=n+1
            omginf(n)=omginf(n+nshft)
          enddo
          nshft=nshft+1
        enddo
        if(n.ne.nomwrt)stop 'iflag=2 nshft error'
      endif
!
  100 CONTINUE
!
! WRITE-OUT SPEC. TARGET ENERGIES
!
      WRITE(MW6,10210)
      WRITE(MW6,10160)NMETA
!
      DO J=1,NSPECE
        I=INDEX(J)
        WRITE(MW6,10150)J,I,DSPECE(J)
      ENDDO
!
      WRITE(MW6,10220)
!
! RE-FLAG ACTIVE ORBITAL PAIR IN INTERACTING CONFIGS,
! SINCE WE DE-ALLOCATED IT IN SR.ALGX...
!
      ALLOCATE(KACT(KMAX,KMAX),KTMP(NF),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CADWX: ALLOCATION FAILS FOR KACT,KTMP'
        NF=0
        GO TO 500
      ENDIF
!
      DO KF=1,KMAX
        DO KG=1,KF
          KACT(KF,KG)=0
          KACT(KG,KF)=0
          DO I=1,NF
            KTMP(I)=QCG(I,KG)
          ENDDO
          K=0
          DO I=1,NF
            L0=0
            DO L=1,NF
              IF(IEQ(KTMP(L)).EQ.IEQ(QCG(I,KF)))THEN
                KTMP(L)=0
                GO TO 120
              ELSE
                IF(KTMP(L).NE.0.AND.L0.EQ.0)L0=L
              ENDIF
            ENDDO
            K=K+1
            IF(K.GT.1)THEN
              KACT(KF,KG)=-1
              KACT(KG,KF)=-1
              GO TO 150
            ENDIF
            KACT(KF,KG)=QCG(I,KF)
            KACT(KG,KF)=KTMP(L0)
!            write(mw6,*)'kg,kf,kact: ',kg,kf,kact(kg,kf),kact(kf,kg)
!            call flush(mw6)
  120     ENDDO
  150   ENDDO
      ENDDO
!
!-----------------------------------------------------------------------
!
! BEGIN LOOP OVER SCATTERING SYMMETRIES
!
!-----------------------------------------------------------------------
!
      NCOR=0
!
      iwait=0
      wait=done
!
      DO IX=1,INAST
!
        IL=LSPI(IX)
!
        LNEW=IL
!
! SEE IF WE NEED TO UPDATE INTEGRALS & CONTINUUM BASIS
!
        IF(LNEW.NE.LOLD)THEN
!
!-----------------------------------------------------------------------
!
          if(btimex)then
!par            if(iam.ge.0)then                                    !par
!par              write(iwp,*)'Starting proc',iam                   !par&
!par     &                  ,'updating continuum for l=',il         !par
!par              call flush(iwp)                                   !par
!par            else                                                !par
            write(iw,*)                                                 &
     &              'Begin update of continuum basis & integrals for L='&
     &              ,lnew
!par            endif                                               !par
!
            call nrb_time(timei)
            times=timei
          endif
!
!-----------------------------------------------------------------------
!
          lstep=lnew-lold
          if(lstep.gt.1.and.lfact.gt.100.and.lold.gt.0)then
            if(iwait.eq.4)then
              iwait=2
            else
              iwait=4
            endif
            wait=iwait*lstep
            wait=wait/dthree
          endif
!
! UPDATE CONTINUUM BASIS
!
          IF(BTHRSH)LCONDW=-LCONDW                            !FLAG
!
          CALL RADCNX(FRX,PSHFTX,PSHFT0,MDIM1,MDIM2,MDIM3,LNEW,LOLD,    &
     &                LCONDW,MXORB)
!
          IF(NF.LE.0)GO TO 400
!
! UPDATE EXCHANGE MULTIPOLE
!
          LDIFF=LNEW
          IF(LOLD.GE.0)LDIFF=LDIFF-LOLD
          LDIFF=LDIFF+LDIFF
!
          DO I=1,IRL
            IF(QRL(2,I).GT.MXORB)QRL(5,I)=QRL(5,I)+INT(LDIFF,QP) !EXCHNG
          ENDDO
!
! UPDATE SLATER INTEGRALS
!
          IF(BPRNT0)WRITE(MW6,10290)LNEW
!
          DO M=1,MTRAN
            M1=MNDEX(M,1)
            M2=MNDEX(M,2)
            CALL SLATRX(FRX,PSHFTX,MDIM1,MDIM2,MDIM3,DRLX(1,M,LSTORE),  &
     &                  DZLX(1),DXTWOX(1),DETAX(1),M1,M2,LNEW,MXORB)
          ENDDO
!
          LOLD=LNEW
!
!-----------------------------------------------------------------------
!
          if(btimex)then
            call nrb_time(timef)
            times=timef-times
!
!par            if(iam.ge.0)then                                    !par
!par              write(iwp,*)'Ending proc',iam                     !par&
!par     &                  ,'updating continuum'                   !par&
!par     &                 ,' time=',nint(times),'sec'              !par
!par              call flush(iwp)                                   !par
!par            else                                                !par
            write(iw,*)'End update of continuum basis & integrals',     &
     &                 ', time=',nint(times),'sec'
!par            endif                                               !par
          endif
!
!-----------------------------------------------------------------------
!
        ENDIF
!
!
! INITIALIZE FOR L-LOOP
!
        IF(BPRNT1)THEN
          WRITE(MW6,10280)IX
        ELSEIF(BPRNT0)THEN
          WRITE(MW6,10270)IX
        ENDIF
!
        IF(BPRNT2)WRITE(MW6,10230)
!
!-----------------------------------------------------------------------
!
        if(btimex)then
!par          if(iam.ge.0)then                                      !par
!par            write(iwp,*)'Starting proc',iam                     !par&
!par     &                ,'cadwx symmetry',ix,':',il               !par
!par            call flush(iwp)                                     !par
!par          else                                                  !par
          write(iw,*)'Starting cadwx symmetry',ix,': L=',il
!par          endif                                                 !par
!
          call nrb_time(timei)
          times=timei
        endif
!
!-----------------------------------------------------------------------
!
!
! NOW FORM CA INTERACTION
!************************
!
!
        MTL=IL+IL
        LI=MTL                                        !INITIAL CHANNEL L
!
! set position of phase shift for this li.
! only required by elastic case, for diagonal rho.
! n.b. recall, elastic yet not coded for CA.
!
        if(ione1.eq.0)then
          L=LCONDW/2+1-LNEW+LI/2
          L0=ABS(QPOS(L))
        endif
!        lcon0=4*((nmultx-1)/2)                                   !local
!
        DO KF=1+ione1,KMAX                                !BEGIN KF LOOP
!
          DO KG=1,KF-ione1                                !BEGIN KG LOOP
!
            IF(KACT(KG,KF).LT.0)GO TO 180
!
            N1=KACT(KF,KG)
            L1=QL(N1)
            N2=KACT(KG,KF)
            L2=QL(N2)
!
            L12M=ABS(L1-L2)
            L12=L1+L2
!
            LCON=L12
  160       LMIN=MTL-LCON
            IF(LMIN.LT.0)THEN                  !EFFECTIVE MULTIPOLE LOOP
              LCON=LCON-IFOUR
              IF(LCON.GE.L12M)GO TO 160
              LMIN=ABS(MTL-L12M)
            ENDIF
!
            LCON=MIN(L12,LCONDW-1)                               !GLOBAL
!            lcon0=3*abs(l1-l2)                                  !local
!            if(l12m.eq.2)lcon=min(lcon,14)                      !dipole
!
            MT=MTL-LCON
            IF(LMIN.LT.MT)THEN
              LMIN=MT
              IF(MOD(L12/2,ITWO).NE.MOD(LCON/2,ITWO))LMIN=LMIN+2  !ALIGN
            ENDIF
!
            LMAX=MTL+L12
            MT=MTL
!            MT=MAX(MT,LMIN)   !NEED MEMORY REPOINTED AS ACCESSES>LCONDW
            MT=MT+LCON
            IF(LMAX.GT.MT)THEN
              LMAX=MT
              IF(MOD(LMIN/2,ITWO).NE.MOD(LMAX/2,ITWO))LMAX=LMAX-2 !ALIGN
            ENDIF
!
            IF(LMAX.LT.LMIN)GO TO 180
!
            J=JNDEX(KF)
            JP=JNDEX(KG)
!
! OMIT CORRELATION BY ENERGY/NON-METASTABLE
!
            if(j.lt.0.or.jp.lt.0.or.min(j,jp).gt.nmeta)then    !non-meta
              ncor=ncor+(lmax-lmin)/4+1
              go to 180
            endif
!
            IF(BPRNT1)WRITE(MW6,10260)J,JP,LMIN/2,LMAX/2
!
            NEF=NEL(N1,KF)
            NEG=NEL(N2,KG)
            L11=2*(L1+1)
            L22=2*(L2+1)
            if(bwgttot)then           !.ge. v30.x
              nwtg=neg*mstat(kg)*(l11-nef+1)
              nwtf=nef*mstat(kf)*(l22-neg+1)
              if(nwtg.ne.nwtf)then
                write(mw0,*)'nwtg.ne.nwtf:',nwtg,nwtf,kg,kf,jp,j,       &
     &                      kact(kg,kf),kact(kf,kg)
!                call flush(mw6)
                stop 'nwtg.ne.nwtf'
              else
!                write(mw0,*)kg,kf,jp,j
              endif
              nwt=nwtg
            else                      !.le. v29.x
              NWT=NEF*NEG*QBINOM(L11,NEF)*QBINOM(L22,NEG)
            endif
!
            litlam=abs(l1-l2)/2                       !top-up multipole
!
! ALLOW FOR ANY INITIAL ALGEBRAIC TERMS NOT BEING LOWEST IN ENERGY.
!
            IF(J.LE.JP)THEN           !INITIAL ALGEBRAIC IS LOWER ENERGY
!
              JL=J                     !EO
              JH=JP                    !EO
!              KLOW=KF                 !SO
!              KUP=KG                  !SO
              LLOW=LI
              I1=1
              I2=2
!
            ELSE                        !FINAL ALGEBRAIC IS LOWER ENERGY
!
              JL=JP                    !EO
              JH=J                     !EO
!              KLOW=KG                 !SO
!              KUP=KF                  !SO
              LUP=LI
              I1=2
              I2=1
!
            ENDIF
!
            NOMT=IROW(JL,JH,ione1,NSPECE)                       !ROWWISE
            DE=DSPECE(JH)-DSPECE(JL)
!
            if(nomt.gt.nomwrt)then                !shouldn't happen, now
              write(mw0,*)jl,jh,nmeta,nspece,nomt,nomwrt
              stop 'omega prob.'
            endif
!
            DO LF=LMIN,LMAX,4                 !LOOP OVER FINAL CHANNEL L
!
              N1=NAD(NCOR)+1
              NCOR=NCOR+1
              N2=NAD(NCOR)
              IF(N1.GT.N2)GO TO 170                     !SHOULDN'T BE SO
!
!                     write(mw6,*)ncor,li/2,lf/2,kf,kg,n1,n2,nrk(n2)
!
! need to find if Slater integral initial and final states are swapped
! because of falling order. (algebraic are not swapped in CA.)
!
              do n=n1,n2
                bswap=.false.
                n8=nrk(n)
                if(n8.gt.0)then                      !direct or exchange
                  n0=int(n8,sp)
                  m0=qrl(1,n0)
                  if(li.eq.ql(m0))then
                    if(li.eq.lf.and.kf.ne.kg)then
                      m0=qrl(3,n0)
                      if(m0.le.mxorb)then                      !exchange
                        if(m0.ne.kact(kg,kf))then                  !swap
                          bswap=.true.
                        endif
                        go to 165
!                      else                !direct, continue to exchange
                      endif
                    else               !distinct or kf=kg, so they can't
                      go to 165
                    endif
                  else                             !trivially, they were
                    bswap=.true.
                    go to 165
                  endif
                else                                       !interference
                  stop 'interference position wrong...?'    !tbd: remove
                endif
              enddo
!
  165         continue
!         write(mw6,*)bswap
!
!-----------------------------------------------------------------------
!
! FORM RHO-REACTANCE MATRIX (SQUARED)
!
              DO M0=1,MENG0
                RHO1(M0)=DZERO
              ENDDO
!
              DO N=N1,N2            !BEGIN LOOP OVER SLATER INTERACTIONS
!
                n8=NRK(N)
                IF(n8.GT.0)THEN                      !DIRECT & EXCHANGE
                  N0=INT(n8,SP)
                ELSE                                 !INTERFERENCE
                  K1=-INT(n8/IPLANT_RL,SP)           !DIRECT      !MAXRL
                  K2=-INT(n8+K1*IPLANT_RL,SP)        !EXCHANGE    !MAXRL
                ENDIF
!
                DO M=1,MTRAN                   !INTERACTING ENERGY PAIRS
!
                  M1=MNDEX(M,I1)
                  M2=MNDEX(M,I2)
!
                  if(bswap)then           !swap because of falling order
                    mm=mrndx(m)
                  else
                    mm=m
                  endif
!
                  IF(n8.GT.0)THEN                    !DIRECT OR EXCHANGE
                    TMP1(M1,M2)=DRLX(N0,mm,LSTORE)
                  ELSE                               !INTERFERENCE
                    TMP1(M1,M2)=DRLX(K1,mm,LSTORE)   !DIRECT
                    TMP2(M1,M2)=DRLX(K2,mm,LSTORE)   !EXCHANGE
                  ENDIF
!
                ENDDO
!
! INTERPOLATE SLATER INTEGRAL AND UPDATE RHO^2.
!
                DO M0=1,MENG0                       !SCATTERING ENERGIES
!
                  M=IYY0(M0)
                  ml=mlim(m,1)
                  mu=mlim(m,2)
!
                  if(omginf(nomt).lt.dzero)mu=-mu           !flag dipole
!
                  T1=XINT(DE,DYY,NLAG,TMP1(1,M),M,ml,mu)         !INTERP
!
                  IF(N8.GT.0)THEN                    !DIRECT OR EXCHANGE
                    DD=T1*T1
                  ELSE       !could recover from respective dir & exc...
                    T2=XINT(DE,DYY,NLAG,TMP2(1,M),M,ML,MU)       !INTERP
                    DD=T1*T2
                  ENDIF
!
                  RHO1(M0)=RHO1(M0)+DD*DRK(N)
!
                ENDDO
!
!                    write(mw6,777)kf,kg,(rho1(m0),m0=1,meng0)
!  777               format(2i5,1p,10d12.3/(10x,10d12.3))
!
              ENDDO                   !END LOOP OVER SLATER INTERACTIONS
!
!-----------------------------------------------------------------------
!
! CONVERT TO TMX^2 AND ADD TO OMEGA
!
              IF(J.LE.JP)THEN
                LUP=LF
              ELSE
                LLOW=LF
              ENDIF
!
              DO M0=1,MENG0                         !SCATTERING ENERGIES
!
                M=IYY0(M0)
!
                RHOSQ=4*RHO1(M0)                                !AS A.U.
!
                if(rhosq.lt.dzero)rhosq=dzero              !interp error
!
                IF(KF.eq.KG.and.LI.eq.LF)THEN               !DIAGONAL MX
!
                  IF(BPRNT3)WRITE(MW6,10030)LLOW/2,LUP/2,JL,JH,         &
     &                            PSHFTX(M,L0),M0,'PHASE SHIFT'
                  T=TPI*PSHFTX(M,L0)
                  C2T=COS(T)
                  S2T=SIN(T)
!
                  rho=sqrt(rhosq)                           !approx
                  if(bunit)then                             !2x2 UNITARY
                    TSQ=DONE+(C2T*(RHOSQ-DONE)+DTWO*S2T*RHO)            &
     &                  /(RHOSQ+DONE)
                  else                                      !non-unitary
                    tsq=done+(dtwo*s2t*rho-c2t)
                  endif
!
                  TSQ=TSQ+TSQ              !  T^R=1+EXP(2I*TAU)(T^RHO-1)
!
                ELSE                                       !OFF DIAGONAL
!
                  TSQ=4*RHOSQ              !   |T^R(V,V')|=|T^RHO(V,V')|
!
                  if(bunit)TSQ=TSQ/(DONE+RHOSQ)**2 !APPROX UNITRTY
!
! TBD             IF(KF.EQ.KG)TSQ=TSQ+TSQ         !FOR ELASTIC LI.NE.LF
!
                ENDIF
!
                IF(BPRNT3)WRITE(MW6,10030)LLOW/2,LUP/2,JL,JH,RHOSQ,M0,  &
     &                                    'RHO^2-MATRIX'
!
                OMPW=wait*TSQ*NWT/DTWO
!
                if(bht)ompw=ompw/2             !for BHT(1970) comparison
!
! LOOK AT TOP-UP ISSUES, IF L LARGE ENOUGH TO WARRANT IT (OFF IF BTHRSH)
!
                IF(LNEW.GE.LRGLMN)THEN
!                                                            !NON-DIPOLE
                  IF(OMGINF(NOMT).gt.DZERO.and.litlam.gt.0)THEN
!
                    IF(LNEW.EQ.LRGLAM)THEN                 !APPLY TOP-UP
                      EJ=DYY0(M0)
                      EI=EJ+DE
!
                      ompw0=ompw
                      ompw=ompw/wait
                      IF(BPRNT3)OMPW=-OMPW                   !FLAG PRINT
!
                      CALL TOP2(LITLAM,LRGLAM,EI,EJ,OMPW)
!
                      ompw=ompw+ompw0*(wait-done)/wait           !adjust
!
                    ELSEIF(LNEW.GT.LRGLAM)THEN
                      OMPW=DZERO
                    ENDIF
!                                                  !DIPOLE:LITLAM=LRGLAM
                  ELSEIF(OMGINF(NOMT).LT.DZERO)THEN       !POSS ZERO-OUT
!                                                        !INC. IN TOP-UP
                    IF(MAX(LI,LF)/2.GT.LRGLAM)OMPW=DZERO
!
                  ENDIF
!
                ENDIF
!
! ARCHIVE PARTIAL/TOTAL COLLISION STRENGTHS
!
                IF(BTHRSH)THEN
                  M00=LUP/2+1-LVMIN
                  IF(M00.LT.1.OR.M00.GT.MOGGY)GO TO 170
                ELSE                          !CASE NOT XCLUDED BY CALGX
                  M00=M0
                ENDIF
!
                OMP(M0)=OMPW
!                                                    !UPDATE TOTAL OMEGA
                OMEGA(M00,NOMT)=OMEGA(M00,NOMT)+REAL(OMPW,RP)
!
              ENDDO                              !END LOOP OVER ENERGIES
!                                                         !PARTIAL OMEGA
              IF(BPRNT2)WRITE(MW6,10020)LLOW/2,LUP/2,JL,JH,             &
     &                                  (OMP(M0),M0=1,MENG0)
!
  170       ENDDO                                 !END LOOP OVER FINAL L
!
  180       CONTINUE
!
          ENDDO                                   !END LOOP KG
!
        ENDDO                                     !END LOOP KF
!
!-----------------------------------------------------------------------
!
        if(btimex)then
          call nrb_time(timef)
          times=timef-times
!
!par          if(iam.ge.0)then                                      !par
!par            write(mw6,*)'Ending proc',iam                       !par&
!par     &               ,'cadwx symmetry',ix                       !par&
!par     &               ,'  time=',nint(times),'sec'               !par
!par            call flush(iwp)                                     !par
!par          else                                                  !par
          write(iw,*)'Ending cadwx symmetry ',ix,'  time=',nint(times), &
     &               'sec'
!par          endif                                                 !par
        endif
!
!-----------------------------------------------------------------------
!                                             --------------------------
      ENDDO                                   !END LOOP OVER TOTAL SYMMS
!                                             --------------------------
!
      IF(IADD.NE.NCOR)THEN
        WRITE(MW6,*)'SR.CADWX: GLOBAL INDEX ERROR:',IADD,NCOR      !test
        GO TO 700
      ENDIF
!
!par!                                                               !par
!par      if(iam.ne.0)then                                          !par
!par        if(btimex)then                                          !par
!par          btimep=.false.                                        !par
!par          call nrb_time(timef)                                  !par
!par          times=timef-time0                                     !par
!par!                                                               !par
!par          write(iw,*)'Ending proc',iam,' for cadwx:'            !par&
!par     &             ,' time=',nint(times),'sec'                  !par
!par        endif                                                   !par
!par      endif                                                     !par
!par!                                                               !par
!par      ns=0                                                      !par
!par      nr=0                                                      !par
!par      itmp4=int(nomwrt,sp_mpi)                                  !par
!par!                                                               !par
!par      do m0=1,moggy                                             !par
!par!                                                               !par
!par        call pomsend(ns,omega(1,1),nomwrt,omsend)               !par
!par!                                                               !par
!par        call comm_barrier()                                     !par
!par!                                                               !par
!par        call mpi_reduce(omsend,omrecv,itmp4,my_mpi_real,        !par&
!par     &                  mpi_sum,izero_mpi,mpi_comm_world,ier4)  !par
!par!                                                               !par
!par        if(ier4.ne.0)write(mw0,*)'mpi_reduce: iam,ier=',iam,ier4!par
!par!                                                               !par
!par        call comm_barrier()                                     !par
!par!                                                               !par
!par        if(iam.eq.0)call pomrecv(nomwrt,omrecv,nr,omega(1,1))   !par
!par!                                                               !par
!par      enddo                                                     !par
!par!                                                               !par
!par      if(iam.ne.0)go to 5000                                    !par
!par!                                                               !par
!
! APPLY (DIPOLE) TOP-UP (OFF IF BTHRSH)
!
      IF(LRGLAM.GT.0)THEN
!
        WRITE(MW6,10190)LRGLAM
        if(btimex)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Proc',iam,                                !par&
!par     &       'Top-up has been applied: lrglam=',lrglam          !par
!par        else                                                    !par
          write(iw,*)'Top-up has been applied: lrglam=',lrglam
!par        endif                                                   !par
        endif
        IF(BPRNT2)WRITE(MW6,10050)
!
        LITLAM=LRGLAM                             !USE GLOBAL VALUE LA=0
        CO2S=D3QRT/LOG(EINF*DZ2)
!
        NOMT=0
        DO I=1,NMETA                                        !,NSPECL
!          IF(INDEX(I).GT.0)THEN                               !NON-CORR
!
          i0=index(i)
          DO J=I+ione1,NSPECE                                !,NSPECL
!            IF(INDEX(J).GT.0)THEN                             !NON-CORR
!
            NOMT=NOMT+1
            SS=OMGINF(NOMT)
!
            IF(SS.LT.DZERO)THEN                                  !DIPOLE
!
              j0=index(j)
              if(bwgttot)then            !.ge. v30.x
                kf=max(i0,j0)
                kg=min(i0,j0)
                if(kact(kg,kf).lt.0)then                !ss should be =0
                  stop 'cadwx:dipole top-up index error...?'
                endif
                n1=kact(kf,kg)
                l1=ql(n1)
                n2=kact(kg,kf)
                l2=ql(n2)
                nef=nel(n1,kf)
                neg=nel(n2,kg)
                l11=2*(l1+1)
                l22=2*(l2+1)
                mg=qbinom(l22,neg)
                mg=mg*qbinom(l11,nef-1)
                ncorwtg=mstat(kg)/(mg)
                mf=qbinom(l11,nef)
                mf=mf*qbinom(l22,neg-1)
                ncorwtf=mstat(kf)/(mf)
                if(ncorwtg.ne.ncorwtf)then
                  write(mw0,*)'cadwx: ncorwtg.ne.ncorwtf:',ncorwtg,     &
     &                        ncorwtf,kg,kf,i,j,kact(kg,kf),kact(kf,kg)
!                  call flush(mw6)
                  stop 'cadwx: ncorwtg.ne.ncorwtf'
                endif
                ncorwt=ncorwtg
              else                       !.le. v29.x
                ncorwt=1
              endif
!
              SS=SS*CO2S                       !CONVERT TO LINE STRENGTH
              DE=DSPECE(J)-DSPECE(I)
              DE=DE/DZ2
              DO M0=1,MENG0
                EJ=DYY0(M0)/DZ2
                EI=EJ+DE
!
                CALL TOP1(NZA,LITLAM,EI,EJ,SS,OMT)
!
                if(bht)omt=omt/2               !for BHT(1970) comparison
                omt=omt*ncorwt
!
                OM=REAL(OMEGA(M0,NOMT),WP)
                OMEGA(M0,NOMT)=OMEGA(M0,NOMT)+REAL(OMT,RP)
!
                IF(BPRNT2)WRITE(MW6,10060)I,J,SS,EI,EJ,DE,OM,OMT,OM+OMT
              ENDDO
            ENDIF
!
!              IF(NOMT.EQ.NOMWRT)GO TO 113                  !WE ARE DONE
!            ENDIF
          ENDDO
!
!          ENDIF
        ENDDO
!
      ELSE
!
        WRITE(MW6,10200)
        if(btimex)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Proc',iam,'Top-up has *NOT* been applied!'!par
!par        else                                                    !par
          write(iw,*)'Top-up has *NOT* been applied!'
!par        endif                                                   !par
        endif
!
      ENDIF
!
! 113  CONTINUE
!
! fix top-up failure on high-e near-degenerate Born allowed transitions
!
      if(btop)then
        NOMT=0
        DO I=1,NMETA
          DO J=I+ione1,NSPECE
            NOMT=NOMT+1
            OMB=OMGINF(NOMT)
            IF(OMB.GT.DZERO)THEN                                   !born
              DE=DSPECE(J)-DSPECE(I)
              DE=MAX(DE,D1M30)
              OM=REAL(OMEGA(2,NOMT),WP)
              DO M0=3,MENG0                        !skip threshold point
                RAT=DYY0(M0)/DE
                OM1=OM
                OM=REAL(OMEGA(M0,NOMT),WP)
                IF(RAT.GT.XBTEST.AND.OM.LT.D0PT8*OM1.AND.OM1.LT.OMB)THEN
                  MM=M0-1              !max(2,m0-1) if no threshold skip
                  GO TO 185
                ENDIF
              ENDDO
              M0=MENG0
              MM=M0+1
              IF(OM1.GE.OMB)THEN
                IF(OM.LT.OMB)MM=MENG0
              ELSE
                IF(OM.LT.OM1)MM=MENG0
              ENDIF
  185         IF(BPRNT2.AND.MM.LE.MENG0)THEN
                WRITE(MW6,10100)I,J,DYY0(M0),DE,RAT,                    &
     &                          (OMEGA(M,NOMT),M=1,MENG0),OMB
              ENDIF
              DO M0=MM,MENG0
                OMEGA(M0,NOMT)=REAL(OMB,RP)
              ENDDO
            ENDIF
          ENDDO
        ENDDO
      endif
!
! test convert to cross section
!
      if(bcrossx)then
        nomt=0
        do i=1,nmeta
          j=index(i)
          do ip=i+ione1,nspece
            nomt=nomt+1
            de=dspece(ip)-dspece(i)
            jp=index(ip)
!
            if(bwgttot)then            !.ge. v30.x
              wi=mstat(j)
            else                       !.le. v29.x
              kf=max(j,jp)
              kg=min(j,jp)
              n1=kact(kf,kg)
              l1=ql(n1)
              n2=kact(kg,kf)
              l2=ql(n2)
              n1=nel(n1,kf)
              n2=nel(n2,kg)
              if(kg.eq.j)then                      !kg not kf
                wi=qbinom(2*(l1+1),n1-1)*qbinom(2*(l2+1),n2)
              else
                wi=qbinom(2*(l1+1),n1)*qbinom(2*(l2+1),n2-1)
              endif
            endif
!
            do m0=1,moggy
              ej=dyy0(m0)
              ei=ej+de
              if(brel)ei=ei+dalf4*ei*ei          !wavenumber
              om=real(omega(m0,nomt),wp)
              om=xconv*om/(ei*wi)
              omega(m0,nomt)=real(om,rp)
            enddo
          enddo
        enddo
      endif
!
!-----------------------------------------------------------------------
!
! WRITE TOTALS
!
      IF(BTHRSH)THEN
        WRITE(MW6,10180)
        IF(BPRNT0)THEN
          WRITE(MW6,10250)((I,J,J=I+ione1,NSPECE),I=1,NMETA)    !ROWWISE
          DO M0=1,MOGGY
            WRITE(MW6,10010)REAL(M0-1+LVMIN),(OMEGA(M0,N),N=1,NOMWRT)
          ENDDO
        ENDIF
      ELSE
        WRITE(MW6,10170)
        IF(BPRNT0)THEN
          WRITE(MW6,10240)((I,J,J=I+ione1,NSPECE),I=1,NMETA)    !ROWWISE
          DO M0=1,MENG0                                         !=MOGGY
            WRITE(MW6,10010)DYY0(M0),(OMEGA(M0,N),N=1,NOMWRT)
          ENDDO
        ENDIF
      ENDIF
!
      IF(IUNIT(MRW23).GT.0)THEN
        CLOSE(MRW23,STATUS='DELETE')
        IF(BTHRSH.or..not.bomega)THEN
          IUNIT(MRW23)=-1
        ELSE
          OPEN(MRW23,FILE='OMEGACA',STATUS='REPLACE')      !USE NEW NAME
!TBD     OPEN(MRW23,FILE='OMEGAUCA',STATUS='REPLACE',FORM='UNFORMATTED')
          WRITE(MRW23,*)NZION,MION
          WRITE(MRW23,*)NSPECE,-(MENG0+1),NOMWRT      !FLAG NO E'S .LT.0
          WRITE(MRW23,*)(IWRK3(I),IWRK4(I),I=1,NSPECE)
          WRITE(MRW23,10040)(DWRK(I),I=1,NSPECE)
          DO M0=1,MENG0                                          !=MOGGY
            WRITE(MRW23,F713)DYY0(M0)/DZ2,(OMEGA(M0,N),N=1,NOMWRT)
          ENDDO
          WRITE(MRW23,F713)EINF,(OMGINF(N),N=1,NOMWRT)
          IUNIT(MRW23)=-1
          CLOSE(MRW23)
        ENDIF
      ENDIF
!
! OVERWRITE PWB ADF04 WITH DW, TAKING ACCOUNT OF THE FACT THAT THE PWB
! DOES NOT CONTAIN (SPIN) FORBIDDEN TRANSITIONS
!
      IF(IUNIT(MRW25).GE.0)THEN         !NO ADF04, LIKELY SINCE RAD='NO'
        WRITE(MW6,*)'NO ADF04 FILE="adf04ca"...'
        WRITE(MW0,*)'NO ADF04 FILE ON UNIT=',MRW25
!        NF=-1
        GO TO 400
      ELSEIF(IUNIT(MRW25).LT.0)THEN
        IUNIT(MRW25)=1
        OPEN(MRW25,FILE='adf04ca',STATUS='OLD',ERR=400)
      ENDIF
!
      BEXP=.FALSE.                              !*MUST* SYNC WITH CARATE
      IF(NSPECE.LT.1000)THEN
        i1=0
        IF(MOGGY.LE.20)THEN
          IF(BEXP)THEN
            F761='(F5.2, I5, 8X,20(1PE10.2))'
            F762='(2I4,22(1PE10.2))'
            F767='(18X,21(F10.5))'
          ELSE
            F761='(A5,A3,I2, 6X, 20(A5, A3))'
            F762='(2I4, 22(A5, A3))'
            F767='(16X,21(F8.5))'
          ENDIF
        ELSE
          IF(BEXP)THEN
            F761='(F5.2, I5, 8X,20(1PE10.2)/(18X,20(1PE10.2)))'
            F762='(2I4,21(1PE10.2)/(18X,20(1PE10.2)))'
          ELSE
            F761='(A5,A3,I2, 6X, 20(A5, A3)/(16X, 20(A5, A3)))'
            F762='(2I4, 21(A5, A3)/(16X, 20(A5, A3)))'  !WRAP LAST POINT
          ENDIF
        ENDIF
      ELSE
        i1=1
        IF(MOGGY.LE.20)THEN
          IF(BEXP)THEN
            F761='(F5.2, I5,10X,20(1PE10.2))'
            F762='(2I5,22(1PE10.2))'
            F767='(20X,21(F10.5))'
          ELSE
            F761='(A5,A3,I2, 8X, 20(A5, A3))'
            F762='(2I5, 22(A5, A3))'
            F767='(18X,21(F8.5))'
          ENDIF
        ELSE
          IF(BEXP)THEN
            F761='(F5.2, I5,10X,20(1PE10.2)/(20X,20(1PE10.2)))'
            F762='(2I5,21(1PE10.2)/(20X,20(1PE10.2)))'
          ELSE
            F761='(A5,A3,I2, 8X, 20(A5, A3)/(18X, 20(A5, A3)))'
            F762='(2I5, 21(A5, A3)/(18X, 20(A5, A3)))'  !WRAP LAST POINT
          ENDIF
        ENDIF
      ENDIF
!
      MSC0=80
      OPEN(MSC0,STATUS='SCRATCH',FORM='FORMATTED')
      IF(.NOT.BEXP)THEN
        MSCP=81
        OPEN(MSCP,STATUS='SCRATCH',FORM='FORMATTED')
      ENDIF
!
      DO N=1,NSPECE+2
        READ(MRW25,10090)CARD
        WRITE(MSC0,10090)CARD
      ENDDO
!
      NNN=max(NOMWRT,nomwr0)
!
      DO N=1,NNN+2
        READ(MRW25,10090,END=200)CARD
        WRITE(MSC0,10090)CARD
      ENDDO
!
  200 REWIND(MRW25)
      REWIND(MSC0)
!
      DO N=1,NSPECE+2
        READ(MSC0,10090)CARD
        WRITE(MRW25,10090)CARD
      ENDDO
!
      IF(BTHRSH)THEN
        ITYPE=6
        WRITE(MRW25,F767)(PSHFT0(M-1+LVMIN),M=1,MOGGY)
        IF(BEXP)THEN
          WRITE(MRW25,F761)REAL(NZA+1),ITYPE,(REAL(M-1+LVMIN),M=1,MOGGY)
        ELSE
          WRITE(MSCP,10120)(REAL(M-1+LVMIN),M=1,MOGGY)
        ENDIF
      ELSE
        ITYPE=5
        IF(BEXP)THEN
          WRITE(MRW25,F761)REAL(NZA+1),ITYPE,(DYY0(M),M=1,MENG0) !=MOGGY
        ELSE
          WRITE(MSCP,10120)(DYY0(M),M=1,MENG0)                   !=MOGGY
        ENDIF
      ENDIF
!
      IF(BEXP)THEN
        READ(MSC0,F761)
      ELSE
        BACKSPACE(MSCP)
        READ(MSCP,10130)(XMANT(M),IEXP(M),M=1,MOGGY)
        iexp(0)='   '
        READ(MSC0,F761)XMANT(0)                                !,IEXP(0)
        WRITE(MRW25,F761)XMANT(0),IEXP(0),ITYPE,                        &
     &                   (XMANT(M),IEXP(M),M=1,MOGGY)
      ENDIF
!
      MENG1=MOGGY+1
      IB0=1
      JB0=IB0+IONE1
!
      nt=0
!
      DO N=1,NNN+1
!
        IF(BEXP)THEN
          READ(MSC0,F762)JB,IB,XB0,(DUM,I=1,MXNXB),XB1
        ELSE
          READ(MSC0,F762)JB,IB,XMANT0,IEXP0,(XMANT(I),IEXP(I),I=1,MXNXB)&
     &                   ,XMANT1,IEXP1
        ENDIF
!
        JB1=JB
        IF(JB.LT.0)THEN
          JB1=NSPECE
          IB=MIN(JB1-IONE1,NMETA)
          IF(BEXP)THEN
            XB0=D1M30
            XB1=DZERO
          ELSE
            XMANT0=' 1.00'
            IEXP0='-30'
            XMANT1=' 0.00'
            IEXP1='+00'
          ENDIF
        ENDIF
!
        IF(BEXP)THEN
          X0=D1M30
          X1=DZERO
        ELSE
          XMANT(0)=' 1.00'
          IEXP(0)='-30'
          XMANT(MENG1)=' 0.00'
          IEXP(MENG1)='+00'
        ENDIF
!
        DO JT=JB0,JB1
          IF(JT.EQ.JB1)THEN
            IB1=IB
          ELSE
            IB1=MIN(JT-IONE1,NMETA)
          ENDIF
          DO IT=IB0,IB1
!
!test        if(ione1.eq.0.or.it.ne.jt)then   !catch ione1=0 carate only
            nt=nt+1
!
            NOMT=IROW(IT,JT,IONE1,NSPECE)
!                                            !TEST MENG0 STILL IF BTHRSH
            IF(OMEGA(MENG0,NOMT).GT.E1M30)THEN           !NO SKIP FOR CA
!
!              if(omginf(nomt).lt.dzero)then  !test write reduced dipole
!                do m=1,moggy
!                  de=log(dyy0(m)+2.7183)
!                  omega(m,nomt)=omega(m,nomt)/de
!                enddo
!              endif
!
              IF(BEXP)THEN
                IF(JT.EQ.JB1.AND.IT.EQ.IB1)THEN             !NOW ALLOWED
                  X0=XB0
                  X1=XB1
                ENDIF
                WRITE(MRW25,F762)JT,IT,X0,(OMEGA(M,NOMT),M=1,MOGGY),X1
              ELSE
                BACKSPACE(MSCP)
                WRITE(MSCP,10120)(OMEGA(M,NOMT),M=1,MOGGY)
                BACKSPACE(MSCP)
                READ(MSCP,10130)(XMANT(M),IEXP(M),M=1,MOGGY)
                IF(JT.EQ.JB1.AND.IT.EQ.IB1)THEN             !NOW ALLOWED
                  XMANT(0)=XMANT0
                  IEXP(0)=IEXP0
                  XMANT(MENG1)=XMANT1
                  IEXP(MENG1)=IEXP1
                ENDIF
                WRITE(MRW25,F762)JT,IT,(XMANT(M),IEXP(M),M=0,MENG1)
              ENDIF
!
            ENDIF
!test        endif
          ENDDO
          IB0=1
        ENDDO
!
        IF(JB.LT.0)then
          if(nt.ne.nomwrt)then                                 !checksum
            write(mw6,*)'adf04 no. of transitions mis-match: nt,nomwrt='&
     &                  ,nt,nomwrt
            write(mw0,*)'adf04 no. of transitions mis-match'
            nf=-1
            go to 400
          endif
          GO TO 300
        endif
!
        JB0=JB
        IB0=IB+1
!
      ENDDO
!
      WRITE(MW0,*)'SR.CADWX: HAVE NOT REACHED END OF adf04ca...'
      WRITE(MW6,*)'SR.CADWX: HAVE NOT REACHED END OF adf04ca...'
      NF=-1
      GO TO 400
!
  300 WRITE(MRW25,F762)-1
      WRITE(MRW25,F762)-1,-1
!
      if(.not.badas)then                             !adas skip comments
        WRITE(MRW25,10070)
!
        NREC=1
  350   NREC=NREC+1
        BACKSPACE(MR5)
        BACKSPACE(MR5)
        READ(MR5,10140)CARD4
        IF(CARD4.NE.'A.S.'.AND.CARD4.NE.'S.S.')GO TO 350
        REWIND(MR5)
!
        DO N=1,NREC
          READ(MR5,10090)CARD
          WRITE(MRW25,10080)CARD
        ENDDO
        DATE='        '
        CALL DATE_AND_TIME(DATE)
        WRITE(MRW25,10110)DATE(7:7),DATE(8:8),DATE(5:5),DATE(6:6),      &
     &                    DATE(3:3),DATE(4:4)
      endif
!
      IUNIT(MRW25)=-1
      CLOSE(MRW25)
!
      CLOSE(MSC0)
      IF(.NOT.BEXP)CLOSE(MSCP)
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par 5000 continue                                                  !par
!
  400 CONTINUE
!
      DEALLOCATE(KACT,KTMP,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CADWX: DE-ALLOCATION FAILS FOR KACT,KTMP'
        NF=0
        GO TO 700
      ENDIF
!
  500 DEALLOCATE(OMGINF,OMEGA,STAT=IERR)
!par!                                                               !par
!par      deallocate(omsend,omrecv,stat=ierr)                       !par
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CADWX: DE-ALLOCATION FAILS FOR OMEGA'
        NF=0
        GO TO 700
      ENDIF
!
  600 CONTINUE
!
      DEALLOCATE(OMP,RHO1,TMP1,TMP2)
      DEALLOCATE(IEXP,XMANT)
      IF(ALLOCATED(DWRK))DEALLOCATE(DWRK,IWRK3,IWRK4)
!par!                                                               !par
!par 5500 continue                                                  !par
!
  700 CONTINUE
!
!-----------------------------------------------------------------------
!
      if(btimep)then
        call nrb_time(timef)
        times=timef-time0
!par!                                                               !par
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Ending proc',iam,' for cadwx:'            !par&
!par     &               ,' time=',nint(times),'sec,     '          !par&
!par     &               ,nint(times/60),'min'                      !par
!par          call flush(iw)                                        !par
!par        else                                                    !par
        write(iw,*)'Ending cadwx: time=',nint(times),'sec,     ',       &
     &             nint(times/60),'min'
!par        endif                                                   !par
      endif
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(F21.3,2X,1P,10(E11.3)/(23X,10(E11.3)))
10020 FORMAT(2I5,3X,2I4,2X,1P,10(E11.3)/(23X,10(E11.3)))
10030 FORMAT(2I5,3X,2I4,2X,1PE11.3,10X,'E(',I2,')   ',A13)
10040 FORMAT(1P,5E16.6)
!10050 FORMAT(1PE14.8,6E11.3/(14X,6E11.3))
10050 FORMAT(3X,'CH',2X,'CHP',9X,'S',14X,'EI',10X,'EJ',10X,'DE',9X,     &
     &       'OMEGA(PAR)',2X,'OMEGA(TOP)',4X,'OMEGA(TOT)')
10060 FORMAT(2I5,3X,1PE11.3,2X,0P,3F12.4,5X,2F12.4,2X,F12.4)
10070 FORMAT('C',79('-')/'C'/'C')
10080 FORMAT('C ',A200)
10090 FORMAT(A200)
10100 FORMAT(2I5,22(1PE10.2))
10110 FORMAT('C'/'C'/'C',79('-')/'C'/'C',1X,                            &
     &       'AUTOSTRUCTURE DISTORTED-WAVE'/'C'/'C NAME:'/'C DATE: ',   &
     &       2(A1),'/',2(A1),'/',2(A1)/'C'/'C',79('-'))
10120 FORMAT(22(1PE9.2))
10130 FORMAT(22(A5,1X,A3))
10140 FORMAT(A4)
10150 FORMAT(2I10,13X,F18.6)
10160 FORMAT(9X,'I',8X,' C',21X,'(EI-E1)/RY',15X,'NMETA=',I5)
10170 FORMAT(///1X,136('-')//51X,                                       &
     &       '*** TOTAL COLLISION STRENGTHS (CA) ***'//1X,136('-')//)
10180 FORMAT(///1X,136('-')//45X,                                       &
     &       '*** THRESHOLD PARTIAL COLLISION STRENGTHS (CA) ***'//1X,  &
     &       136('-')//)
10190 FORMAT(//' *** TOP-UP HAS BEEN APPLIED: LRGLAM=',I5//)
10200 FORMAT(//' *** TOP-UP HAS *NOT* BEEN APPLIED ***'//)
10210 FORMAT(//1X,136('-')///49X,'*** TARGET ENERGIES (CA) ***'/)
10220 FORMAT(//1X,136('-')/)
10230 FORMAT(/3X,' L',3X,'LP',5X,' I',2X,'IP',4X,'OMEGA(IE=1,MENG):')
10240 FORMAT(74X,'OMEGA(I-IP)'/74X,11('-')/2X,'*FINAL* ENERGY(RYD)',2X, &
     &       10(2X,I4,'-',I4)/(23X,10(2X,I4,'-',I4)))
10250 FORMAT(74X,'OMEGA(I-IP)'/74X,11('-')/1X,'*FINAL* RYDBERG A.M.',2X,&
     &       10(2X,I4,'-',I4)/(23X,10(2X,I4,'-',I4)))
10260 FORMAT(20X,2I5,2X,2I4)
10270 FORMAT(' SY=',I3/1X,6('-'))
10280 FORMAT(' SY=',I3,13X,'    I','   IP',3X,'LP=...,+2')
10290 FORMAT(//' *** UPDATING SLATER INTEGRALS FOR LTOT=',I3/1X,42('-') &
     &       /)
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION IROW(ILI,ILF,IONE1,NENG)
!
      INTEGER (SP) ILI,ILF,IONE1,NENG,IROW
!
      IROW=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE1))/2
!
      END FUNCTION IROW
!-----------------------------------------------------------------------
!
      END SUBROUTINE CADWX
!
!                             *******************
!
      SUBROUTINE CAEKAL(MMIN,MMAX,JOS)
!
!-----------------------------------------------------------------------
!
!  SR.CAEKAL EXPANDS THE ELECTRIC MULTIPOLE MATRIX ELEMENT <CA|R^K|CA'>
!  IN TERMS OF RADIAL INTEGRALS AND ANGULAR COEFFICIENTS.
!  IT CALCULATES THE AVERAGE SQUARE ALGEBRAIC COEFFICIENT * NWT
!  WHERE NWT IS THE NUMBER OF TRANSITIONS. THIS IS JUST
!  NWT * 0.5*(L1 K L2 0 0 0)**2 WHERE (...) IS THE WIGNER 3J-SYMBOL.
!
!  N.B. WE COULD DIVIDE BY THE STAT WEIGHT OF ALGEBRAIC "UPPER" STATE,
!  SAY, AND CANCEL BINOMIALS ANALYTICALLY BUT SINCE WE SUBSEQUENTLY WANT
!  THE LINE STRENGTH ANYWAY, WE CURRENTLY GENERATE A SYMMETRIC QUANTITY.
!
!  IT IS CALLED BY:
!    SR.CALGEB
!
!  IT CALLS:
!    FN.QBINOM
!    FN.VCC
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_ALGEB,  ONLY: MPRINT
!!      COMMON /BASIC/NF,KF,KG,NEN11,NEN21,NEN12,NEN22,MGAP(5)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,NEN11=>IBSK4,NEN21=>IBSK5      &
     &              ,NEN12=>IBSK6,NEN22=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9&
     &              ,IBSK10=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL,NAD,IWORD
      USE COMMON_DXRL,   ONLY: IRK,IRK0,IOS,IOS0
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
!
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBRN2, ONLY: BINDB,MENGB
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      INTEGER(SP) QBINOM                       !DO NOT USE SHORT INTEGER
!
!-----------------------------------------------------------------------
!
!      ICOL(ILI,ILF,IONE1)=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
!-----------------------------------------------------------------------
!
      MXORB2=MXORB*MXORB      !MXORB -> MXORBR UNNECESS. FOR CA   !FLAGX
!
      i1=1
!!      i1=mb+1                                                   !FLAGX
      i2=i1
!
      IOS0=IOS+1
      K=IOS
!
      NG=NEN11
      NT=NEN21
      M1=QL(NG)
      M2=QL(NT)
      MN=MIN(NT,NG)
      MX=MAX(NT,NG)
      IN=ICOL(MN,MX,IZERO)
!
      NUX=NEL(NG,KF)
      NLX=NEL(NT,KG)
      NWT=NUX*NLX*QBINOM(2*M1+2,NUX)*QBINOM(2*M2+2,NLX)
!
      DO MK=MMIN,MMAX,4
!
        MM=MK/2
        BINDB(IN,MM/2)=.TRUE.
!
        DD=VCC(M1,M2,MK,IZERO,IZERO,IZERO)
        DD=DD*DD/REAL(MK+1,WP)                                 !W3J NORM
        DD=NWT*DD/2
!
! STORE COEFFICIENT
!
        K=K+1
        IF(K.GT.IAXRK)THEN                                    !GO TO 999
          IXXX=7*(IAXRK/5+1)
          WRITE(MW6,*)'*** CAEKAL: increasing MAXRK from ',IAXRK,       &
     &                ' to: ',IXXX
          WRITE(MW0,*)'*** CAEKAL: increasing MAXRK from ',IAXRK,       &
     &                ' to: ',IXXX
!
          CALL RE_ALLOC(DRK,IONE,IAXRK,IXXX,IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'CAEKAL: RE-ALLOCATION FAILS FOR DRK'
            NF=0
            GO TO 100
          ENDIF
!
          CALL RE_ALLOC(NRK,IONE,IAXRK,IXXX,IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'CAEKAL: RE-ALLOCATION FAILS FOR NRK'
            NF=0
            GO TO 100
          ENDIF
          IAXRK=IXXX
        ENDIF
!
        MX=MK
!!        MX=MX-MPOL0                                             !FLAGX
!!        if(irlx.lt.0)then
!!          i1=icfgp(kf)*mb+1
!!          i2=icfgp(kg)*mb+1
!!        endif
        IPLANT=(MX/2)*MXORB2+(NG-I1)*MXORB+NT-I2
!
        NRK(K)=IPLANT
        DRK(K)=DD
!
        IF(MPRINT.GT.0)THEN
          IF(MM.LT.10)THEN
            WRITE(MW6,10010)JOS,KF,KG,NG,NT,K,DRK(K)/NWT,MM
          ELSE
            WRITE(MW6,10020)JOS,KF,KG,NG,NT,K,DRK(K)/NWT,MM
          ENDIF
        ENDIF
!
      ENDDO
!
  100 IOS=K
      IF(IOS.GE.IOS0)JOS=JOS+1
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(I5,2X,2(I5,I4),I7,F13.5,5X,'E',I1)
10020 FORMAT(I5,2X,2(I5,I4),I7,F13.5,5X,'E',I2)
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!-----------------------------------------------------------------------
!
      END SUBROUTINE CAEKAL
!
!                             *******************
!
      SUBROUTINE CAFLGL0
!
!-----------------------------------------------------------------------
!
!  SR.CAFLGL0 EXPANDS THE DIAGONAL ENERGY MATRIX ELEMENT <CA! H !CA>
!  IN TERMS OF 2-BODY RADIAL INTEGRALS AND CALCULATES THE COEFFICIENTS.
!
!  IT IS CALLED BY:
!    SR.CALGEB
!
!  IT CALLS:
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!    FN.VCC
!
!-----------------------------------------------------------------------
!
!!      COMMON /BASIC/NF,KF,KG,MGAP(9)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,IBSK4=>IBSK4,IBSK5=>IBSK5      &
     &              ,IBSK6=>IBSK6,IBSK7=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9&
     &              ,IBSK10=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL,NAD,IWORD
      USE COMMON_DXRL,   ONLY: IRK,IRK0,IOS,IOS0
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
!
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL2, ONLY: MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX                     &
     &                        ,MXBORB,MXVORB,MXFORB,NGRP
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION MRL(5)
!
      POINTER :: ML
      TARGET :: MRL
!
      ML=>MRL(5)
!
!      EQUIVALENCE (ML,MRL(5))
!
!-----------------------------------------------------------------------
!
      MXLAM=ABS(MAXLAM)
      NMULT=NMULTE-1                              !LIMIT NO OF MULIPOLES
!
      IRL00=IRL
!
      IDIR=0                                               !ALLOW DIRECT
      IXCH=0                                              !ALLOW ECHANGE
!t      idir=1
!t      ixch=1
!
! RESTRICT RANGE OF ORBITALS
!
      NGRP0=0
      MB0=MB
!
      IF(IEQ(0).LT.0)THEN
!p        MXBORB=-IEQ(0)
      ELSEIF(IEQ(0).GT.0)THEN
        IF(IRLX.LT.0)THEN                   !IRLX.LT.0 MEANS IEQ(0).GT.0
!p          NGRP=-IRLX/100000
!p          MXBORB=-IRLX-100000*NGRP
          IF(NF.EQ.0)NGRP0=NGRP
          MB0=0
        ELSEIF(NF.GT.0)THEN
!p          ID=IEQ(0)-MXORB
!p          NGRP=ID/100000
!p          ID=ID-100000*NGRP
!p          MXFORB=ID/10000
!p          ID=ID-10000*MXFORB
!p          MXVORB=ID/1000
!p          ID=ID-1000*MXVORB
!p          MXBORB=ID
        ENDIF
      ENDIF
!
      J1=1
      K00=MB+1
!
      IF(NF.EQ.0)THEN                                 !CLOSED SHELL CORE
        MXB=MB
      ELSEIF(IEQ(0).EQ.0)THEN
        MXB=0
        DO J=1,MXORB
          IF(QN(J).LT.90)MXB=J
        ENDDO
      ELSE
        N=ICFGP(KF)
        N1=(N-1)*MXBORB
        IF(IRLX.LT.0)J1=J1+N1
        K00=K00+N1
        MXB=N1+MXBORB+MB0
      ENDIF
!
! FORM CONFIGURATION AVERAGE
!
      G0=DONE/DTWO
!
      DO J=J1,MXB                              !LOOP OVER FIRST ELECTRON
!
        IF(NEL(J,KF).NE.0)THEN
!
          IF(IDIR.EQ.0)THEN
!
            MI=QL(J)+2
            F0=REAL((MI-1),WP)/REAL((2*MI-3),WP)
            MJX=MIN(INT(QL(J),SP),MXLAM)                     !MAX LAMBDA
            MJX=MIN(MJX,ITWO*NMULT)                           !LIMIT NO.
!
          ENDIF
!
          IF(NF.EQ.0)THEN
            K0=J
          ELSE                                  !EXCLUDE ANY CLOSED CORE
            K0=MAX(J,K00)
          ENDIF
!
          DO K=MXB,K0,-1                      !LOOP OVER SECOND ELECTRON
!
            BEQNL=J.EQ.K
!
            C=ABS(NEL(K,KF))
            IF(BEQNL)C=(C-DONE)/DTWO
!
            IF(C.NE.DZERO)THEN
!
              C=C*ABS(NEL(J,KF))
!
! STATIC
!
              MRL(1)=K
              MRL(3)=K
              MRL(2)=J
              MRL(4)=J
              MRL(5)=0
!
              IRL=IRL+1
              IF(IRL.GT.IAXRL)THEN
                IXXX=7*(IAXRL/5+1)
                WRITE(MW6,*)'*** CAFLGL0: increasing MAXRL from ',IAXRL,&
     &                      ' to: ',IXXX
                WRITE(MW0,*)'*** CAFLGL0: increasing MAXRL from ',IAXRL,&
     &                      ' to: ',IXXX
!
                CALL RE_ALLOC2(QRL,IONE,IFIVE,IONE,IAXRL,IFIVE,IXXX,    &
     &                         IERR)
!
                IF(IERR.NE.0)THEN
                  WRITE(MW0,*)'CAFLGL0: RE-ALLOCATION FAILS FOR QRL'
                  NF=0
                  GO TO 100
                ENDIF
                IAXRL=IXXX
              ENDIF
!
              IRK=IRK+1
              IF(IRK.GT.IAXRK)THEN
                IXXX=7*(IAXRK/5+1)
                WRITE(MW6,*)'*** CAFLGL0: increasing MAXRK from ',IAXRK,&
     &                      ' to: ',IXXX
                WRITE(MW0,*)'*** CAFLGL0: increasing MAXRK from ',IAXRK,&
     &                      ' to: ',IXXX
!
                CALL RE_ALLOC(DRK,IONE,IAXRK,IXXX,IERR)
!
                IF(IERR.NE.0)THEN
                  WRITE(MW0,*)'CAFLGL0: RE-ALLOCATION FAILS FOR DRK'
                  NF=0
                  GO TO 100
                ENDIF
!
                CALL RE_ALLOC(NRK,IONE,IAXRK,IXXX,IERR)
!
                IF(IERR.NE.0)THEN
                  WRITE(MW0,*)'CAFLGL0: RE-ALLOCATION FAILS FOR NRK'
                  NF=0
                  GO TO 100
                ENDIF
                IAXRK=IXXX
              ENDIF
!
              DRK(IRK)=C
              NRK(IRK)=IRL
!
              DO M=1,5
                QRL(M,IRL)=INT(MRL(M),QP)
              ENDDO
!
              IF(NGRP0.NE.0)THEN          !DUPLICATE CORE FOR EACH GROUP
                DO N=1,NGRP-1
                  IRL=IRL+1       !ASSUME INITIAL ALLOC O.K. FOR CORE...
                  DO M=1,4
                    QRL(M,IRL)=INT(MRL(M)+N*MXBORB,QP)
                  ENDDO
                  QRL(5,IRL)=INT(MRL(5),QP)
                ENDDO
              ENDIF
!
! DIRECT
!
              IF(BEQNL.AND.IDIR.EQ.0)THEN
!
                DO MJ=2,MJX,2
!
                  ML=2*MJ
                  DC1=VCC(INT(QL(J),SP),ML,INT(QL(J),SP),IZERO,IZERO,   &
     &                IZERO)
                  F=-F0*DC1*DC1/(QL(J)+1)
!                write(mw6,*)ql(j),2*mj,ql(j),'  f=',f
!
                  IRL=IRL+1
                  IF(IRL.GT.IAXRL)THEN
                    IXXX=7*(IAXRL/5+1)
                    WRITE(MW6,*)'*** CAFLGL0: increasing MAXRL from ',  &
     &                          IAXRL,' to: ',IXXX
                    WRITE(MW0,*)'*** CAFLGL0: increasing MAXRL from ',  &
     &                          IAXRL,' to: ',IXXX
!
                    CALL RE_ALLOC2(QRL,IONE,IFIVE,IONE,IAXRL,IFIVE,IXXX,&
     &                             IERR)
!
                    IF(IERR.NE.0)THEN
                      WRITE(MW0,*)'CAFLGL0: RE-ALLOCATION FAILS FOR QRL'
                      NF=0
                      GO TO 100
                    ENDIF
                    IAXRL=IXXX
                  ENDIF
!
                  IRK=IRK+1
                  IF(IRK.GT.IAXRK)THEN
                    IXXX=7*(IAXRK/5+1)
                    WRITE(MW6,*)'*** CAFLGL0: increasing MAXRK from ',  &
     &                          IAXRK,' to: ',IXXX
                    WRITE(MW0,*)'*** CAFLGL0: increasing MAXRK from ',  &
     &                          IAXRK,' to: ',IXXX
!
                    CALL RE_ALLOC(DRK,IONE,IAXRK,IXXX,IERR)
!
                    IF(IERR.NE.0)THEN
                      WRITE(MW0,*)'CAFLGL0: RE-ALLOCATION FAILS FOR DRK'
                      NF=0
                      GO TO 100
                    ENDIF
!
                    CALL RE_ALLOC(NRK,IONE,IAXRK,IXXX,IERR)
!
                    IF(IERR.NE.0)THEN
                      WRITE(MW0,*)'CAFLGL0: RE-ALLOCATION FAILS FOR NRK'
                      NF=0
                      GO TO 100
                    ENDIF
                    IAXRK=IXXX
                  ENDIF
!
                  DRK(IRK)=C*F
                  NRK(IRK)=IRL
!
                  DO M=1,5
                    QRL(M,IRL)=INT(MRL(M),QP)
                  ENDDO
!
                  IF(NGRP0.NE.0)THEN      !DUPLICATE CORE FOR EACH GROUP
                    DO N=1,NGRP-1
                      IRL=IRL+1   !ASSUME INITIAL ALLOC O.K. FOR CORE...
                      DO M=1,4
                        QRL(M,IRL)=INT(MRL(M)+N*MXBORB,QP)
                      ENDDO
                      QRL(5,IRL)=INT(MRL(5),QP)
                    ENDDO
                  ENDIF
!
                ENDDO
!
              ENDIF
!
! EXCHANGE
!
              IF(.NOT.BEQNL.AND.IXCH.EQ.0)THEN
!
                MRL(2)=K
                MRL(3)=J
!
                ME1=ABS(QL(J)-QL(K))/2                       !MIN LAMBDA
                ME2=(QL(J)+QL(K))/2
                ME2=MIN(ME2,MXLAM)                           !MAX LAMBDA
                ME2=MIN(ME2,ME1+2*NMULT)                      !LIMIT NO.
!
                DO MJ=ME1,ME2,2
!
                  ML=2*MJ
                  DC1=VCC(INT(QL(J),SP),ML,INT(QL(K),SP),IZERO,IZERO,   &
     &                IZERO)
                  G=-G0*DC1*DC1/(QL(K)+1)
!                write(mw6,*)ql(j),2*mj,ql(k),'  g=',g
!
                  IRL=IRL+1
                  IF(IRL.GT.IAXRL)THEN
                    IXXX=7*(IAXRL/5+1)
                    WRITE(MW6,*)'*** CAFLGL0: increasing MAXRL from ',  &
     &                          IAXRL,' to: ',IXXX
                    WRITE(MW0,*)'*** CAFLGL0: increasing MAXRL from ',  &
     &                          IAXRL,' to: ',IXXX
!
                    CALL RE_ALLOC2(QRL,IONE,IFIVE,IONE,IAXRL,IFIVE,IXXX,&
     &                             IERR)
!
                    IF(IERR.NE.0)THEN
                      WRITE(MW0,*)'CAFLGL0: RE-ALLOCATION FAILS FOR QRL'
                      NF=0
                      GO TO 100
                    ENDIF
                    IAXRL=IXXX
                  ENDIF
!
                  IRK=IRK+1
                  IF(IRK.GT.IAXRK)THEN
                    IXXX=7*(IAXRK/5+1)
                    WRITE(MW6,*)'*** CAFLGL0: increasing MAXRK from ',  &
     &                          IAXRK,' to: ',IXXX
                    WRITE(MW0,*)'*** CAFLGL0: increasing MAXRK from ',  &
     &                          IAXRK,' to: ',IXXX
!
                    CALL RE_ALLOC(DRK,IONE,IAXRK,IXXX,IERR)
!
                    IF(IERR.NE.0)THEN
                      WRITE(MW0,*)'CAFLGL0: RE-ALLOCATION FAILS FOR DRK'
                      NF=0
                      GO TO 100
                    ENDIF
!
                    CALL RE_ALLOC(NRK,IONE,IAXRK,IXXX,IERR)
!
                    IF(IERR.NE.0)THEN
                      WRITE(MW0,*)'CAFLGL0: RE-ALLOCATION FAILS FOR NRK'
                      NF=0
                      GO TO 100
                    ENDIF
                    IAXRK=IXXX
                  ENDIF
!
                  DRK(IRK)=C*G
                  NRK(IRK)=IRL
!
                  DO M=1,5
                    QRL(M,IRL)=INT(MRL(M),QP)
                  ENDDO
!
                  IF(NGRP0.NE.0)THEN      !DUPLICATE CORE FOR EACH GROUP
                    DO N=1,NGRP-1
                      IRL=IRL+1   !ASSUME INITIAL ALLOC O.K. FOR CORE...
                      DO M=1,4
                        QRL(M,IRL)=INT(MRL(M)+N*MXBORB,QP)
                      ENDDO
                      QRL(5,IRL)=INT(MRL(5),QP)
                    ENDDO
                  ENDIF
!
                ENDDO
!
              ENDIF
!
            ENDIF
!
          ENDDO
!
        ENDIF
!
      ENDDO
!
!
! ELIMINATE ARGUMENTS OF QRL THAT HAVE BEEN LISTED BEFORE
! IN THE REFERENCE LIST
!
      KP=0
      DO K=IRK0,IRK
!
        JD=INT(NRK(K),SP)
        LP=JD
        IF(JD.GT.IRL00)THEN
          LP=JD-KP
          DO L=1,IRL00
            DO J=1,5
              IF(QRL(J,JD).NE.QRL(J,L))GO TO 20
            ENDDO
            KP=KP+1
            LP=L
            GO TO 50
   20     ENDDO
          DO J=1,5
            QRL(J,LP)=QRL(J,JD)
          ENDDO
        ENDIF
!
   50   NRK(K)=LP
!
      ENDDO
!
      IRL=IRL-KP
!
!-----------------------------------------------------------------------
!
  100 RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE CAFLGL0
!
!                             *******************
!
      SUBROUTINE CAFLGL
!
!-----------------------------------------------------------------------
!
!  SR.CAFLGL EXPANDS THE ENERGY MATRIX ELEMENT <CA! H !CA'>
!  IN TERMS OF 2-BODY RADIAL INTEGRALS AND ANGULAR COEFFICIENTS.
!  IT CALCULATES THE AVERAGE SQUARE ALGEBRAIC COEFFICIENT * NWT/G
!  WHERE NWT IS THE NUMBER OF TRANSITIONS AND G THE STAT WEIGHT
!  OF THE INITIAL QUASI-BOUND STATE.
!  IT IS SPECIFIC FOR BOUND-CONTINUUM INTERACTIONS ONLY.
!
!  IT IS CALLED BY:
!    SR.CALGEB
!
!  IT CALLS:
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!    FN.SJS
!    FN.VCC
!
!  INPUT: NEN(L,K) ORBITAL NUMBERS FOR L=1,2 AND K=1,2 WHERE K IS THE
!         INTERACTION PAIR AND L IS THE CONFIGURATION, KF, KG.
!
!  OUTPUT: COEFFICIENTS DRK(J) AND ARGUMENT-ADRESSES L=NRK(J) STORED
!  SEQUENTIALLY FROM IRK0 ONWARDS; ARGUMENTS QRL(1...5,L)=A,B,C,D,LD
!
!-----------------------------------------------------------------------
!
!!      COMMON /BASIC/NF,KF,KG,NEN11,NEN21,NEN12,NEN22,MGAP(5)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,NEN11=>IBSK4,NEN21=>IBSK5      &
     &              ,NEN12=>IBSK6,NEN22=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9&
     &              ,IBSK10=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL,NAD,IWORD,IPLANT_RL
      USE COMMON_DXRL,   ONLY: IRK,IRK0,IOS,IOS0
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
!
      USE COMMON_NRBAL2, ONLY: MAXLAM,NMULTE,KUTLS
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,IBUFF4
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M8)
!
      DIMENSION Q1(2,2),MM(2,2),MRL(5),NEN(2,2)
!
      POINTER :: MJ11,MJ12,ML
      TARGET :: MM,MRL
!
      MJ11=>MM(1,1)
      MJ12=>MM(1,2)
      ML=>MRL(5)
!
!      EQUIVALENCE (MJ11,MM(1,1)),(MJ12,MM(1,2)),(ML,MRL(5))
!
!-----------------------------------------------------------------------
!
      ITEST4=IBUFF4
      ITEST4=ITEST4+1
      IF(IWORD.EQ.4.AND.ITEST4.LT.IBUFF4)THEN                 !I.E. SP=4
        T=IBUFF4
        T=SQRT(T)
        IPLANT_RL=INT(T,SP)
        IF(IAXRL.GT.IPLANT_RL)THEN          !NEED TO CHECK RE-ALLOCATION
          WRITE(MW0,*)'CAFLGL: I*4/SP TOO SHORT FOR PLANTS'
          WRITE(MW6,*)'CAFLGL: CHANGE TO I*8/EP IN MODULE COMMON_DXRL'
          IRL=-IAXRL
          NF=0
          GO TO 500
        ENDIF
      ELSE
        IPLANT_RL=IBUFF4
      ENDIF
!
      NEN(1,1)=NEN11
      NEN(2,1)=NEN21
      NEN(1,2)=NEN12
      NEN(2,2)=NEN22
!
      MXLAM=ABS(MAXLAM)
      NMULT=NMULTE-1                              !LIMIT NO OF MULIPOLES
!
      IRL00=IRL
!
      IDIR=0                                               !ALLOW DIRECT
      IXCH=0                                              !ALLOW ECHANGE
!t      idir=1
!t      ixch=1
!
      II=QCG(NF,KF)
      IF(QN(II).GE.90)THEN
        KC=1
        KCC=KF
        KB=2
        KBB=KG
      ELSE
        II=QCG(NF,KG)
        KC=2
        KCC=KG
        KB=1
        KBB=KF
      ENDIF
      JJ=NEN(KC,1)
      IF(JJ.EQ.II)JJ=NEN(KC,2)
!
      BEQNL=NEN(1,1).EQ.NEN(1,2).OR.NEN(2,1).EQ.NEN(2,2)
!
! DETERMINE (RESIDUAL) NWT/G, HAVING CANCELLED BINOMIALS ANALYTICALLY.
!
      IF(BEQNL)THEN
        IXCH=1
        L2=NEN(KB,1)
        L3=NEN(KB,2)
        if(l2.ne.l3)stop 'equiv error'
        N2=NEL(L2,KBB)
        L2=QL(L2)
        L1=QL(JJ)
        L4=QL(II)
        N1=NEL(JJ,KCC)-1
!       N4=1                                              !THE CONTINUUM
        MQ=N2*(N2-1)*(2*L1+2-N1)*2*(L2+1)*2*(L4+1)
        TQ=REAL(MQ,WP)
        TQ=TQ/REAL(2*L2+1,WP)
      ELSE
        L2=NEN(KB,1)
        L3=NEN(KB,2)
        N2=NEL(L2,KBB)
        N3=NEL(L3,KBB)
        L1=QL(JJ)
        L4=QL(II)
        N1=NEL(JJ,KCC)-1
!       N4=1                                              !THE CONTINUUM
        MQ=N2*N3*(2*L1+2-N1)*2*(L4+1)
        TQ=REAL(MQ,WP)
      ENDIF
!
      TQ=TQ/DFOUR                                         !RYD TO A.U.
!
      DO L=1,2              ! KF=1, KG=2
        DO K=1,2            ! PAIR 1, PAIR 2
          LP=NEN(L,K)
          MM(L,K)=INT(QL(LP),SP)
          Q1(L,K)=INT(LP,QP)
        ENDDO
      ENDDO
!
! DIRECT
!
      KP=0
!
! EQU  MJ11=Q2(1,1)
! EQU  MJ12=Q2(1,2)
!
      ID2=IRK
      ID1=ID2+1
!
      IF(IDIR.EQ.1)GO TO 400                                  !NO DIRECT
!
! EXCHANGE RE-ENTRY POINT
!
  100 CONTINUE
!
      MJ21=MM(2,KP+1)
      MJ22=MM(2,2-KP)
!
! MU=MAX LAM
      MU=MIN(MJ11+MJ21,MJ12+MJ22,ITWO*MXLAM)
!
! ML=MIN LAM
      ML=MAX(ABS(MJ11-MJ21),ABS(MJ12-MJ22))
!
! LIMIT NUMBER
      MU=MIN(MU,ML+IFOUR*NMULT)
!
      IF(ML.GT.MU)GO TO 400
!
! REORDER A,B,C,D IN AS MUCH FALLING ORDER AS SYMMETRY ALLOWS FOR
!
      L=0
      K=0
      IF(Q1(2,2-KP).GT.Q1(1,2))K=2                       !FO
      I=0
      IF(Q1(2,1+KP).GT.Q1(1,1))I=2                       !FO
      IF(KP.EQ.0)THEN
        I0=I
        K0=K
      ELSE
        I0=0
        K0=0
      ENDIF
!
  200 MRL(1+I+L)=Q1(1,1)*(1-I0)
      MRL(3-I+L)=Q1(2,1+KP)
      MRL(2+K-L)=Q1(1,2)*(1-K0)
      MRL(4-K-L)=Q1(2,2-KP)
      L=1
      IF(MRL(2).GT.MRL(1))GO TO 200                      !FO
!
! LAMBDA RE-ENTRY POINT
!
  300 CONTINUE
!
      DVC=VCC(MJ11,MJ21,ML,IZERO,IZERO,IZERO)
      DDA=DVC*VCC(MJ22,MJ12,ML,IZERO,IZERO,IZERO)
      DDA=DDA/REAL(ML+1,WP)                                    !W3J NORM
!
! STORE COEFFICIENT
!
      LP=IRL+1
      IF(LP.GT.IAXRL)THEN                                     !GO TO 999
        IXXX=7*(IAXRL/5+1)
        WRITE(MW6,*)'*** CAFLGL: increasing MAXRL from ',IAXRL,' to: ', &
     &              IXXX
        WRITE(MW0,*)'*** CAFLGL: increasing MAXRL from ',IAXRL,' to: ', &
     &              IXXX
!
        CALL RE_ALLOC2(QRL,IONE,IFIVE,IONE,IAXRL,IFIVE,IXXX,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'CAFLGL: RE-ALLOCATION FAILS FOR QRL'
          NF=0
          GO TO 500
        ENDIF
        IAXRL=IXXX
        IF(IAXRL.GT.IPLANT_RL)THEN
          WRITE(MW0,*)'CAFLGL: I*4/SP TOO SHORT FOR PLANTS'
          WRITE(MW6,*)'CAFLGL: CHANGE TO I*8/EP IN MODULE COMMON_DXRL'
          IRL=-IAXRL
          NF=0
          GO TO 500
        ENDIF
      ENDIF
!
      IRL=LP
      DO K=1,5
        QRL(K,LP)=INT(MRL(K),QP)
      ENDDO
!
      IRK=IRK+1
      IF(IRK.GT.IAXRK)THEN                                    !GO TO 999
        IXXX=7*(IAXRK/5+1)
        WRITE(MW6,*)'*** CAFLGL: increasing MAXRK from ',IAXRK,' to: ', &
     &              IXXX
        WRITE(MW0,*)'*** CAFLGL: increasing MAXRK from ',IAXRK,' to: ', &
     &              IXXX
!
        CALL RE_ALLOC(DRK,IONE,IAXRK,IXXX,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'CAFLGL: RE-ALLOCATION FAILS FOR DRK'
          NF=0
          GO TO 500
        ENDIF
!
        CALL RE_ALLOC(NRK,IONE,IAXRK,IXXX,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'CAFLGL: RE-ALLOCATION FAILS FOR NRK'
          NF=0
          GO TO 500
        ENDIF
        IAXRK=IXXX
      ENDIF
!
      NRK(IRK)=LP
      DRK(IRK)=DDA
!
! MOVE TO NEXT CONTRIBUTION
!
      ML=ML+4
      IF(ML.LE.MU)GO TO 300                          !NEXT LAMBDA
!
      IF(KP.EQ.0)ID2=IRK
!
  400 KP=KP+1+IXCH
      IF(KP.EQ.1)GO TO 100                           !EXCHANGE
!
! ELIMINATE ARGUMENTS OF QRL THAT HAVE BEEN LISTED BEFORE
! IN THE REFERENCE LIST
!
      KP=0
      DO K=IRK0,IRK
!
        JD=INT(NRK(K),SP)
        LP=JD
        IF(JD.GT.IRL00)THEN
          LP=JD-KP
          DO L=1,IRL00
            DO J=1,5
              IF(abs(QRL(J,JD)).NE.abs(QRL(J,L)))GO TO 420
            ENDDO
            KP=KP+1
            LP=L
            QRL(3,LP)=QRL(3,JD)
            QRL(4,LP)=QRL(4,JD)
            GO TO 450
  420     ENDDO
          DO J=1,5
            QRL(J,LP)=QRL(J,JD)
          ENDDO
        ENDIF
!
  450   NRK(K)=LP
!
      ENDDO
!
      IRL=IRL-KP
!
! SUM INTERFERENCE
!
      IF(BEQNL)THEN
        IH=2
        IE2=ID2
      ELSE
        IH=1
        IE1=ID2+1
        IE2=IRK
      ENDIF
!
      DO K=ID1,ID2
!
        DDA=DRK(K)
!
        L=INT(NRK(K),SP)
        ML=QRL(5,L)
!
        I0=QRL(3,L)
        IF(I0.LT.0)THEN
          I=2
          QRL(3,L)=-QRL(3,L)
        ELSE
          I=0
        ENDIF
        I1=QRL(1+I,L)
        MRL(1)=QL(I1)
        I3=QRL(3-I,L)
        MRL(3)=QL(I3)
!
        I0=QRL(4,L)
        IF(I0.LT.0)THEN
          I=2
          QRL(4,L)=-QRL(4,L)
        ELSE
          I=0
        ENDIF
        I2=QRL(2+I,L)
        MRL(2)=QL(I2)
        I4=QRL(4-I,L)
        MRL(4)=QL(I4)
!
        IF(BEQNL)IE1=K
        DO KP=IE1,IE2
!
          DDB=DRK(KP)
          LP=INT(NRK(KP),SP)
          MLP=QRL(5,LP)
!
          SJ6=SJS(MRL(1),MRL(3),ML,MRL(2),MRL(4),MLP)
!
          IF(ABS(SJ6).GT.TYNY)THEN
            IRK=IRK+1
            IF(IRK.GT.IAXRK)THEN                              !GO TO 999
              IXXX=7*(IAXRK/5+1)
              WRITE(MW6,*)'*** CAFLGL: increasing MAXRK from ',IAXRK,   &
     &                    ' to: ',IXXX
              WRITE(MW0,*)'*** CAFLGL: increasing MAXRK from ',IAXRK,   &
     &                    ' to: ',IXXX
!
              CALL RE_ALLOC(DRK,IONE,IAXRK,IXXX,IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)'CAFLGL: RE-ALLOCATION FAILS FOR DRK'
                NF=0
                GO TO 500
              ENDIF
!
              CALL RE_ALLOC(NRK,IONE,IAXRK,IXXX,IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)'CAFLGL: RE-ALLOCATION FAILS FOR NRK'
                NF=0
                GO TO 500
              ENDIF
              IAXRK=IXXX
            ENDIF
!
            NRK(IRK)=-(IPLANT_RL*L+LP)                            !MAXRL
!
            IF(K.EQ.KP)SJ6=SJ6/REAL(IH,WP)
            DRK(IRK)=-DDA*DDB*SJ6*TQ*(1-MOD(ABS((ML-MLP)),IFOUR))
!
            if(beqnl)then
              isgn=1-2*mod(abs((ml-mlp)/2),itwo)   !(-1)**((ml-mlp)/2)
              if(isgn.lt.0)write(mw0,*)'multipole mixup?',k,kp
            endif
!
          else
            if(sj6.eq.dzero)then !cancellation error, since triangles ok
              write(mw6,*)"sjs=zero:",MRL(1),MRL(3),ML,MRL(2),MRL(4),MLP
! now just drop
!              nf=-1
!              go to 999
            else
              write(mw6,*)"sjs=",sj6,MRL(1),MRL(3),ML,MRL(2),MRL(4),MLP
! drop
            endif
          ENDIF
!
        ENDDO
      ENDDO
!
! FINALIZE DIRECT & EXCHANGE
!
      DO K=ID1,ID2
        DDA=DRK(K)
        L=INT(NRK(K),SP)
        ML=QRL(5,L)
        DRK(K)=TQ*DDA*DDA/REAL(ML+1,WP)
      ENDDO
!
      IF(IXCH.EQ.0)THEN
        DO KP=IE1,IE2
          DDB=DRK(KP)
          LP=INT(NRK(KP),SP)
          MLP=QRL(5,LP)
          DRK(KP)=TQ*DDB*DDB/REAL(MLP+1,WP)
        ENDDO
      ENDIF
!
!-----------------------------------------------------------------------
!
  500 RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE CAFLGL
!
!                             *******************
!
      SUBROUTINE CAFLGLX
!
!-----------------------------------------------------------------------
!
!  SR.CAFLGLX EXPANDS THE HAMILTONIAN MATRIX ELEMENT <CA! H !CA'>
!  IN TERMS OF 2-BODY RADIAL INTEGRALS AND ANGULAR COEFFICIENTS.
!  IT CALCULATES THE AVERAGE SQUARE ALGEBRAIC COEFFICIENT.
!
!  IT IS CALLED BY:
!    SR.CALGX
!
!  IT CALLS:
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!    FN.SJS
!    FN.VCC
!
!  INPUT: NEN(L,K) ORBITAL NUMBERS FOR L=1,2 AND K=1,2 WHERE K IS THE
!         INTERACTION PAIR AND L IS THE CONFIGURATION, KF, KG.
!
!  OUTPUT: COEFFICIENTS DRK(J) AND ARGUMENT-ADRESSES L=NRK(J) STORED
!  SEQUENTIALLY FROM IRK0 ONWARDS; ARGUMENTS QRL(1...5,L)=A,B,C,D,LD
!
!-----------------------------------------------------------------------
!
!!      COMMON /BASIC/NF,KF,KG,NEN11,NEN21,NEN12,NEN22,MGAP(2),LI,LF,NGP
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,NEN11=>IBSK4,NEN21=>IBSK5      &
     &              ,NEN12=>IBSK6,NEN22=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9&
     &              ,LI=>IBSK10,LF=>IBSK11,IBSK12=>IBSK12
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL,NAD,IWORD,IPLANT_RL
      USE COMMON_DXRL,   ONLY: IRK,IRK0,IOS,IOS0
!
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,INAST0=>NASTB                            &
     &                        ,INASTJ0=>NASTJB,LFACT,JFACT              &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
!T      USE COMMON_NRBDWX, ONLY: MAXLX0
      USE COMMON_NRBDW1, ONLY: MXORB,ma0,mb0
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,IBUFF4
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M8)
!
      INTEGER(SP) Q1(2,2),Q2(2,2)
!
      DIMENSION MRL(5)
!
      POINTER :: MJ11,MJ12,ML
      TARGET :: Q2,MRL
!
      MJ11=>Q2(1,1)
      MJ12=>Q2(1,2)
      ML=>MRL(5)
!
!      EQUIVALENCE (MJ11,Q2(1,1)),(MJ12,Q2(1,2)),(ML,MRL(5))
!
!-----------------------------------------------------------------------
!
!t      if(maxlx.ne.maxlx0)stop 'caflglx: maxlx...'
!
      ITEST4=IBUFF4
      ITEST4=ITEST4+1
      IF(IWORD.EQ.4.AND.ITEST4.LT.IBUFF4)THEN
        T=IBUFF4
        T=SQRT(T)
        IPLANT_RL=INT(T,SP)                                !NOT IF SP=EP
        IF(IAXRL.GT.IPLANT_RL)THEN          !NEED TO CHECK RE-ALLOCATION
          WRITE(MW0,*)'CAFLGLX: I*4/SP TOO SHORT FOR PLANTS'
          WRITE(MW6,*)'CAFLGLX: CHANGE TO I*8/EP IN MODULE COMMON_DXRL'
          IRL=-IAXRL
          NF=0
          GO TO 500
        ENDIF
      ELSE
        IPLANT_RL=IBUFF4
      ENDIF
!
      NMULT=NMULTX-1                           !LIMIT NO OF MULIPOLES
!
      IRL00=IRL
!
      MPOSC=MXORB+(LCONDW+1)/2                 !INIT CONT POINTER
!
! SET-UP INTERACTING PAIRS
!
      I=NEN12                                  !BOUND ORB IN KF
      Q1(1,2)=I
      Q2(1,2)=QL(I)
      I=NEN22                                  !BOUND ORB IN KG
      Q1(2,2)=I
      Q2(2,2)=QL(I)
      I=MPOSC                                  !CONT ON KF
      Q1(1,1)=I
      Q2(1,1)=LI
      QL(I)=INT(LI,QP)                         !FOR INTERFERENCE
      Q2(2,1)=LF
      I=(LF-LI)/2+MPOSC                        !CONT ON KG
      Q1(2,1)=I
      QL(I)=INT(LF,QP)                         !FOR INTERFERENCE
!
      mtl=li
      MQ=(LI+1)*(LF+1)                         !CONT. WEIGHT
      TQ=REAL(MQ,WP)
!
!      TQ=TQ/DFOUR                              !RYD TO A.U.
!
! FLAG REQUIREMENT FOR DIRECT AND EXCHANGE
!
      IDIR=0                                   !ALLOW DIRECT
      IXCH=0                                   !ALLOW EXCHANGE
      IF(MTL.GT.2*MAXLX)IXCH=1                 !NO EXCHANGE
!t      idir=1
!t      ixch=1
!
      IF(IDIR+IXCH.EQ.2)GO TO 500              !NULL
!
! DIRECT
!
      KP=0
!
! EQU  MJ11=Q2(1,1)
! EQU  MJ12=Q2(1,2)
!
      ID2=IRK
      ID1=ID2+1
!
      IF(IDIR.EQ.1)GO TO 400                   !NO DIRECT
!
      MXLAM=ABS(MXLAMX)                       !RESTRICT DIRECT LAMBDA
!
! EXCHANGE RE-ENTRY POINT
!
  100 CONTINUE
!
      MJ21=Q2(2,KP+1)
      MJ22=Q2(2,2-KP)
!
! MU=MAX LAM
      MU=MIN(MJ11+MJ21,MJ12+MJ22,ITWO*MXLAM)
!
! ML=MIN LAM
      ML=MAX(ABS(MJ11-MJ21),ABS(MJ12-MJ22))
!
! LIMIT NUMBER
      MU=MIN(MU,ML+IFOUR*NMULT)
!
      IF(ML.GT.MU)GO TO 400
!
! REORDER A,B,C,D IN AS MUCH FALLING ORDER AS SYMMETRY ALLOWS FOR
!
      L=0
      K=0
      IF(Q1(2,2-KP).GT.Q1(1,2))K=2                       !FO
      I=0
      IF(Q1(2,1+KP).GT.Q1(1,1))I=2                       !FO
      IF(KP.EQ.0)THEN
        I0=I
        K0=K
      ELSE
        I0=0
        K0=0
      ENDIF
!
  200 MRL(1+I+L)=Q1(1,1)*(1-I0)
      MRL(3-I+L)=Q1(2,1+KP)
      MRL(2+K-L)=Q1(1,2)*(1-K0)
      MRL(4-K-L)=Q1(2,2-KP)
      L=1
      IF(MRL(2).GT.MRL(1))GO TO 200                      !FO
!
! LAMBDA RE-ENTRY POINT
!
  300 CONTINUE
!
! GET VCA & VCB
!
      DVC=VCC(MJ11,MJ21,ML,IZERO,IZERO,IZERO)
      DDA=DVC*VCC(MJ22,MJ12,ML,IZERO,IZERO,IZERO)
!
      if(abs(dda).gt.tyny)then
!
! STORE COEFFICIENT
!
        LP=IRL+1
        IF(LP.GT.IAXRL)THEN
          IXXX=7*(IAXRL/5+1)
          WRITE(MW6,*)'*** CAFLGLX: increasing MAXRL from ',IAXRL,      &
     &                ' to: ',IXXX
          WRITE(MW0,*)'*** CAFLGLX: increasing MAXRL from ',IAXRL,      &
     &                ' to: ',IXXX
!
          CALL RE_ALLOC2(QRL,IONE,IFIVE,IONE,IAXRL,IFIVE,IXXX,IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'CAFLGLX: RE-ALLOCATION FAILS FOR QRL'
            NF=0
            GO TO 500
          ENDIF
          IAXRL=IXXX
          IF(IAXRL.GT.IPLANT_RL)THEN
            WRITE(MW0,*)'CAFLGLX: I*4/SP TOO SHORT FOR PLANTS'
            WRITE(MW6,*)                                                &
     &                 'CAFLGLX: CHANGE TO I*8/EP IN MODULE COMMON_DXRL'
            IRL=-IAXRL
            NF=0
            GO TO 500
          ENDIF
        ENDIF
!
        IRL=LP
        DO K=1,5
          QRL(K,LP)=INT(MRL(K),QP)
        ENDDO
        if(qrl(2,lp).gt.mxorb)qrl(5,lp)=qrl(5,lp)-INT(mtl,QP)  !exchange
!
!       write(mw6,*)irk,kp,lp,(qrl(k,lp),k=1,5)
!
        IRK=IRK+1
        IF(IRK.GT.IAXRK)THEN
          IXXX=7*(IAXRK/5+1)
          WRITE(MW6,*)'*** CAFLGLX: increasing MAXRK from ',IAXRK,      &
     &                ' to: ',IXXX
          WRITE(MW0,*)'*** CAFLGLX: increasing MAXRK from ',IAXRK,      &
     &                ' to: ',IXXX
!
          CALL RE_ALLOC(DRK,IONE,IAXRK,IXXX,IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'CAFLGLX: RE-ALLOCATION FAILS FOR DRK'
            NF=0
            GO TO 500
          ENDIF
!
          CALL RE_ALLOC(NRK,IONE,IAXRK,IXXX,IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'CAFLGLX: RE-ALLOCATION FAILS FOR NRK'
            NF=0
            GO TO 500
          ENDIF
          IAXRK=IXXX
        ENDIF
!
        NRK(IRK)=LP
        DRK(IRK)=DDA/REAL(ML+1,WP)                             !W3J NORM
!
      else
        if(dda.eq.dzero)then   !cancellation error, since triangles o.k.
          write(mw6,*)"vcc=zero: ",MJ11,MJ21,MJ22,MJ12,'  ',ML
! now just drop
!        nf=-1
!        go to 999
        else
          write(mw6,*)"vcc=",dda,MJ11,MJ21,MJ22,MJ12,'  ',ML
! drop
        endif
      endif
!
! MOVE TO NEXT CONTRIBUTION
!
      ML=ML+4
      IF(ML.LE.MU)GO TO 300                    !NEXT LAMBDA
!
      IF(KP.EQ.0)ID2=IRK
!
  400 KP=KP+1+IXCH
      MXLAM=MXLAMX                             !RESTRICT EXCHANGE LAMBDA
      IF(KP.EQ.1)GO TO 100                     !EXCHANGE
!
! ELIMINATE ARGUMENTS OF QRL THAT HAVE BEEN LISTED BEFORE
! IN THE REFERENCE LIST
!
      KP=0
      DO K=IRK0,IRK
!
        JD=INT(NRK(K),SP)
        LP=JD
        IF(JD.GT.IRL00)THEN
          LP=JD-KP
          DO L=1,IRL00
            DO J=1,4
              IF(abs(QRL(J,JD)).NE.abs(QRL(J,L)))GO TO 420
            ENDDO
            IF(QRL(5,JD).NE.QRL(5,L))GO TO 420
            KP=KP+1
            LP=L
            QRL(3,LP)=QRL(3,JD)
            QRL(4,LP)=QRL(4,JD)
            GO TO 450
  420     ENDDO
          DO J=1,5
            QRL(J,LP)=QRL(J,JD)
          ENDDO
        ENDIF
!
  450   NRK(K)=LP
!
      ENDDO
!
!      call flush(mw6)
!
      IRL=IRL-KP
!
! SUM INTERFERENCE
!
      IE1=ID2+1
      IE2=IRK
!
      DO K=ID1,ID2
!
        DDA=DRK(K)
!
        L=INT(NRK(K),SP)
        ML=QRL(5,L)
!
        I0=QRL(3,L)
        IF(I0.LT.0)THEN
          I=2
          QRL(3,L)=-QRL(3,L)
        ELSE
          I=0
        ENDIF
        I1=QRL(1+I,L)
        MRL(1)=QL(I1)
        I3=QRL(3-I,L)
        MRL(3)=QL(I3)
!
        I0=QRL(4,L)
        IF(I0.LT.0)THEN
          I=2
          QRL(4,L)=-QRL(4,L)
        ELSE
          I=0
        ENDIF
        I2=QRL(2+I,L)
        MRL(2)=QL(I2)
        I4=QRL(4-I,L)
        MRL(4)=QL(I4)
!
        DO KP=IE1,IE2
!
          DDB=DRK(KP)
          LP=INT(NRK(KP),SP)
          MLP=QRL(5,LP)+mtl
!
          SJ6=SJS(MRL(1),MRL(3),ML,MRL(2),MRL(4),MLP)
!
          IF(ABS(SJ6).GT.TYNY)THEN
            IRK=IRK+1
            IF(IRK.GT.IAXRK)THEN
              IXXX=7*(IAXRK/5+1)
              WRITE(MW6,*)'*** CAFLGLX: increasing MAXRK from ',IAXRK,  &
     &                    ' to: ',IXXX
              WRITE(MW0,*)'*** CAFLGLX: increasing MAXRK from ',IAXRK,  &
     &                    ' to: ',IXXX
!
              CALL RE_ALLOC(DRK,IONE,IAXRK,IXXX,IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)'CAFLGLX: RE-ALLOCATION FAILS FOR DRK'
                NF=0
                GO TO 500
              ENDIF
!
              CALL RE_ALLOC(NRK,IONE,IAXRK,IXXX,IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)'CAFLGLX: RE-ALLOCATION FAILS FOR NRK'
                NF=0
                GO TO 500
              ENDIF
              IAXRK=IXXX
            ENDIF
!
            NRK(IRK)=-(IPLANT_RL*L+LP)                            !MAXRL
            DRK(IRK)=-DDA*DDB*SJ6*TQ*(1-MOD(ABS((ML-MLP)),IFOUR))
!
          else
            if(sj6.eq.dzero)then !cancellation error, since triangles ok
              write(mw6,*)"sjs=zero:",MRL(1),MRL(3),ML,MRL(2),MRL(4),MLP
! now just drop
!              nf=-1
!              go to 999
            else
!              write(mw6,*)"sjs=",sj6,MRL(1),MRL(3),ML,MRL(2),MRL(4),MLP
! drop
            endif
          ENDIF
!
        ENDDO
      ENDDO
!
! FINALIZE DIRECT & EXCHANGE
!
      DO K=ID1,ID2
        DDA=DRK(K)
        L=INT(NRK(K),SP)
        ML=QRL(5,L)
        DRK(K)=TQ*DDA*DDA/REAL(ML+1,WP)
      ENDDO
!
      IF(IXCH.EQ.0)THEN
        DO KP=IE1,IE2
          DDB=DRK(KP)
          LP=INT(NRK(KP),SP)
          MLP=QRL(5,LP)+mtl
          DRK(KP)=TQ*DDB*DDB/REAL(MLP+1,WP)
        ENDDO
      ENDIF
!
!-----------------------------------------------------------------------
!
  500 RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE CAFLGLX
!
!                             *******************
!
      SUBROUTINE CALGEB(MAXEL)
!
!-----------------------------------------------------------------------
!
!  SR.CALGEB CALCULATES THE ALGEBRAIC CONFIGURATION AVERAGE COEFFICIENTS
!  FOR EACH NON-VANISHING ELECTROSTATIC INTERACTION MATRIX ELEMENT;
!  ALSO, ELECTRIC MULTIPOLE MATRIX ELEMENTS ARE COMPUTED.
!
!  IT IS CALLED BY:
!    SR.ALGEB
!
!  IT CALLS:
!    SR.CAEKAL
!    SR.CAFLGL0
!    SR.CAFLGL
!    SR.DIMUSE
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!    FN.QBINOM
!
!-----------------------------------------------------------------------
!
      USE COMMON_ALGEB,  ONLY: MPRINT
      USE COMMON_ALGEB,  ONLY: BFOT
!!      COMMON /BASIC/NF,KF,KG,NEN11,NEN21,NEN12,NEN22,MGAP(5)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,NEN11=>IBSK4,NEN21=>IBSK5      &
     &              ,NEN12=>IBSK6,NEN22=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9&
     &              ,IBSK10=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL,NAD,IWORD                &
     &                        ,MAXRK0,MAXRL0
      USE COMMON_DXRL,   ONLY: IRK,IRK0,IOS,IOS0
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
!
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL2, ONLY: MDEL,MXORBR,MPOL00,MPOL0,MPOLE,MPOLX,CODE
      USE COMMON_NRBAL2, ONLY: MAXLAM0,MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBDR,  ONLY: MAXNV
      USE COMMON_NRBDW,  ONLY: IDW,btop
      USE COMMON_NRBIAD, ONLY: IADJ,IADJ8,NP8
      USE COMMON_NRBRN2, ONLY: BINDB,MENGB
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBVAL, ONLY: BRAD,BAUGER
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (MG=-2)
!
      INTEGER(SP) QBINOM                       !DO NOT USE SHORT INTEGER
!
      ALLOCATABLE :: IGRGR(:)
!
!-----------------------------------------------------------------------
!
! INITIALIZE
!
!-----------------------------------------------------------------------
!
      ALLOCATE(IGRGR(NF))
!                                 **** NO LONGER NEEDED???
!      IF(KMAX.GT.IAXCT)THEN
!        WRITE(MW0,*)'*** SR.CALGEB: INCREASE IAXCT BUFFER'
!        WRITE(MW6,*)'*** SR.CALGEB: INCREASE IAXCT BUFFER TO ',KMAX
!!       write(mw0,*),iaxct,iaxtm,iaxcf
!        GO TO 999
!      ENDIF
!      CALL DIMUSE('MAXCT',KMAX)
!
! EX-COMMON/NRBAL1/
      ALLOCATE(MSTAT(KMAX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CALGEB: ALLOCATION FAILS FOR MSTAT'
        NF=0
        GO TO 700
      ENDIF
!
      NP8=KMAX
      IADJ8=NP8*NP8                        !FOR H AND EK
!
      IF(IADJ8.GT.MAXAD)THEN
        IF(MAXAD.GT.0)WRITE(MW6,10040)IADJ8,MAXAD
      ENDIF
!
      NMULT=NMULTE-1                              !LIMIT NO OF MULIPOLES
!
! DETAIL CONFIGS
!
      MAXNV=1
      DO KF=1,KMAX
        KP=0
        NU=0
        IW8=1
        DO K=1,MXORB
          N=NEL(K,KF)
          IF(N.GT.0)THEN
            IF(QN(K).LT.80.AND.QN(K).GT.MAXNV)                          &
     &         MAXNV=MOD(INT(QN(K),SP),I70)                   !I60?
            IF(QN(K).LT.90)IW8=IW8*QBINOM(INT(2*QL(K)+2,SP),N)
                                                              !OMIT CONT
            KP=KP+N*QL(K)
            NI=NU+1
            NU=NU+N
            DO I=NI,NU
              QCG(I,KF)=INT(K,QP)
            ENDDO
            IF(NU.EQ.NF)GO TO 50                            !WE ARE DONE
          ENDIF
        ENDDO
   50   CONTINUE
        MSTAT(KF)=IW8
        QCP(KF)=INT(MOD(KP,IFOUR),QP)                       !PARITY
        WRITE(MW6,10010)KF,0,(QN(QCG(I,KF)),QL(QCG(I,KF))/2,I=1,NF)
      ENDDO
!
! NEED MAX ORBITRAL L FOR VCC STORAGE AND BORN.
!
!
      IF(MENGB.GE.0)THEN
        MXLL=-1                                     !NEED MAX ORBITRAL L
        DO K=1,MXORB
          IF(DEY(K).NE.DZERO.AND.QL(K).GT.MXLL)MXLL=QL(K)
        ENDDO
        MPOLE=MIN(MPOLE,2*MXLL)                   !CAN NOW RESTRICT BORN
      ENDIF
!
!-----------------------------------------------------------------------
!
! FOR MPRINT.GE.0 MPOLE HAS ALREADY BEEN SET (DEFAULT=4), CF ALGEB2
!
!-----------------------------------------------------------------------
!
      IF(MPRINT.EQ.-1.OR.MPRINT.EQ.-4)MPOLE=2
      IF(MPRINT.EQ.MG)MPOLE=-1                                 !FOR INFO
      IF(MPOLE.GT.2*MXBLM)THEN
        IF(MXBLM.GT.0)THEN
          WRITE(MW6,10190)MPOLE/2,MXBLM
!          WRITE(MW0,955)MPOLE/2,MXBLM
        ENDIF
!        IXBLM=MPOLE/2               !NOT NEEDED UNTIL MINIM
      ENDIF
!
      IM=MAX(IONE,MPOLE/2)
!
      CALL DIMUSE('MXBLM',IM)
!
!B      BBORN=MENGB.GE.0            !BORN CODING NOW USED MORE GENERALLY
!B      IF(BBORN)THEN
!!      MPOL0=MPOL00                                              !FLAGX
      IF(MPOL00.GE.0)THEN           !BORN CODING NOW USED MORE GENERALLY
        MXORB2=(MXORB*(MXORB+1))/2
        LHM=MPOLE/4
        IF(BREL)LHM=LHM+1
      ELSE
        MXORB2=1
        LHM=0
      ENDIF
!
!-----------------------------------------------------------------------
!
! EX-COMMON/DXRL/
!
      IAXRK=MAX(MAXRK0,MAXRK,IAXRK)                !USE LARGEST PREVIOUS
!      IAXRK=MAX(MAXRK0,MAXRK)                      !RESET
      IAXRL=MAX(MAXRL0,MAXRL,IAXRL)                !USE LARGEST PREVIOUS
!      IAXRL=MAX(MAXRL0,MAXRL)                      !RESET
!
      ALLOCATE(DRK(IAXRK),QRL(5,IAXRL),NRK(IAXRK),NAD(0:IADJ8),         &
     &         STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CALGEB: ALLOCATION FAILS FOR  DRK,QRL,NRK,NAD'
        NF=0
        RETURN
      ENDIF
!
! EX-COMMON/NRBRN2/
      ALLOCATE(BINDB(MXORB2,0:LHM),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'ALGEB2: ALLOCATION FAILS FOR  BINDB'
        NF=0
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
! CALCULATE SOME (PRODUCTS OF) CLEBSCH-GORDAN COEFFICIENTS:
!
! VCA=C(L1,L2,L,0,0,0)*C(L1,L2,KT,ML1,ML2,MLK)/(L+1)
! VCB=C(L1,L2,L,0,0,0)*C(L1,L2,KT+2,ML1,ML2,MLK)
!
!-----------------------------------------------------------------------
!
      WRITE(MW6,10050)MAXAD,MAXCF,MAXCF,IAXRK,IAXRL,IXDFS
      IF(MAXLAM.NE.MAXLAM0)WRITE(MW6,10060)MAXLAM
!
!-----------------------------------------------------------------------
!
      DO LH=0,LHM
        DO I=1,MXORB2
          BINDB(I,LH)=.FALSE.
        ENDDO
      ENDDO
!
      NE=NF
      IF(NW.GT.0)THEN
        NP8=-1
        NF=0
      ELSE
        NAD(0)=0
        NP8=0
      ENDIF
!
      IOS=0
      JOS=1
      IRK=0
      IRL=0
      BLP=MPRINT.GT.0
!
!-----------------------------------------------------------------------
!
!   CALCULATE THE CONFIGURATION AVERAGE ALGEBRA OF THE ELECTROSTATIC
!   MATRIX BETWEEN TWO CONFIGS THAT DIFFER BY TWO ELECTRON PAIRS & WHICH
!   GIVES RISE TO AUTOIONIZATION. WE ARE NOT INTERESTED IN THE 1-BODY
!   OFF-DIAGONAL BOUND-BOUND (ENERGY) CONTRIBUTIONS NOR BOUND-CONTINUUM
!   AS THE LATTER CANNOT AUTOIONIZE ON ENERGY GROUNDS.
!   THE (DIAGONAL) CONFIGURATION AVERAGE ENERGY IS DETERMINED THOUGH.
!
!-----------------------------------------------------------------------
!
      IF(NF.EQ.1)THEN                    !THERE CAN BE NO TWO-BODY TERMS
        DO KF=1,KMAX
          DO KG=1,KF
            NP8=NP8+1
            NAD(NP8)=0
          ENDDO
        ENDDO
        GO TO 200
      ENDIF
!
      DO KF=1,KMAX                                        !BEGIN KF LOOP
!
        II=IEQ(QCG(NE,KF))
        KCF=0
        IF(QN(II).GE.90)KCF=II                                !CONTINUUM
!
        DO KG=1,KF                                        !BEGIN KG LOOP
!
   60     NP8=NP8+1
!
! FIRST CHECK GLOBAL SWITCHES
!
          IF(KF.EQ.KG)GO TO 100                           !FOR CA ENERGY
          IF(QCP(KF).NE.QCP(KG))GO TO 120               !OPPOSITE PARITY
          IF(.NOT.BAUGER)GO TO 120
!
          II=IEQ(QCG(NF,KG))
          KCG=0
          IF(QN(II).GE.90)KCG=II
!
          IF(KCF+KCG.EQ.0.OR.KCF*KCG.NE.0)GO TO 120      !NOT BOUND-CONT
!
! NOW, FIND NUMBER NK OF ELECTRON PAIRS IN WHICH KF, KG DIFFER
!
          DO M=1,NF
            IGRGR(M)=QCG(M,KG)
          ENDDO
          NK=0
          DO M=1,NF
            ICG=IEQ(QCG(M,KF))
            DO L=1,NF
              IF(IEQ(IGRGR(L)).EQ.ICG)THEN
                IGRGR(L)=0
                GO TO 80
              ENDIF
            ENDDO
            NK=NK+1
!            NEN(1,NK)=QCG(M,KF)
            IF(NK.EQ.1)THEN
              NEN11=QCG(M,KF)
            ELSEIF(NK.EQ.2)THEN
              NEN12=QCG(M,KF)
            ELSE
              GO TO 120                             !THREE PAIRS OR MORE
            ENDIF
   80     ENDDO
!
! SKIP IF ONLY ONE-BODY EXISTS
!
          IF(NK.EQ.1)GO TO 120
!
! IDENITIFY THE PAIRS IN KG
!
          K=0
          DO L=1,NF
            IF(IGRGR(L).NE.0)THEN
              K=K+1
!              NEN(2,K)=QCG(L,KG)
              IF(K.EQ.1)THEN
                NEN21=QCG(L,KG)
              ELSE
                NEN22=QCG(L,KG)
                GO TO 100
              ENDIF
            ENDIF
          ENDDO
          write(mw6,*)'calgeb: should not be here - report to nrb'
          write(mw0,*)'calgeb: should not be here - report to nrb'
!
  100     CONTINUE
!
!          write(mw6,*)'kf, kg=',kf,kg,' 2-body:',nen11,nen12
!     &    ,'  ',nen21,nen22
!
          IRK0=IRK+1
!
          IF(KF.EQ.KG)THEN
            CALL CAFLGL0                             !  <B|H|B>
          ELSE
            CALL CAFLGL                              ! |<B|H|C>|**2
          ENDIF
!
          IF(IRL.GT.IAXRL.or.irl.lt.0)JOS=-1
          IF(IRK.GT.IAXRK)JOS=0
          IF(JOS.LE.0)GO TO 300            !DIMENSION EXCEEDED, BAIL OUT
          IF(NF.LT.0)GO TO 700             !.LT. AS .EQ.0 FLAGS CORE
!
          IF(BLP.AND.IRK.GE.IRK0)THEN
            IF(IRK-IRK0.NE.5)THEN
              WRITE(MW6,10030)NP8,KF,KG,IRK,IRL,                        &
     &                        (NRK(I),DRK(I),I=IRK0,IRK)
            ELSE
              WRITE(MW6,10020)NP8,KF,KG,IRK,IRL,                        &
     &                        (NRK(I),DRK(I),I=IRK0,IRK)
            ENDIF
            WRITE(MW6,10030)
          ENDIF
!
  120     NAD(NP8)=IRK
!
          IF(NF.EQ.0)THEN                             !RESTORE FROM CORE
            NF=NE
            GO TO 60
          ENDIF
!
        ENDDO                                   !END LOOP KG
!
      ENDDO                                     !END LOOP KF
!
  200 CONTINUE
!
      IADJ8=NP8
      IADJ=INT(IADJ8,SP)                               !FOR I*4 BRANCHES
!
      CALL DIMUSE('MAXAD',IADJ)
      CALL DIMUSE('MAXRK',IRK)
      CALL DIMUSE('MAXRL',IRL)
!
  300 IF(.NOT.BLP.OR.JOS.LE.0)THEN
        WRITE(MW6,10030)NP8,KMAX,KMAX,IRK,IRL
        IF(JOS.LT.0)GO TO 1000
        IF(JOS.EQ.0)GO TO 800
        WRITE(MW6,10130)MPRINT
      ELSE
!
! PRINT SLATER INTEGRAL (ADRESS REFERENCE) LIST
!
        IF(IRL.GT.0)THEN
          WRITE(MW6,10140)
          DO L=1,IRL
            WRITE(MW6,10170)L,(QRL(I,L),I=1,5)
          ENDDO
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
!   CALCULATE THE CONFIGURATION AVERAGE ALGEBRA OF THE EK RADIATION
!   MATRIX FOR BOTH BOUND-BOUND AND BOUND-CONTINUUM, THE LATTER ONLY IF
!   PHOTOIONIZATION IS FLAGGED.
!
!-----------------------------------------------------------------------
!
      IOS0=IRK
      IOS=IOS0
      IF(MPRINT.EQ.MG)THEN
        WRITE(MW6,10200)
        GO TO 600
      ENDIF
!
      IF(BLP)WRITE(MW6,10150)
      IF(.NOT.BLP)WRITE(MW6,10160)
!
      IFOTMX=0
      IF(BFOT)IFOTMX=1
      IFOTMN=0
      IF(.NOT.BRAD)IFOTMN=1
!
      JOS=1
!
      DO KF=1,KMAX                                        !BEGIN KF LOOP
        II=IEQ(QCG(NF,KF))
        IFOT1=0
        IF(QN(II).GE.90)IFOT1=1                               !CONTINUUM
!
        DO KG=1,KF-1                                      !BEGIN KG LOOP
!
          NP8=NP8+1
!
! FIRST CHECK GLOBAL SWITCHES
!
          II=IEQ(QCG(NF,KG))
          IFOT2=0
          IF(QN(II).GE.90)IFOT2=1
          IF((IFOT1+IFOT2).GT.IFOTMX)GO TO 360               !NOT WANTED
          IF((IFOT1+IFOT2).LT.IFOTMN)GO TO 360         !DOES NOT CONTRIB
!
! NOW, FIND NUMBER NK OF ELECTRON PAIRS IN WHICH KF, KG DIFFER
!
          DO M=1,NF
            IGRGR(M)=QCG(M,KG)
          ENDDO
          NK=0
          DO M=1,NF
            ICG=IEQ(QCG(M,KF))
            DO L=1,NF
              IF(IEQ(IGRGR(L)).EQ.ICG)THEN
                IGRGR(L)=0
                GO TO 320
              ENDIF
            ENDDO
            NK=NK+1
            IF(NK.GT.1)GO TO 360                      !TWO PAIRS OR MORE
            LD1=QCG(M,KF)
  320     ENDDO
!
! IDENTIFY THE MATCH IN KG AND SEE IF ONE-BODY EXISTS
!
          DO L=1,NF
            IF(IGRGR(L).NE.0)THEN
              LD2=QCG(L,KG)
              GO TO 340
            ENDIF
          ENDDO
          write(mw6,*)'calgeb: should not be here - report to nrb'
          write(mw0,*)'calgeb: should not be here - report to nrb'
  340     CONTINUE
!
          MMIN=MAX(MPOL00,ABS(INT(QL(LD1)-QL(LD2),SP)))      !MIN LAMBDA
          IF(MOD(QCP(KF)+QCP(KG)+MMIN,IFOUR).NE.0)MMIN=MMIN+2
          MMAX=MIN(MPOLE,INT(QL(LD1)+QL(LD2),SP))            !MAX LAMBDA
          IF(MOD(QCP(KF)+QCP(KG)+MMAX,IFOUR).NE.0)MMAX=MMAX-2
          MMAX=MIN(MMAX,MMIN+IFOUR*NMULT)                     !LIMIT NO.
          IF(MMIN.GT.MMAX)GO TO 360
!
!          write(mw6,*)'kf, kg=',kf,kg,' 1-body:',ld1,ld2,'  '
!     &              ,ql(ld1)/2,ql(ld2)/2,mpole/2
!
          NEN11=LD1
          NEN21=LD2
!
          CALL CAEKAL(MMIN,MMAX,JOS)
!
          IF(IOS.GT.IAXRK)GO TO 900
          IF(NF.LE.0)GO TO 1200
!
  360     CONTINUE
!
          NAD(NP8)=IOS
!
        ENDDO                                   !END LOOP KG
!
      ENDDO                                     !END LOOP KF
!
      CALL DIMUSE('MAXRK',IOS)
!
      IF(IOS.GE.IOS0)JOS=JOS-1
!
      MPOLE0=MPOLE
      MPOLE=-1
      LHM0=LHM
      IF(BREL)LHM=LHM-1
      DO LH=LHM,0,-1
        I=0
        DO K=1,MXORB
          DO J=1,K
            I=I+1
            IF(BINDB(I,LH))THEN
              MP=ABS(QL(J)-QL(K))/2
              MP=MOD(MP,ITWO)
              M=4*LH+2-2*(1-MP)
!       write(mw6,*)j,k,ql(j)/2,ql(k)/2,m/2
              MPOLE=MAX(M,MPOLE)
              IF(MP.EQ.1)GO TO 400
            ENDIF
          ENDDO
        ENDDO
        IF(MPOLE.GE.0)GO TO 400
      ENDDO
!
  400 CONTINUE
!
      IF(REAL(MPOLE,WP).GE.5*REAL(MPOLE0,WP)/7.OR.                      &
     &   MPOLE0*MXORB2.LT.I100000)GO TO 500
!
      WRITE(MW6,*)'*** CALGEB: decreasing KPOLE from ',MPOLE0/2,' to: ',&
     &            MPOLE/2
      WRITE(MW0,*)'*** CALGEB: decreasing KPOLE from ',MPOLE0/2,' to: ',&
     &            MPOLE/2
!
      LHM=MPOLE/4
      IF(BREL)LHM=LHM+1
!
      CALL RE_ALLOC2(BINDB,IONE,MXORB2,IZERO,LHM0,MXORB2,LHM,IERR)
!
  500 IF(.NOT.BLP)THEN
        WRITE(MW6,10180)JOS,KMAX,KMAX,MPOLE/2,MPOLE/2,IOS
        WRITE(MW6,10130)MPRINT
      ENDIF
!
!-----------------------------------------------------------------------
!
  600 CONTINUE
!
! IF ACTUAL USAGE IS SUFFICIENTLY SMALLER THAN *INITIAL* ALLOCATION,
! THEN REDUCE USAGE TO ACTUAL - FOR SMALL CASES ON SMALL MEMORY MACHINES
!
!-----------------------------------------------------------------------
!
      IXXX=(4*MAXRL)/5
      IF(IRL.LT.IXXX)THEN
!
!       WRITE(MW6,*)'*** CALGEB: decreasing MAXRL from ',IAXRL,' to: '
!                 ,IRL
!       WRITE(MW0,*)'*** CALGEB: decreasing MAXRL from ',IAXRL,' to: '
!                 ,IRL
!
        CALL RE_ALLOC2(QRL,IONE,IFIVE,IONE,IAXRL,IFIVE,IRL,IERR)
!
        IAXRL=IRL
!
      ENDIF
!
      IXXX=(4*MAXRK)/5
      IF(IOS.LT.IXXX)THEN
!
!       WRITE(MW6,*)'*** CALGEB: decreasing MAXRK from ',IAXRK,' to: '
!                 ,IOS
!       WRITE(MW0,*)'*** CALGEB: decreasing MAXRK from ',IAXRK,' to: '
!                 ,IOS
!
        CALL RE_ALLOC(DRK,IONE,IAXRK,IOS,IERR)
!
        CALL RE_ALLOC(NRK,IONE,IAXRK,IOS,IERR)
!
        IAXRK=IOS
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! DUMP
!
      IF(IDW.NE.0)THEN
!
        IF(IUNIT(MRW10).EQ.0)THEN            !CADW PASS FILE, NO RESTART
          OPEN(MRW10,FORM='UNFORMATTED',STATUS='SCRATCH')
          IUNIT(MRW10)=1
        ENDIF
!
        REWIND(MRW10)
!
        WRITE(MRW10)MXORB,NW,NF,MODD,MAXEL,KMAX,NPRINT,MA,MB,IRLX
!
        WRITE(MRW10)((NEL(I,J),I=1,MXORB),J=1,KMAX),                    &
     &              ((NNL(I,J),I=1,NW),J=1,3),                          &
     &              ((QCG(I,J),I=1,MAXEL),J=1,KMAX),(QL(I),I=1,MXORB),  &
     &              (QN(I),I=1,MXORB),(DEY(I),I=1,MXORB),               &
     &              (MSTAT(I),I=1,KMAX),(IEQ(I),I=0,MXORB),             &
     &              (QCP(I),I=1,KMAX)
!
      ENDIF
!
!-----------------------------------------------------------------------
!
  700 CONTINUE
!
      DEALLOCATE(IGRGR)
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
!     E R R O R   M E S S A G E S
!
  800 WRITE(MW6,10070)
      MPOLE=-1
  900 IF(MPOLE.GE.4)WRITE(MW6,10100)
      IF(MPOLE.EQ.2)WRITE(MW6,10080)
      IF(IRL.LE.IAXRL.and.irl.ge.0)GO TO 1100
 1000 if(irl.ge.0)then
        WRITE(MW6,10110)
      else
        WRITE(MW6,10120)
      endif
 1100 IF(MPRINT.EQ.MG-1)GO TO 700
      WRITE(MW6,10090)
!
 1200 NF=-1
      GO TO 700
!
!-----------------------------------------------------------------------
!
10010 FORMAT(//' CONFIGURATION CF=',I4,',',I11,' ON DISK, (N-L)-',      &
     &       'COMBINATIONS  ',12(I4,I3)/64X,12(I4,I3))
10020 FORMAT(I9,3X,2I6,I9,I5,6(I6,F11.6))
10030 FORMAT(I9,3X,2I6,I9,I5,6(I6,F11.6)/(38X,6(I6,F11.6)))
10040 FORMAT('SR.CALGEB: ALLOCATION INCREASES NUMBER OF MATRIX ',       &
     &       ' ELEMENTS IADD =',I12,' .GT. MAXAD=',I12)
10050 FORMAT(//' SLATER COEFFICIENTS  F(A,...)  FOR CONSTRUCTING   ',   &
     &'( KF !  H  ! KG ) = SUM( F(A,...) * R(A,...) );   NCYC=0: COMMON'&
     &,' DIAGONAL CORE TERM'/I9,3X,2I6,I9,I5,' STORAGE',                &
     &' RESTRICTIONS FOR (MAXAD,MAXCF,MAXCF,MAXRK,MAXRL), MXDFS=',      &
     &I4/'     NCYC       KF    KG      MNF  MNR',6(3X,'I(R)  F(A,...)')&
     &)
10060 FORMAT(/' **** SLATER MULTIPOLE EXPANSION LIMITED TO LAMDA=',I3/)
10070 FORMAT(/' SR.CALGEB: *MAXRK TOO SMALL, ARRAYS DRK AND NRK ')
10080 FORMAT(/' SR.CALGEB: *MAXRK TOO SMALL, ARRAYS DRK AND NRK;'/      &
     &   ' MAYBE SUFFICIENT IF NO RADIATIVE RATES (MPRINT=-2) REQUIRED.'&
     &   )
10090 FORMAT(' SR.CALGEB: STORAGE EXCEEDED - CASE SKIPPED')
10100 FORMAT(/' SR.CALGEB: *MAXRK TOO SMALL, ARRAYS DRK AND NRK;'/' ',  &
     &    'MAYBE SUFFICIENT IF NO RADIATIVE RATES (MPRINT=-2) OR DIPOLE'&
     &    ,' ONLY (MPRINT=-1) REQUIRED')
10110 FORMAT(/' SR.CALGEB: *MAXRL TOO SMALL, ARRAYS DRL AND QRL')
10120 FORMAT(/' SR.CALGEB: *MAXRL TOO LARGE FOR INTEGER(SP) POINTER IN '&
     &       ,'NRK:'/12X,'*TRY REDUCING MAXRL TO ACTUAL USAGE,',        &
     &       '*OR USE INTEGER *8 FOR NRK - SEE MODULE COMMON_DXRL'/)
10130 FORMAT(/' *** PRINTOUT OF COEFFICIENTS SUPPRESSED - MPRINT',      &
     &       '(MODULO 5)=',I2/)
10140 FORMAT(/' I(R)  R(  A,  B,   C,  D,  2LBD )=SLATER-INTEGRALS',7X, &
     &       'A,B,C,D=1,2,3,..15: 1S,2S,2P,..5G-ORBITAL',9X,            &
     &       'REFERENCE LIST')
10150 FORMAT(' IOSC     KF  KG,   B   D,   MNF,    <CA!CK!CAP>   K')
10160 FORMAT('  IOSC    KF    KG    B   D      MNF')
10170 FORMAT(I5,2X,2(I5,I4),I7,F13.5,2F19.5,6X,2I4,5X,'E',I1,I6)
10180 FORMAT(I6,I6,I6,I5,I4,I9)
10190 FORMAT(//'SR.CALGEB: ALLOCATION INCREASES MAX 2K-POLE ',          &
     &       'RADIATION IXBLM =',I3,' .GT. MXBLM =',I3)
10200 FORMAT(/' SR.CALGEB: RADIATIVE CALCULATIONS SKIPPED'/12X,30('*'))
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE CALGEB
!
!                             *******************
!
      SUBROUTINE CALGX(KACT,MXCF)
!
!-----------------------------------------------------------------------
!
!  SR.CALGX CALCULATES THE ALGEBRAIC CONFIGURATION AVERAGE COEFFICIENTS
!  FOR EACH NON-VANISHING ELECTROSTATIC INTERACTION MATRIX ELEMENT;
!
!  IT IS CALLED BY:
!    SR.ALGX
!
!  IT CALLS:
!    SR.CAFLGLX
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam                            !par
!
      USE COMMON_ALGEB,  ONLY: MPRINT
!!      COMMON /BASIC/NF,KF,KG,NEN11,NEN21,NEN12,NEN22,MGAP(2),LI,LF,NGP
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,NEN11=>IBSK4,NEN21=>IBSK5      &
     &              ,NEN12=>IBSK6,NEN22=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9&
     &              ,LI=>IBSK10,LF=>IBSK11,IBSK12=>IBSK12
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL,NAD,IRLAST,IWORD         &
     &                        ,MAXRK0,MAXRL0
      USE COMMON_DXRL,   ONLY: IRK,IRK0,IOS,IOS0
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
!
      use common_misc,   only: ione1,ione0
      use common_misc,   only: iw,iwp,btime,btimex
!
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
      USE COMMON_NRBIAD, ONLY: IADD
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION KACT(MXCF,*)
!
!-----------------------------------------------------------------------
!
      if(btimex)then
!par      if(iam.ge.0)then                                          !par
!par        write(iw,*)'Starting proc',iam,' for calgx '            !par
!par      else                                                      !par
        write(iw,*)'Starting calgx'
!par      endif                                                     !par
        call nrb_time(timei)
        time0=timei
      endif
!
!-----------------------------------------------------------------------
!
! EX-COMMON/DXRL/
!
!      IAXRK=MAX(MAXRK0,MAXRK,IAXRK)               !USE LARGEST PREVIOUS
      IAXRK=MAX(MAXRK0,MAXRK)                     !RESET
!      IAXRL=MAX(MAXRL0,MAXRL,IAXRL)               !USE LARGEST PREVIOUS
      IAXRL=MAX(MAXRL0,MAXRL)                     !RESET
      IL=ABS(MAXLT)
!
      ALLOCATE(DRK(IAXRK),QRL(5,IAXRL),NRK(IAXRK),NAD(0:IADD),          &
     &         IRLAST(0:IL),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CALGX: ALLOCATION FAILS FOR  DRK,QRL,NRK,NAD'
        GO TO 700
      ENDIF
!
      IRLAST=0                                                  !INITIAL
!
!-----------------------------------------------------------------------
!
      WRITE(MW6,10030)MAXAD,MAXCF,MAXCF,IAXRK,IAXRL,MXDFS
!
!-----------------------------------------------------------------------
!
      NF1=NF+1                                       !CONTINUUM LOCATION
!
      NEN11=NF1                                !CURRENTLY, NOT NECESSARY
      NEN21=NF1                                    !TO SPECIFY - ASSUMED
!
      NAD(0)=0
      NCOR=0
!
      IOS=0
      JOS=1
      IRK=0
      IRL=0
!
      BLP=MPRINT.GT.0
!
!-----------------------------------------------------------------------
! LOOP OVER TOTAL SYMMETRIES
!-----------------------------------------------------------------------
!
      DO IX=1,INAST
!
        IL=LSPI(IX)
        MTL=IL+IL
        LI=MTL                   !ASSIGN ALGEBRAIC INITIAL CONT L FOR CA
!
!-----------------------------------------------------------------------
!
!   CALCULATE THE CONFIGURATION AVERAGE ALGEBRA OF THE ELECTROSTATIC
!   MATRIX BETWEEN TWO TARGET CONFIGS THAT DIFFER BY ONE ELECTRON PAIR
!   FOR ELECTRON-IMPACT EXCITATION. CURRENTLY, WE ARE NOT INTERESTED IN
!   ELASTIC TRANSITIONS.
!
!-----------------------------------------------------------------------
!
!        lcon0=4*((nmultx-1)/2)                                   !local
!
        DO KF=1+ione1,KMAX                                !BEGIN KF LOOP
!
          DO KG=1,KF-ione1                                !BEGIN KG LOOP
!
            IF(KACT(KG,KF).LT.0)GO TO 20
!
            L1=KACT(KF,KG)
            NEN12=L1
            L1=QL(L1)
            L2=KACT(KG,KF)
            NEN22=L2
            L2=QL(L2)
!
            L12M=ABS(L1-L2)
            L12=L1+L2
!
            LCON=L12
   10       LMIN=MTL-LCON
            IF(LMIN.LT.0)THEN                  !EFFECTIVE MULTIPOLE LOOP
              LCON=LCON-IFOUR
              IF(LCON.GE.L12M)GO TO 10
              LMIN=ABS(MTL-L12M)
            ENDIF
!
            LCON=MIN(L12,LCONDW-1)                               !GLOBAL
!            lcon0=3*abs(l1-l2)                                  !local
!            if(l12m.eq.2)lcon=min(lcon,14)                      !dipole
!
            MT=MTL-LCON
            IF(LMIN.LT.MT)THEN
              LMIN=MT
              IF(MOD(L12/2,ITWO).NE.MOD(LCON/2,ITWO))LMIN=LMIN+2  !ALIGN
            ENDIF
!
            LMAX=MTL+L12
            MT=MTL
!            MT=MAX(MT,LMIN)   !NEED MEMORY REPOINTED AS ACCESSES>LCONDW
            MT=MT+LCON
            IF(LMAX.GT.MT)THEN
              LMAX=MT
              IF(MOD(LMIN/2,ITWO).NE.MOD(LMAX/2,ITWO))LMAX=LMAX-2 !ALIGN
            ENDIF
!
            IF(LMAX.LT.LMIN)GO TO 20
!
            DO LF=LMIN,LMAX,4          !LOOP OVER ALGEBRAIC FINAL CONT L
!
!          write(mw6,*)'kf, kg=',kf,kg,' 2-body:',nen11,nen12
!     &    ,'  ',nen21,nen22
!
              IRK0=IRK+1
!
              CALL CAFLGLX
!
              NCOR=NCOR+1
!
              IF(IRL.GT.IAXRL.or.irl.lt.0)JOS=-1
              IF(IRK.GT.IAXRK)JOS=0
              IF(JOS.LE.0)GO TO 100            !DIMEN EXCEEDED, BAIL OUT
              IF(NF.LE.0)GO TO 200
!
!        write(mw6,*)'cf=',kf,kg,li/2,lf/2
              IF(BLP.AND.IRK.GE.IRK0)THEN
                IF(IRK-IRK0.NE.5)THEN
                  WRITE(MW6,10020)NCOR,li/2,lf/2,KF,KG,IRK,IRL,         &
     &                            (NRK(I),DRK(I),I=IRK0,IRK)
                ELSE
                  WRITE(MW6,10010)NCOR,li/2,lf/2,KF,KG,IRK,IRL,         &
     &                            (NRK(I),DRK(I),I=IRK0,IRK)
                ENDIF
                WRITE(MW6,10020)
              ENDIF
!
              NAD(NCOR)=IRK                       !ONLY FLAG INTERACTING
!
            ENDDO                                 !END LOOP OVER FINAL L
!
   20       CONTINUE
!
          ENDDO                                   !END LOOP KG
!
        ENDDO                                     !END LOOP KF
!
        IRLAST(IL)=IRL                         !POINT TO END FOR THIS IL
!
      ENDDO                             !END LOOP OVER INITIAL L
!
! RESULTS
!
      IF(IADD.NE.NCOR)THEN
        WRITE(MW6,*)'SR.CALGX: GLOBAL INDEX ERROR:',IADD,NCOR      !test
        GO TO 600
      ENDIF
!      write(mw0,*)iadd
!      IADD=NCOR
!
      CALL DIMUSE('MAXAD',IADD)
      CALL DIMUSE('MAXRK',IRK)
      CALL DIMUSE('MAXRL',IRL)
!
  100 IF(.NOT.BLP.OR.JOS.LE.0)THEN
        WRITE(MW6,10020)NCOR,-1,-1,KMAX,KMAX,IRK,IRL
        IF(JOS.LT.0)GO TO 400
        IF(JOS.EQ.0)GO TO 300
        WRITE(MW6,10080)MPRINT
      ELSE
!
! PRINT SLATER INTEGRAL (ADRESS REFERENCE) LIST
!
        IF(IRL.GT.0)THEN
          WRITE(MW6,10090)
          DO L=1,IRL
            WRITE(MW6,10100)L,(QRL(I,L),I=1,5)
          ENDDO
        ENDIF
      ENDIF
!
  200 CONTINUE
!
! IF ACTUAL USAGE IS SUFFICIENTLY SMALLER THAN *INITIAL* ALLOCATION,
! THEN REDUCE USAGE TO ACTUAL - FOR SMALL CASES ON SMALL MEMORY MACHINES
!
      IXXX=(4*MAXRL)/5
      IF(IRL.LT.IXXX)THEN
!
!        WRITE(MW6,*)'*** CALGX: decreasing MAXRL from ',IAXRL,' to: '
!                  ,IRL
!        WRITE(MW0,*)'*** CALGX: decreasing MAXRL from ',IAXRL,' to: '
!                  ,IRL
!
        CALL RE_ALLOC2(QRL,IONE,IFIVE,IONE,IAXRL,IFIVE,IRL,IERR)
!
        IAXRL=IRL
!
      ENDIF
!
      IXXX=(4*MAXRK)/5
      IF(IRK.LT.IXXX)THEN
!
!        WRITE(MW6,*)'*** CALGX: decreasing MAXRK from ',IAXRK,' to: '
!                  ,IRK
!        WRITE(MW0,*)'*** CALGX: decreasing MAXRK from ',IAXRK,' to: '
!                  ,IRK
!
        CALL RE_ALLOC(DRK,IONE,IAXRK,IRK,IERR)
!
        CALL RE_ALLOC(NRK,IONE,IAXRK,IRK,IERR)
!
        IAXRK=IRK
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      if(btimex)then
        call nrb_time(timef)
        times=timef-time0
!par      if(iam.ge.0)then                                          !par
!par        write(iw,*)'Ending proc',iam,' for calgx:'              !par&
!par     &           ,' time=',nint(times),'sec'                    !par&
!par     &             ,nint(times/60),'min'                        !par
!par        call flush(iw)                                          !par
!par      else                                                      !par
        write(iw,*)'Ending calgx: time=',nint(times),'sec,     ',       &
     &             nint(times/60),'min'
!par      endif                                                     !par
      endif
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
!     E R R O R   M E S S A G E S
!
  300 WRITE(MW6,10040)
      IF(IRL.LE.IAXRL.and.irl.ge.0)GO TO 500
  400 if(irl.ge.0)then
        WRITE(MW6,10060)
      else
        WRITE(MW6,10070)
      endif
  500 WRITE(MW6,10050)
!
  600 NF=-1
      GO TO 200
!
  700 NF=0
      GO TO 200
!
!-----------------------------------------------------------------------
!
!  119 FORMAT(I9,3X, 2I6, I9,I5, 6(I6,F11.6))
10010 FORMAT(I7,2X,2I3,1X,2I5,I7,I5,6(I6,F11.6))
10020 FORMAT(I7,2X,2I3,1X,2I5,I7,I5,6(I6,F11.6)/(38X,6(I6,F11.6)))
10030 FORMAT(//' SLATER COEFFICIENTS  F(A,...)  FOR CONSTRUCTING   ',   &
     &       '( KF !  H  ! KG ) = SUM( F(A,...) * R(A,...) )'/I7,9X,2I5,&
     &       I7,I5,1X,                                                  &
     &'STORAGE RESTRICTIONS FOR (MAXAD,MAXCF,MAXCF,MAXRK,MAXRL), MXDFS='&
     &,I3/'   NCYC   LF LG    KF   KG    MNF  MNR',                     &
     &6(3X,'I(R)  F(A,...)'))
10040 FORMAT(/' SR.CALGX: *MAXRK TOO SMALL, ARRAYS DRK AND NRK ')
10050 FORMAT(' SR.CALGX: STORAGE EXCEEDED - CASE SKIPPED')
10060 FORMAT(/' SR.CALGX: *MAXRL TOO SMALL, ARRAYS DRL AND QRL')
10070 FORMAT(/' SR.CALGX: *MAXRL TOO LARGE FOR INTEGER(SP) POINTER IN ',&
     &       'NRK:'/12X,'*TRY REDUCING MAXRL TO ACTUAL USAGE,',         &
     &       '*OR USE INTEGER *8 FOR NRK - SEE MODULE COMMON_DXRL'/)
10080 FORMAT(/' *** PRINTOUT OF COEFFICIENTS SUPPRESSED - MPRINT',      &
     &       '(MODULO 5)=',I2/)
10090 FORMAT(/' I(R)  R(  A,  B,   C,  D,  2LBD )=SLATER-INTEGRALS ',   &
     &       ' REFERENCE LIST  (EXCHANGE LAMBDA = LBD + LTOT)')
10100 FORMAT(I5,2X,2(I5,I4),I7)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE CALGX
!
!                             *******************
!
      SUBROUTINE CALGX0
!
!-----------------------------------------------------------------------
!
!  SR.CALGX0 RECOVERS TARGET INFO AND ENERGIES.
!
!  IT IS CALLED BY:
!    SR.ALGX
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
!
      USE COMMON_NRBAL0, ONLY: IRET0,LORIG,LMIN,MPRNT0,MOD0,MSTRT0,BPASS&
     &                        ,MLIT
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,INAST0=>NASTB,MINLTB,MAXLTB,LSPIB        &
     &                        ,MAXLX,LFACT,LRGLAM,btop
      USE COMMON_NRBDW1, ONLY: MXORB,ma0,mb0,MSTAT
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
      USE COMMON_NRBDW4, ONLY: DSPECE,INDEX,JNDEX,NSPECE,NENERG
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ !NMETAG0<-DUMP
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBORB, ONLY: IEQ
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
! RE-POINT RESTART FILE
!
      REWIND(MRW10)
!
!-----------------------------------------------------------------------
! RECOVER TARGET HEADER INFO FROM ALGEB1 (NOTE: DEY IS JUST ON/OFF HERE)
! N.B. NOT ALL (SCALARS) USED, EX MORE GENERAL RESTART DUMP.
!-----------------------------------------------------------------------
!
      READ(MRW10)MXORB,NW,NF,MODD,MAXEL,KMAX,NPRINT,MA0,MB0,IRLX
!
      MAXEL1=MAXEL+1                   !ADD SPACE FOR CONTINUUM ELECTRON
      IXEL0=MAXEL1
!
      CALL DIMUSE('MXEL0',MAXEL1)
!
! EX-COMMON/CCLSH/
      IAXCL=MAX(IONE,NW)
      ALLOCATE(NNL(IAXCL,3),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CALGX0: ALLOCATION FAILS FOR NNL'
        GO TO 300
      ENDIF
!
! EX-COMMON/DBD2/        !NOT DEY(MXORB) AS NEED MINIM VALUES...SIGH
      ALLOCATE(QCP(KMAX),QCG(IXEL0,KMAX),QL(MXORB),QN(MXORB),DEY(MXORB),&
     &         STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CALGX0: ALLOCATION FAILS FOR QCP,QCG,QL,QN,DEY'
        GO TO 300
      ENDIF
!
! EX-COMMON/MQVC/
      ALLOCATE(NEL(MXORB,KMAX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CALGX0: ALLOCATION FAILS FOR NEL'
        GO TO 300
      ENDIF
!
! EX-COMMON/NRBDW1/
      ALLOCATE(MSTAT(KMAX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CALGX0: ALLOCATION FAILS FOR MSTAT'
        GO TO 300
      ENDIF
!
! EX-COMMON/NRBORB/
      ALLOCATE(IEQ(0:MXORB+1),STAT=IERR)             !+1 FOR POSS STOPOT
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CALGX0: ALLOCATION FAILS FOR IEQ'
        GO TO 300
      ENDIF
!
      READ(MRW10)((NEL(I,J),I=1,MXORB),J=1,KMAX),                       &
     &           ((NNL(I,J),I=1,NW),J=1,3),                             &
     &           ((QCG(I,J),I=1,MAXEL),J=1,KMAX),(QL(I),I=1,MXORB),     &
     &           (QN(I),I=1,MXORB),(DEY(I),I=1,MXORB),                  &
     &           (MSTAT(I),I=1,KMAX),(IEQ(I),I=0,MXORB),                &
     &           (QCP(I),I=1,KMAX)
!
! EX-COMMON/NRBLS/
      INAST=INAST0
      IF(INAST.GT.0)THEN
        ALLOCATE(LSPI(INAST),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'CALGX0: ALLOCATION FAILS FOR LSPI'
          GO TO 300
        ENDIF
        IAXSL=INAST
      ELSE
        IF(.NOT.ALLOCATED(LSPI))THEN
          IAXSL=0
        ELSE                                              !SHOULD NOT BE
          STOP 'CALGX0: LSPI ALREADY ALLOCATED...'
        ENDIF
      ENDIF
!
      DO I=1,INAST
        LSPI(I)=LSPIB(I)         !REPOPULATE WITH SCATTERING SYMMTRIES
      ENDDO
      MINLT=MINLTB
      MAXLT=MAXLTB
!
!-----------------------------------------------------------------------
! N.B. DUMP OF TARGET RADIAL INFO: DPNL, *DEY* ETC IS READ IN SR.RADCX0
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
! RECOVER TARGET CARATE SO WE CAN SET METASTABLE AND CORRELATION ALGEBRA
!-----------------------------------------------------------------------
!
      READ(MRW10,END=100)NMETA                     !NDUM IF WANT NMETA=0
!      NENERG=0
      READ(MRW10)N,KCUT
      BECOR=N.LT.0
      IF(BECOR)N=-N
      NENERG=N
!
! EX-COMMON/NRBDW4/
      ALLOCATE(DSPECE(NENERG),INDEX(NENERG),JNDEX(NENERG),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CALGX0: ALLOCATION FAILS FOR DSPECE,INDEX,JNDEX'
        GO TO 300
      ENDIF
!
      READ(MRW10)(INDEX(I),I=1,NENERG)
      READ(MRW10)(DSPECE(I),I=1,NENERG)                   !RYD NOW !
!
! REDUCE NENERG ENERGIES TO THE NSPECE NON-CORRELATION.
! THIS MAKES IT EASY TO HANDLE INTERSPERSED SPEC/CORR.
!
! ALSO, SET REVERSE INDEX(I), JNDEX(J):
! INDEX MAPS SPEC E.O. I=1,2,3  TO S.O.
! JNDEX MAPS *ALL S.O. I=1,2,3  TO SPEC E.O.
!   FOR CORR S.O. THE FULL E.O. POSITION IS SET. SUBSEQUENTLY, WE ONLY
!   CARE THAT IT HAS BEEN FLAGGED NEGATIVE FOR CORR. THE ACTUAL VALUE
!   IS NOT NEEDED/USED.
!
      NSPECE=0
      DO J=1,NENERG
        I=INDEX(J)
        if(i.lt.0)then
          jndex(-i)=-j
        else
          NSPECE=NSPECE+1
          JNDEX(I)=NSPECE                               !=J IN ORIG E.O.
          INDEX(NSPECE)=I
          DSPECE(NSPECE)=DSPECE(J)
        endif
      ENDDO
! if(nspece.lt.nenerg)then could re-allocate to reduce memory, but small
!
      NMETA=ABS(NMETA)
      NMETA=MIN(NMETA,NSPECE)
!
  100 IF(NENERG.EQ.0)THEN
        IF(NZION.NE.0)THEN                             !SHOULDN'T HAPPEN
          WRITE(MW6,*)'*** SR.CALGX0: MISSING CF TARGET INFO'
          WRITE(MW0,*)'*** SR.CALGX0: MISSING CF TARGET INFO'
          NF=-1
          GO TO 200
        ENDIF
! ELSE JUST AN ALGEBRA RUN
      ENDIF
!
!-----------------------------------------------------------------------
!
  200 CONTINUE
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
  300 NF=0
      GO TO 200
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE CALGX0
!
!                             *******************
!
      SUBROUTINE CARATE(DECORE,DF)
!
!-----------------------------------------------------------------------
!
!  SR.CARATE CALCULATES CA ENERGIES AND DATA FOR ELECTRIC RADIATIVE
!  TRANSITIONS.
!  ALSO CALCULATES AUTOIONIZATION RATES AND PHOTOIONIZATION CROSS
!  SECTIONS - SEE ALSO NOTES IN SR.RADCON.
!
!  N.B. CONTAINS LEGACY OF MORE GENERAL MIXED CODE.
!
!  IT IS CALLED BY:
!    SR.CALCFX
!    SR.MINIM
!
!  IT CALLS:
!    SR.BRNINT
!    SR.DATA_AND_TIME (SYSTEM)
!    SR.LAGINT
!    SR.NRB_TIME
!    FN.QBINOM
!    SR.RKINT
!    SR.HPSRTI
!    SR.SLATR
!
!  IT CONTAINS:
!    FN.ICOL
!    FN.ICOL8
!    FN.IROW
!    SR.SO2NL
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam                            !par
!
      USE COMMON_ALGEB,  ONLY: BFOT
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CACC,   ONLY: ACC
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL,NAD,IPLANT_RL,n8
      USE COMMON_DXRL,   ONLY: IRK,IRK0,IOS,IOS0
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCL0=>INCLUD,JPRINT,JEND
      USE COMMON_INTS,   ONLY: DRL,DOSC,IGAUGE,IXD09,IXD28,IXD29
      USE COMMON_MINIM,  ONLY: MPNCH,KUTCAS,BPRINT
      USE COMMON_MINIM,  ONLY: ECOR1,ECOR2,ECORR,ECORRJ,ESKPL,ESKPH     &
     &                        ,BECOR
      USE COMMON_MINIM,  ONLY: EIONPOT,EIMXLS,EIMXIC                    &
     &                        ,WLG1,WLG2,IWGHT,IWGHT0,IOPTIM            &
     &                        ,JUPMX,JUPMN,JLOWMX,JLOWMN                &
     &                        ,LUPMX,LUPMN,LLOWMX,LLOWMN                &
     &                        ,NMETAR,NMETARJ,NMETAP,NMETAPJ,NRSLMX
      USE COMMON_MISC,   ONLY: IDIAG
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
      USE COMMON_QTG,    ONLY: MTGD,NXLL,NTT,NTG,JTGD,QTGS,QTGL,QTGD    &
     &                        ,NFI,NFK,NFQ
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
      USE COMMON_REL,    ONLY: DMASS,DCD,D2LL
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
      USE COMMON_WEIGHT, ONLY: WGHT,INDEXW
!
      use common_misc,   only: ione1,ione0
      use common_misc,   only: iw,iwp,btime,btimex
      use common_misc,   only: badas
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL2, ONLY: MDEL,MXORBR,MPOL00,MPOL0,MPOLE,MPOLX,CODE
      USE COMMON_NRBAL2, ONLY: MAXLAM0,MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBCAV, ONLY: ECAVX,ECAV,AJUSTX,ICAV
      USE COMMON_NRBDEL, ONLY: ISHFTLS,ISHFTIC,NOBS,NOBSJ,MDELE,MULTS   &
     &                        ,DELELS,DELEIC,DELECF,EFLG0,EFLGJ0        &
     &                        ,TOLB,TOLE
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBDR,  ONLY: IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR
      USE COMMON_NRBDW,  ONLY: IDW,btop
      USE COMMON_NRBDW4, ONLY: DSPECE,INDEX,JNDEX,NSPECE,NENERG
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBIAD, ONLY: IADJ,IADJ8,NP8
      USE COMMON_NRBINT, ONLY: DRLI,DYY,IYY,NRLI,MENG,NREL,NLAG,NLAGP   &
     &                        ,BLAG,BBC2
      USE COMMON_NRBOLP, ONLY: OVLPGR,OVLPCF,IPAIR
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX                     &
     &                        ,MXBORB,MXVORB,MXFORB,NGRP
      USE COMMON_NRBORN, ONLY: BL,OBO,TM2
      USE COMMON_NRBPOT, ONLY: ALFD,RCUT,ALAV,RCAV,IPOLFN
      USE COMMON_NRBQED, ONLY: VPINT,SLFINT,QED
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBRN1, ONLY: SBL,DBL                                  &
     &                        ,MB3,MB4,INDX,INDL,INDK
      USE COMMON_NRBRN2, ONLY: BINDB,MENGB
      USE COMMON_NRBRN3, ONLY: V0,V1,XB,XS,DB0,DB1,OMEGAB               &
     &                        ,MV0,MV1,MINFB,MXNXB,MXNXB1,NLAGB         &
     &                        ,IEXP,XMANT
      USE COMMON_NRBSHF, ONLY: DSHIFT,MSHIFT,KSHIFT,MKMAX,MXEP
      USE COMMON_NRBTAR, ONLY: IGAPE
      USE COMMON_NRBTS1, ONLY: DFOT,DFOSS,PMIN,NFOSS,IPIG,IGAG
      USE COMMON_NRBVAL, ONLY: FACT,IVAL,NNEW,NNOLD,BJUMP,BJUMP2,BRAD   &
     &                        ,BAUGER
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP,IBUFF4
      USE PARAM
      USE UTILITY
      USE CONSTANTS
      USE ADF00, ONLY: BADF00,MSC00,MXCONFH,QCFG0,QCFGX,JZ0,JZX,EXCITE
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (MXLIT=62)
      PARAMETER (MXSTRG=32)           !MAX STRING WRITE, MOD(MXSTRG,4)=0
      PARAMETER (MSTRGH=16)         !SHORT STRING WRITE, MOD(MSTRGH,4)=0
      PARAMETER (MXLAB1=29)                                    !0:MXLAB1
      PARAMETER (MXLAB2=29)                                    !0:MXLAB2
      PARAMETER (MXLEN=200)                                 !CARD LENGTH
      parameter (mxlenx=200)                                !card length
!
      PARAMETER (DKON=1.653656E+17_WP)   !DEIGHT/HBAR
      PARAMETER (C1=DFSC**3/HBAR)
      PARAMETER (C2=2.567895E-18_WP)     !DFOUR*XPI*A0_BOHR**2*DFSC
!      PARAMETER (C3=C2/DTHREE)
!
      PARAMETER (EINF=D1P6)
!
      INTEGER(EP) I8,J8 !,ICOL8  -INTERNAL
!
      INTEGER(SP) QBINOM                       !DO NOT USE SHORT INTEGER
!
      INTEGER QLB,LIT     !HISTORIC DEFAULT KIND TO SYNC WITH POST PROCS
!
      REAL(RP) OMEGA
!
      CHARACTER(LEN=1) BIGL,NUMB,STRING,CLIT,CMBLK1
!OLD  X,SMAL
!HAR  X,LIT,MBLK1  !USE OF CHAR REQUIRES CHANGES TO PP'S FOR UNFORM I/O
      CHARACTER(LEN=2) CELMNT,ELEM
      CHARACTER(LEN=4) MBCOR,MCOR,MBLK,MYRGE,LAB4,CARD4
      CHARACTER(LEN=8) DATE
      character(len=9) orbfmt
      character(len=32) ceiss,cstan
      CHARACTER(LEN=17) F762
      CHARACTER(LEN=29) F713,F761
      character(len=51) f542,f543
      character(len=mxlenx) cardx
      CHARACTER(LEN=MXLEN) CARD
      CHARACTER(LEN=6) FORM,FORM2,FORM3
!
      PARAMETER (FORM2='(60I2)')
      PARAMETER (FORM3='(40I3)')
!
      ALLOCATABLE :: LMX(:),QSB(:,:),QLB(:,:),DG(:)
!
      ALLOCATABLE :: OMR(:),OMC(:),OMEGA(:,:),ITMP(:),DDY(:)
      allocatable :: isorb(:),decorn(:)
!
      ALLOCATABLE :: DENERG(:),IORIG(:)                                 &
     &              ,DWRK(:)                                            &
     &              ,IWRK1(:),IWRK2(:),IWRK3(:),IWRK4(:)
!
      ALLOCATABLE :: DSTRNG(:,:)
      SAVE DSTRNG                                     !LOCAL, BUT FOR DR
!
      allocatable :: ncc0(:),iorb(:)
!
      ALLOCATABLE :: MNAL(:),MXAL(:)
!
      ALLOCATABLE :: KNEW(:),KCLOSE(:),KZERO(:),QCFG(:)
!
      ALLOCATABLE :: DPA(:) !,DP(:)
!
      DIMENSION BIGL(0:MXLAB1),NUMB(0:MXLAB2)                           &
     &         ,STRING(MXSTRG),CLIT(MXLIT),LIT(MXLIT)
!
      DATA CMBLK1/' '/,MBLK/'    '/,MCOR/' COR'/,BSCRO/.FALSE./
!
      DATA CLIT( 1),CLIT( 2),CLIT( 3),CLIT( 4)  /'1','2','3','4'/,      &
     &     CLIT( 5),CLIT( 6),CLIT( 7),CLIT( 8)  /'5','6','7','8'/,      &
     &     CLIT( 9),CLIT(10),CLIT(11),CLIT(12)  /'9','A','B','C'/,      &
     &     CLIT(13),CLIT(14),CLIT(15),CLIT(16)  /'D','E','F','G'/,      &
     &     CLIT(17),CLIT(18),CLIT(19),CLIT(20)  /'H','I','J','K'/,      &
     &     CLIT(21),CLIT(22),CLIT(23),CLIT(24)  /'L','M','N','O'/,      &
     &     CLIT(25),CLIT(26),CLIT(27),CLIT(28)  /'P','Q','R','S'/,      &
     &     CLIT(29),CLIT(30),CLIT(31),CLIT(32)  /'T','U','V','W'/,      &
     &     CLIT(33),CLIT(34),CLIT(35),CLIT(36)  /'X','Y','Z','a'/,      &
     &     CLIT(37),CLIT(38),CLIT(39),CLIT(40)  /'b','c','d','e'/,      &
     &     CLIT(41),CLIT(42),CLIT(43),CLIT(44)  /'f','g','h','i'/,      &
     &     CLIT(45),CLIT(46),CLIT(47),CLIT(48)  /'j','k','l','m'/,      &
     &     CLIT(49),CLIT(50),CLIT(51),CLIT(52)  /'n','o','p','q'/,      &
     &     CLIT(53),CLIT(54),CLIT(55),CLIT(56)  /'r','s','t','u'/,      &
     &     CLIT(57),CLIT(58),CLIT(59),CLIT(60)  /'v','w','x','y'/,      &
     &     CLIT(61),CLIT(62)  /'z','*'/
      DATA (BIGL(I),I=0,MXLAB1)/'S','P','D','F','G','H','I','K','L','M' &
     &                         ,'N','O','P','Q','R','S','T','U','V','W' &
     &                         ,'X','Y','Z','a','b','c','d','e','f','*'/
      DATA (NUMB(I),I=0,MXLAB2)/'0','1','2','3','4','5','6','7','8','9' &
     &                         ,'A','B','C','D','E','F','G','H','I','J' &
     &                         ,'K','L','M','N','O','P','Q','R','S','*'/
!
!-----------------------------------------------------------------------
!      ICOL(ILI,ILF,IONE1)=((ILF-1)*(ILF-2*IONE1))/2+ILI
!      ICOL8(I8,J8,IONE1)=((J8-1)*(J8-2*IONE1))/2+I8
!      IROW(ILI,ILF,IONE1,NENG)=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE1))/2
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!
! THE NAMES HERE ARE NOT NECESSARILY SIGNIFICANT THEY ARE COMMON LEGACY.
!
! LOCAL
      ALLOCATE(DPA(MAXRS),STAT=IERR)                 !,DP(MAXRS)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CARATE: ALLOCATION FAILS FOR DPA' !,DP'
        NF=0
        GO TO 1800
      ENDIF
!
      IF(IEQ(0).NE.0)THEN
        ALLOCATE(ITMP(2*MXORB),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'CARATE: ALLOCATION FAILS FOR ITMP'
          NF=0
          GO TO 1800
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
      BACC=ALLOCATED(ACC)
      BVEL=IXD29.EQ.IXD28*2
      BMVDR=ALLOCATED(DCD)
!      B2LL=ALLOCATED(D2LL)
!
!-----------------------------------------------------------------------
!
! FIX FOR FORTRAN 90 COMPILERS THAT DON'T ALLOW ASSIGNMENT OF CHARACTERS
! TO INTEGER VARIABLES, REQUIRED FOR HISTORIC BACKWARDS COMPATIBILITY
!
      OPEN(80,STATUS='SCRATCH',FORM='FORMATTED')
      WRITE(80,10620)CMBLK1,(CLIT(I),I=1,MXLIT)
      BACKSPACE(80)
      READ(80,10620)MBLK1,(LIT(I),I=1,MXLIT)
      CLOSE(80)
!
! INITIALIZE LOGICALS ETC
!
      BCONT=MODE.EQ.2.OR.MODE.EQ.3                  !FOR BOUND-CONTINUUM
!
      BREL2=ABS(IREL).EQ.2
      BDR=IDR.NE.0
      BBORN=MENGB.GE.0
!
      BFOTJ=.NOT.BFOT.OR..NOT.BLAG
      IF(.NOT.BFOTJ.AND.PMIN.GT.DZERO)IPIG=1
      BELONG=IGAUGE.EQ.0                           !AEK/SEK LENGTH GAUGE
!
      NPRNT5=MOD(NPRINT,IFIVE)
      BPRNT0=BPRINT
      IF(BPRINT)BPRNT0=JPRINT.NE.-3
!
      BORT=MORT.LT.0                              !FOR EXPECTATION PRINT
      TOLB2=TOLB/DTWO                                         !RYD->A.U.
!
      nmeta0=nmeta
!
! RESET INCLUD
!
      INCLUD=MOD(INCL0,I1000000)
      BINCF=IWGHT.LT.0        !.T. INCLUD CF BY ALG ORDER, .F. BY ENERGY
!
! LOCAL
!
      MXVORB0=10                                  !FOR HISTORIC PP READS
      DO K=1,KMAX
        LM=0
        DO J=1,MXORB
          IF(NEL(J,K).GT.0)LM=LM+1
        ENDDO
        MXVORB0=MAX(MXVORB0,LM)
      ENDDO
!
      ALLOCATE(LMX(KMAX),QSB(MXVORB0,KMAX),QLB(MXVORB0,KMAX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CARATE: ALLOCATION FAILS FOR LMX,QSB,QLB'
        NF=0
        GO TO 1800                                               !RETURN
      ENDIF
!
      ALLOCATE(DENERG(KMAX),IWRK2(KMAX),IORIG(KMAX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CARATE: ALLOCATION FAILS FOR DENERG ETC'
        NF=0
        GO TO 1800                                               !RETURN
      ENDIF
!
      ALLOCATE(DWRK(KMAX),IWRK3(KMAX),IWRK4(KMAX),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CARATE: ALLOCATION FAILS FOR DWRK,IWK'
        NF=0
        GO TO 1800                                               !RETURN
      ENDIF
!
! ex-common/nrbtmp/
      allocate(ncc0(mxorb),iorb(0:mxorb),stat=ierr)    !iorb not used...
      if(ierr.ne.0)then
        write(mw0,*)'carate: allocation fails for ncc0,iorb'
        nf=0
        go to 1800
      endif
!pc
!p      ngrp=1
!p      mxborb=0
!p      if(irlx.lt.0)then
!p        ngrp=-irlx/100000             !until /nrborb/ in a module
!p        mxborb=-irlx-100000*ngrp
!p      endif
!
      ngrp1=1
      if(irlx.lt.0)ngrp1=ngrp
!
      allocate(decorn(ngrp1))
!
! SET CHARGES ETC.
!
      NZA=NZION-MION+1
      DZA2=NZA*NZA
      DZA=-NZA
!      DZM=-NZION
      DZ2=NZION-MION
      IF(NZION.EQ.MION)DZ2=DONE
      DZ2=DZ2*DZ2
      TSHFT=MSHIFT+MSHIFT
!
! INITIALIZE FOR NLAG-POINT LAGRANGE INTERPOLATION FORMULA FOR
!  BOUND-CONTINUUM INTEGRALS.
!  NLAG MUST BE AN EVEN NUMBER .GE. 4 . READ IN SRADCON.
!  DEFAULT:   NLAG=6.
!  IF MENG.EQ.1 THEN NO INTERPOLATION (& NLAG NOT IUSED)
!
      NLAG2=NLAG-2
      NP1=1
      NP2=MAX(IONE,NLAG)
      NPH=NP2/2
      BBC1=MENG.LE.NP2
      IF(BBC1)NP2=MENG
!
      IF(BAUGER)THEN
        IF(BLAG)THEN
          ALLOCATE(DDY(MENG))
        ELSE
          ALLOCATE(DDY(1))
          DDY(1)=DONE
        ENDIF
      ENDIF
!
! RE-SCALE ONE-BODY TERMS INVOLVING RYDBERG ORBITAL IN DR OPERATION
!
      IF(BJUMP2)THEN
        DO K=1,MXORB                    !1/N**3 SCALING
          IF(DEY(K).EQ.DZERO)GO TO 50
!         IF(K.LE.ABS(MPSEUD))GO TO 115
          IF(IVAL(K).NE.0)THEN
            TM=NNEW
            IF(KSHIFT.LE.0)TM=TM-SCREEN(K)                  !NEEDS Q.D.
            TN=DZA/TM
            TN=TN*TN                    !COULOMB
            IF(BREL)THEN
              T=DTWO*TM/(QL(K)+1)-DTHREE/DFOUR
              TMV=T*TN*TN               !M-V
              IF(QL(K).EQ.QZERO)THEN        !DARWIN
                TT=dza/TM               !DZM->dza since large n
                TT=TT*TT
                TD=-TT*TT*TM
              ELSE
                TD=DZERO
              ENDIF
              T=(TMV+TD)*DFSC*DFSC
              if(tn+t.lt.dzero)t=dzero  !use non.rel.
              TN=TN+T
            ENDIF
            DSHIFT(K)=TN/DTWO
            TN=NNOLD
            IF(KSHIFT.LE.0)TN=TN-SCREEN(K)                  !NEEDS Q.D.
            TN=TN/TM
            FACT(K)=TN**3
            IN=ICOL(K,K,IZERO)
            DUY(IN)=DUY(IN)*FACT(K)
            DEY(K)=DUY(IN)-DSHIFT(K)
            IF(KSHIFT.GT.0)DSHIFT(K)=DZERO
            IF(QED.LT.QZERO.AND.QN(K).GT.QZERO)THEN
              VPINT(K)=FACT(K)*VPINT(K)
              SLFINT(K)=FACT(K)*SLFINT(K)
            ENDIF
            FACT(K)=SQRT(FACT(K))
          ENDIF
          IF(K.EQ.1)GO TO 50
          I=K-1
          DO J=1,I
            IN=ICOL(J,K,IZERO)
            DUY(IN)=DUY(IN)*FACT(K)*FACT(J)
          ENDDO
          IF(BMVDR.AND.BMVD)THEN
            DO J=1,K
              IF(DEY(J).NE.DZERO.AND.QL(J).EQ.QL(K))THEN
                IN=ICOL(J,K,IZERO)
                DD=FACT(J)*FACT(K)
                DMASS(IN)=DMASS(IN)*DD
                DCD(IN)=DCD(IN)*DD
!                IF(B2LL)D2LL(IN)=D2LL(IN)*DD
              ENDIF
            ENDDO
          ENDIF
   50   ENDDO
        GO TO 200
      ENDIF
!
! DETERMINE CONFIGURATION OVERLAP MATRIX
! (FOR USE WITH RELAXED ORBITALS, IRLX=2 ONLY.)
!
      IF(IRLX.EQ.2)THEN      !DETERMINE OVERLAPS BETWEEN CF'S
!
        ALLOCATE(IWRK1(NF))
!
        KK=0
        DO KF=2,KMAX
          DO KG=1,KF-1
            KK=KK+1
            DO I=1,NF
              IWRK3(I)=QCG(I,KG)
            ENDDO
            K=0
            OVL=DONE
            DO I=1,NF
              DO L=1,NF
                IF(IEQ(IWRK3(L)).EQ.IEQ(QCG(I,KF)))THEN
                  IWRK3(L)=0
                  I1=MIN(QCG(I,KF),QCG(L,KG))
                  I2=MAX(QCG(I,KF),QCG(L,KG))
                  II=((I2-1)*(I2-2))/2+I1
                  OVL=OVL*OVLPGR(II)
                  GO TO 60
                ENDIF
              ENDDO
              K=K+1
              IPAIR(KK)=K
              IF(K.GT.2)GO TO 80
   60       ENDDO
            OVLPCF(KK)=OVL
   80     ENDDO
        ENDDO
!
        DEALLOCATE(IWRK1)
!
        IF(BPRINT)THEN
          WRITE(MW6,10430)(K,K=1,KMAX-1)
          K2=0
          DO KF=2,KMAX
            K1=K2+1
            K2=K2+KF-1
            WRITE(MW6,10420)KF,(OVLPCF(K),K=K1,K2)
          ENDDO
        ENDIF
!
! MULTIPLY ONE-BODY INTEGRALS BY OVERLAPS
!
        DO J=2,MXORB
          KF=IGRCF(J)
          IF(DEY(J).EQ.DZERO.OR.KF.EQ.0)GO TO 150
          DO I=1,J-1
            KG=IGRCF(I)
            IF(DEY(I).EQ.DZERO.OR.KG.EQ.0)GO TO 100
            IF(BJUMP.AND.IVAL(I)+IVAL(J).EQ.0)GO TO 100
            IF(QL(I).NE.QL(J))GO TO 100
            IF(KF.NE.KG)THEN
              K1=MIN(KF,KG)
              K2=MAX(KF,KG)
              KK=((K2-1)*(K2-2))/2+K1
              IF(IPAIR(KK).EQ.1)THEN
                IN=ICOL(I,J,IZERO)
                OVL=OVLPCF(KK)
                DUY(IN)=DUY(IN)*OVL
!                DUY(J,I)=DUY(J,I)*OVL         !NEEDED?
                IF(BMVD)THEN
                  DMASS(IN)=DMASS(IN)*OVL     !DITTO
                  DCD(IN)=DCD(IN)*OVL
!                 IF(B2LL)D2LL(IN)=D2LL(IN)*OVL
                ENDIF
              ENDIF
            ENDIF
  100     ENDDO
  150   ENDDO
!
      ENDIF
!
! GENERATE AND PRINT SOME EXPECTATION VALUES
! (NOT USED SUBSEQUENTLY, SO CAN SKIP IF PRINTING SUPPRESSED.)
!
  200 IF(.NOT.BPRNT0)GO TO 400
!
      IF(MGRP.GE.0)WRITE(MW6,10040)MAXRS
      IF(MGRP.LT.0)WRITE(MW6,10050)MAXRS
      L=MAXRS-2
!
      IF(.NOT.ALLOCATED(DSTRNG))THEN
        ALLOCATE(DSTRNG(6,MXORB),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'CARATE: ALLOCATION FAILS FOR DSTRNG'
          NF=0
          GO TO 1800
        ENDIF
      ENDIF
!
      DO K=1,MXORB
!
        IF(DEY(K).EQ.DZERO)GO TO 300
!       IF(K.LE.ABS(MPSEUD))GO TO 816
        K17=K
        N1=QL(K)/2
        N3=N1
        IF(BORT)N3=K-1
        IF(BJUMP.AND.IVAL(K).EQ.0)GO TO 250
        DO J=1,6
          DSTRNG(J,K)=DZERO
        ENDDO
        IN=ICOL(K,K,IZERO)
        DSTRNG(3,K)=-DUY(IN)
        DSTRNG(1,K)=(DEY(K)+DSTRNG(3,K))*DTWO
        IF(.NOT.BDR)DSTRNG(1,K)=DSTRNG(1,K)+DTWO*DSHIFT(K)
        IF(MODE.LT.6.AND.QN(K).LT.0)GO TO 250    !MODE=1-4, CURRENTLY...
!
        DO J=2,6
          M=J-3
          IF(M.NE.0)THEN
            IF(BREL2)THEN
              DO I=1,MAXRS
                DD=DPNL(I,K)*DPNL(I,K)+DQNL(I,K)*DQNL(I,K)
                DPA(I)=DD*DX(I)**M
              ENDDO
            ELSE
              DO I=1,MAXRS
                DPA(I)=DPNL(I,K)*DPNL(I,K)*DX(I)**M
              ENDDO
            ENDIF
            CALL WEDDLE(DZERO,DPA,DC,MNH,DHNS,MJH,MAXRS)
            DSTRNG(J,K)=DC
!            write(mw0,*)m,dc
          ENDIF
        ENDDO
!
  250   N2=JEND(N3+1)
        IF(N2.EQ.0)N2=MAXRS
!
        WRITE(MW6,10060)K,QN(K),N1,MION,NZION,SCREEN(K),                &
     &                  (DSTRNG(J,K),J=1,6),DADJUS(N3+1),DX(N2),        &
     &                  (DPNL(I,K)*FACT(K),I=L,MAXRS)
!
  300 ENDDO
!
      WRITE(MW6,10020)(DX(I),I=L,MAXRS)
!
      IF(JND.LT.0)THEN                              !THIS WAS THE LAST N
        DEALLOCATE(DSTRNG,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'CARATE: DE-ALLOCATION FAILS FOR DSTRNG'
          NF=0
          GO TO 1800
        ENDIF
      ENDIF
!
!  DETAILED PRINTOUT OF MASS-VELOCITY PLUS DARWIN INTEGRALS
! (SKIPPED IF PRINTING SUPPRESSED.)
!
      IF(BMVDR.AND.BMVD.AND.BPRNT0)THEN
        WRITE(MW6,10480)JPRINT
        DD1=DZERO
        DD2=DZERO
        DD3=DZERO
        DO K=1,MXORB
          IF(DEY(K).NE.DZERO)THEN
            IN=ICOL(K,K,IZERO)
            DD1=DMASS(IN)
            DD2=DCD(IN)
            DD=DD1+DD2
!            IF(B2LL)DD3=D2LL(IN)
            L=QL(K)/2
            WRITE(MW6,10490)K,QN(K),L,DEY(K),DD1,DD2,DD,DD3
          ENDIF
        ENDDO
!
        WRITE(MW6,10500)
        DO L=1,IRL
          IF(QRL(5,L).EQ.-1)THEN
            L1=QRL(1,L)
            L2=QRL(3,L)
            IN=ICOL(L2,L1,IZERO)
            IF(BMVDR)DD1=DMASS(IN)
            IF(BMVDR)DD2=DCD(IN)
!            IF(B2LL)DD3=D2LL(IN)
            WRITE(MW6,10510)L,L1,L2,DD1,DD2,DD3
          ENDIF
        ENDDO
      ENDIF
!
!  DETAILED PRINTOUT OF ONE-BODY INTEGRALS I(A,C)
!
      IF(IRL.LT.0)THEN            !.LT.0 SUPRESSES PRINTOUT
        WRITE(MW6,10320)
        K0=0
        DO K=1,K17
          I=K
          IF(DEY(K).EQ.DZERO)I=10000
          WRITE(MW6,10330)I,(DUY(K0+J),J=1,K)
          K0=K0+K
        ENDDO
      ENDIF
!
! DETAILED PRINTOUT OF ANY QED CONTRIBUTIONS
!
      IF(QED.LT.QZERO.AND.BPRNT0)THEN
        WRITE(MW6,10630)
        DO K=1,MXORB
          IF(DEY(K).NE.DZERO)THEN
            IF(QN(K).LT.QZERO)GO TO 400             !WE ARE DONE
            DD=VPINT(K)+SLFINT(K)
            WRITE(MW6,10640)K,QN(K),QL(K)/2,VPINT(K),SLFINT(K),DD
          ENDIF
        ENDDO
      ENDIF
!
  400 CONTINUE
!----------------------------------------------------------
!  *** CALCULATE SLATER INTEGRALS:  DRL(L)  (AND 2-NFS) ***
!----------------------------------------------------------
!
      if(btime)call nrb_time(timei)
!
      IF(IRL.GT.0)THEN
!
        CALL SLATR(BPRNT0)
!
        IF(NF.LE.0)GO TO 1900
      ENDIF
!
!
      IF(BPRNT0.AND.MAXLAM.NE.MAXLAM0)WRITE(MW6,10070)2*MAXLAM
!
      BRADAT=BPRINT.OR.JPRINT.EQ.3.AND.INCL0.EQ.0       !ORIGINAL INCLUD
      IF(.NOT.BPRINT)BRADAT=JPRINT.LT.0.AND.NPRNT5.GT.-2 !EVAL G FUNCTNL
!
      IF(.NOT.BRADAT)GO TO 500
      IF(BJUMP.AND..NOT.BRAD)GO TO 500
!
!-----------------------------------------------------
! *** CALCULATE R^K MULTIPOLE INTERGALS (INC BORN) ***
!-----------------------------------------------------
!
      CALL RKINT(BPRNT0)
!
      IF(NF.LE.0)GO TO 1900
!
  500 CONTINUE
!
      if(btime)then
        call nrb_time(timef)
        times=timef-timei
!par        if(iam.ge.0)then                                        !par
!par          write(iwp,*)'proc',iam,' for carate:'                 !par
!par          write(iwp,*)'    integral time=',nint(times),'sec'    !par
!par          call flush(iwp)                                       !par
!par        else                                                    !par
        write(iw,*)'integral time=',nint(times),'sec'
!par        endif                                                   !par
      endif
!
!  COLLAPSE BACK RELAXED ORBITAL LIST
!
      IF(IEQ(0).LT.0)THEN
!p        MXBORB=-IEQ(0)
        KF=MB+MXBORB                                                !MB0
        DO K=1,KF
          K2=2*K
          ITMP(K2-1)=QN(K)
          ITMP(K2)=QL(K)/2
          IORB(K)=K2
        ENDDO
        KP=2*KF
        KF=MB+MXBORB*KMAX                                           !MB0
        IF(BDR)THEN
          DO K=1,KMAX
            KF=KF+1
            IF(IGRCF(KF).GT.0.AND.KF.EQ.IEQ(KF))THEN         !FIRST OCC.
              KP=KP+1
              ITMP(KP)=QN(KF)
              KP=KP+1
              ITMP(KP)=QL(KF)/2
              IORB(KF)=KP
            ENDIF
          ENDDO
        ENDIF
        IF(BCONT)THEN
          DO K=1,KMAX
            KF=KF+1
            IF(IGRCF(KF).GT.0.AND.KF.EQ.IEQ(KF))THEN         !FIRST OCC.
              KP=KP+1
              ITMP(KP)=QN(KF)
              KP=KP+1
              ITMP(KP)=QL(KF)/2
              IORB(KF)=KP
            ENDIF
          ENDDO
        ENDIF
      ELSEIF(IEQ(0).GT.0)THEN
        KP=0
        DO K=1,MXORB
          IF(K.EQ.IEQ(K))THEN                                !FIRST OCC.
            KP=KP+1
            ITMP(KP)=QN(K)
            KP=KP+1
            ITMP(KP)=QL(K)/2
            IORB(K)=KP
          ENDIF
        ENDDO
      ENDIF
!
      IF(MODE.GT.0)THEN
        IF(IEQ(0).EQ.0)THEN
          KF=MIN(MXLIT,MXORB)
          IF(BPRNT0)THEN
            IF(KMAX.LT.1000)THEN
              WRITE(MW7,10160)KMAX,NZION,MION,                          &
     &                        (ABS(QN(K)),QL(K)/2,K=1,KF)
            ELSE
              WRITE(MW7,10170)KMAX,NZION,MION,                          &
     &                        (ABS(QN(K)),QL(K)/2,K=1,KF)
            ENDIF
          ENDIF
          IF(.NOT.BPRNT0)WRITE(MW27)int(KMAX),int(NZION),int(MION),     &
     &                              (int(ABS(QN(K))),int(QL(K)/2),K=1,  &
     &                              KF)
        ELSE
          KF=MIN(KP,ITWO*MXLIT)
          IF(BPRNT0)THEN
            IF(KMAX.LT.1000)THEN
              WRITE(MW7,10160)KMAX,NZION,MION,                          &
     &                        (ABS(ITMP(K)),ITMP(K+1),K=1,KF,2)
            ELSE
              WRITE(MW7,10170)KMAX,NZION,MION,                          &
     &                        (ABS(ITMP(K)),ITMP(K+1),K=1,KF,2)
            ENDIF
          ENDIF
          IF(.NOT.BPRNT0)WRITE(MW27)int(KMAX),int(NZION),int(MION),     &
     &                              (int(ABS(ITMP(K))),int(ITMP(K+1)),  &
     &                              K=1,KF,2)
        ENDIF
      ENDIF
!
      TOTW=0
      DO K=1,KMAX
        LM=0
!
        DO J=1,MXORB
          IF(NEL(J,K).GT.0)THEN
            LM=LM+1
            QSB(LM,K)=INT(NEL(J,K),QP)
            IF(LM.GT.1)QSB(LM,K)=QSB(LM,K)+Q50
            IF(IEQ(0).NE.0)THEN
              JM=MIN(IORB(IEQ(J))/2,MXLIT)
            ELSE
              JM=MIN(J,MXLIT)
            ENDIF
            QLB(LM,K)=LIT(JM)
!HAR        QLB(LM,K)=ICHAR(CLIT(JM))
            NCC0(LM)=J
          ENDIF
        ENDDO
        LMX(K)=LM
!
        IF(LM.LT.MXVORB0)THEN
          LP=LM+1
          DO J=LP,MXVORB0
            QSB(J,K)=0
            QLB(J,K)=MBLK1
!HAR        QLB(J,K)=ICHAR(CMBLK1)
          ENDDO
        ENDIF
        M2=QCG(NF,K)
        KW=K
        MST=MSTAT(K)
        TOTW=TOTW+MST
        IF(IYY(M2).GT.0)THEN
          KW=-K
!          M1=QL(M2)+1
!          MST=MSTAT(K)/(M1+M1)                 !AS CA OMITS CONTINUUM
        ENDIF
        IF(MODE.GT.0)THEN
          IF(BPRNT0)THEN
            if(mst.gt.99999)mst=0      !as I5 - use unformatted !MA0,MB0
            WRITE(MW7,10260)KW,MST,MA,MB,(QSB(L,K),QLB(L,K),L=1,LM)
!HAR  X             ,CHAR(QLB(L,K)),L=1,LM)
          ELSE                                                  !MA0,MB0
            WRITE(MW27)int(KW),int(MST),int(MA),int(MB),                &
     &                 (int(QSB(L,K)),int(QLB(L,K)),L=1,MXVORB0)
          ENDIF
        ENDIF
        DO L=1,LM
          QLB(L,K)=NCC0(L)
        ENDDO
      ENDDO
!
      IF(MODE.GT.0)THEN
        IF(BPRNT0)WRITE(MW7,10140)NZION,MION
        IF(.NOT.BPRNT0)WRITE(MW27)int(NZION),int(MION)
      ENDIF
!
! ex-common/nrbtmp/
      if(allocated(ncc0))then
        deallocate(ncc0,iorb)
      endif
!
!***********************************************************************
!
!  CONSTRUCT HAMILTONIAN MATRICES (H FOR ENERGY AND H**2 FOR RATES).
!
!***********************************************************************
!
!
!  CALCULATE ENERGY CONTRIBUTION DECORE OF THE NW CORE ELECTRONS
!  (MAYBE GROUP DEPENDENT)
!
      do n=1,ngrp1
!
        n1=n-1
        decor0=dzero
!
        DC1=DZERO                                    ! 1-BODY
        DC2=DZERO                                    ! 2-BODY
!
! 1-BODY (INC. NFS IF CAM)
!
        DO L=1,NW
          J=NNL(L,1)
          if(irlx.lt.0)j=j+mxborb*n1
          DC1=DC1+DEY(J)
          IF(BMVDR.AND.BMVD)THEN
            IN=ICOL(J,J,IZERO)
            DC1=DC1+DCD(IN)+DMASS(IN)
          ENDIF
          IF(QED.LT.QZERO)THEN              !SPLIT FOR CASE NOT-ALLOC
            DC1=DC1+VPINT(J)+SLFINT(J)
          ENDIF
        ENDDO
!
! 2-BODY (NON-REL ONLY)
!
        DO I=1,NAD(0)
          J=INT(NRK(I),SP)+n1
          DC2=DC2+DRL(J)*DRK(I)
        ENDDO
!
        DECORE=DC1+DC2                      ! 1-BODY + 2-BODY
!
        IF(BPRNT0)WRITE(MW6,10080)DC2,DC1
!
        decorn(n)=decore
        decor0=min(decor0,decore)
!
      enddo
!
      decore=decor0
!
      do n=1,ngrp1
        decorn(n)=decorn(n)-decore
      enddo
!
!***********************************************************************
! FIRST, GENERATE ALL CA ENERGIES.
! (WE ARE NOT CONSTRAINED TO THE LOOP ORDER IN CALGEB)
!***********************************************************************
!
      NCUT=KCUT
      IF(KCUT.LE.0)NCUT=1000000
      DMIN=D1P20
      DMAX=-D1P20
      EIONMN=DZERO
!
      DO K=1,KMAX
!
! 1-BODY (INC. NFS IF CAM)
!
        M2=0
        E1BODY=DZERO
        DO L=1,NF
          IF(QCG(L,K).NE.M2)THEN
            M2=QCG(L,K)
            DD=DEY(M2)
            IF(BMVDR.AND.BMVD)THEN
              IN=ICOL(M2,M2,IZERO)
              DD=DD+DCD(IN)+DMASS(IN)
            ENDIF
            IF(QED.LT.QZERO)THEN               !SPLIT FOR CASE NOT-ALLOC
              IF(QN(M2).GT.0)DD=DD+VPINT(M2)+SLFINT(M2)
            ENDIF
          ENDIF
          E1BODY=E1BODY+DD
        ENDDO
        IF(ICAV.NE.0)E1BODY=E1BODY+ECAVX(K)-ECAV(K)    !RLXD CA CORRECTN
!
        if(irlx.lt.0)then
          n=icfgp(k)
          e1body=e1body+decorn(n)
        endif
!
! 2-BODY (NON-REL ONLY)
!
        I8=K
        NP8=ICOL8(I8,I8,IZERO)
        N1=NAD(NP8-1)+1
        N2=NAD(NP8)
!
        E2BODY=DZERO
        DO L=N1,N2
          M1=INT(NRK(L),SP)
          E2BODY=E2BODY+DRL(M1)*DRK(L)
        ENDDO
!
        DD=E1BODY+E2BODY
!
        IF(ISHFTLS.EQ.1)DD=DD+DELELS(K,1)         !SHIFT
!
        KK=K
        IF(IYY(M2).GT.0)THEN                      !CONT
          KK=-K
          DD=DD+ECOR1
          IF(MODE.LT.3)DD=DD-DYY(NREL)            !REMOVE ENERGY OF CONT
          DD=MOD(DD,TSHFT)
          IF(DD.LT.EIONMN)EIONMN=DD
          IWRK3(K)=M2
        ELSE
          IWRK3(K)=-M2
        ENDIF
!
        IF(DD.LT.DMIN)THEN
          DMIN=DD
        ENDIF
        IF(DD.GT.DMAX)DMAX=DD
!
        DENERG(K)=DD
!
        IF(BPRNT0)WRITE(MW6,10030)K,MSTAT(K),QCP(K)/2,DENERG(K),KK
!
!        if(bprnt0)then
!          write(mw0,*)'cf=',k,'  e1body=',e1body,'  e2body=',e2body
!          write(mw6,*)'cf=',k,'  e1body=',e1body,'  e2body=',e2body
!        endif
!
      ENDDO
!
      IF(BPRNT0)THEN
        WRITE(MW6,10470)DC1,DECORE
        IF(BAUGER)THEN
          WRITE(MW6,10130)
          IF(ISHFTLS.EQ.1)WRITE(MW6,10190)
        ENDIF
      ENDIF
!
      EIONMN=EIONMN+DECORE
      EIONMN=EIONMN+EIONMN
!
!********************************************
!
!     ***COMPUTE AUTOIONIZATION RATES***
!
!********************************************
!
      IF(.NOT.BAUGER)GO TO 700
!
      if(btime)call nrb_time(timei)
!
      DO KF=1,KMAX
!
        IF(IWRK3(KF).GT.0)GO TO 600
!
        DO KG=1,KMAX
!
          IF(IWRK3(KG).LT.0)GO TO 550
!
          I8=MIN(KF,KG)
          J8=MAX(KF,KG)
          NP8=ICOL8(I8,J8,IZERO)                  !ENERGY IS ON DIAGONAL
          N1=NAD(NP8-1)+1
          N2=NAD(NP8)
          IF(N1.GT.N2)GO TO 550
!
          IF(ABS(DENERG(KG)+DYY(NREL)-DENERG(KF)).GT.ACE)GO TO 550
          DRY=DENERG(KG)
!   DRY STILL EQUAL TO ENERGY OF TARGET BUT DENERG ALSO EQUAL TO IT NOW
          DS=DENERG(KF)-DRY
!
          IF(DS.LT.DZERO)GO TO 550            !NOT ENERGETICALLY ALLOWED
!                       .AND.BLAG
!
! SET-UP INTERPOLATION
!
          IF(BLAG)THEN
!
            IF(IGAPE.GT.0)THEN
              IF(DS.LT.DYY(IGAPE).AND.DS.GT.DYY(IGAPE-1))THEN
                WRITE(MW6,*)'***EXTRAPOLATING AUGERS2'
                WRITE(MW6,*)IGAPE,2*DYY(IGAPE-1),2*DS,2*DYY(IGAPE)
                IF(DS.LT.D0PT8*DYY(IGAPE).AND.DS.GT.D1PT2*DYY(IGAPE-1)) &
     &             THEN
                  WRITE(MW0,*)'***EXTRAPOLATING AUGERS2'
!                  GO TO 2000
                ENDIF
              ENDIF
            ENDIF
!
            M2=-IWRK3(KF)
            TM=DS+DSHIFT(M2)
!
            CALL LAGINT(TM,DDY,NP1,NP2)
!
          ENDIF
!
! FORM AUTOIONIZATION RATE
!
          DAS=DZERO
!
          DO L=N1,N2
            n8=NRK(L)
            IF(n8.GT.0)THEN                  !DIRECT & EXCHANGE
              M0=INT(n8,SP)
              K0=NRLI(M0)
              IF(K0.GT.0)THEN
                DO M=NP1,NP2
                  DAS=DAS+DDY(M)*DRLI(M,K0)*DRLI(M,K0)*DRK(L)
                ENDDO
              ENDIF
            ELSE                             !INTERFERENCE
              M1=-INT(n8/IPLANT_RL,SP)                            !MAXRL
              M2=-INT(M1*IPLANT_RL+n8,SP)                         !MAXRL
              K1=NRLI(M1)                    !DIRECT
              K2=NRLI(M2)                    !EXCHANGE
              IF(K1*K2.GT.0)THEN
                DO M=NP1,NP2
                  DAS=DAS+DDY(M)*DRLI(M,K1)*DRLI(M,K2)*DRK(L)
                ENDDO
              ENDIF
            ENDIF
          ENDDO
!
          DAS=abs(DAS)*DKON   !CA IS ALREADY SQUARED, but for extrapn...
          IF(DAS.GT.D1M2)THEN
            MWJ=MSTAT(KF)
            MWI=MSTAT(KG)
            IF(BPRNT0)WRITE(MW6,10110)MWJ,KF,KG,DAS,DS,DRY
            DS=DS+DS
            DRY=DRY+DECORE
            DRY=DRY+DRY
!
            IF(BPRNT0)THEN
              if(mwj.gt.99999)mwj=0             !as I5 - use unformatted
              WRITE(MW7,10150)KF,KF,MWJ,-KG,KG,DAS,DS,DRY
!              WE KNOW MWI, BUT FOR ADASDR COMPATIBILITY WITH LS/IC OMIT
            ELSE
              WRITE(MW27)int(KF),int(KF),int(MWJ),int(-KG),int(KG),DAS, &
     &                   DS,DRY
            ENDIF
          ENDIF
!
  550   ENDDO                    !END LOOP OVER FINAL CFS
!
  600 ENDDO                      !END LOOP OVER INIITAL CFS
!
      if(btime)then
        call nrb_time(timef)
        times=timef-timei
!par        if(iam.ge.0)then                                        !par
!par          write(iwp,*)'proc',iam,' for carate:'                 !par
!par          write(iwp,*)'    auger time=',nint(times),'sec'       !par
!par          call flush(iwp)                                       !par
!par        else                                                    !par
        write(iw,*)'auger time=',nint(times),'sec'
!par        endif                                                   !par
      endif
!
  700 CONTINUE
!
! ******* END GENERATION OF ENERGIES AND AUGERS
!
      NENERG=KMAX
!
      lupe=nenerg
      if(idw.eq.0)lupe=min(lupe,lupmx)
!
! SORT ENERGIES (assumes all are negative...)
!
      IF(DMAX.GT.DZERO)THEN                        !UNLIKELY
        DO L=1,NENERG
          DENERG(L)=DENERG(L)-DMAX
        ENDDO
      ENDIF
!
!
      CALL HPSRTI(NENERG,DENERG,IORIG)
!
!
      IF(DMAX.GT.DZERO)THEN                        !UNLIKELY
        DO L=1,NENERG
          DENERG(L)=DENERG(L)+DMAX
        ENDDO
      ENDIF
!
! PRELIMINARY WRITES
!
      IF(.NOT.BFOTJ)THEN
        IF(BPRNT0)THEN
          WRITE(MW17,10230)MENG,NZION,MION,EIONMN
          WRITE(MW17,10240)(DTWO*DYY(M8),M8=1,MENG)
          WRITE(MW17,10250)NZION,MION
        ELSE
          WRITE(MW29)int(MENG),int(NZION),int(MION),EIONMN
          WRITE(MW29)(DTWO*DYY(M8),M8=1,MENG)
          WRITE(MW29)int(NZION),int(MION)
          WRITE(MW29)MBLK
        ENDIF
      ENDIF
      IF(MODE.GT.0)THEN
        IF(BPRNT0)THEN
          WRITE(MW7,10120)EIONMN
        ELSE
          WRITE(MW27)int(IZERO),int(IZERO),int(IZERO),int(IZERO),       &
     &               int(IZERO),DZERO,DZERO,EIONMN
        ENDIF
      ENDIF
!
      IF(.NOT.BRAD.AND.BJUMP)GO TO 1800
!
      DG0=DECORE+DMIN             !GROUND ENERGY (A.U.)
      IF(MODE.GT.0)THEN
        IF(BPRNT0)THEN
          WRITE(MW7,10200)NENERG,2*DG0
        ELSE
          WRITE(MW27)int(NENERG),2*DG0
          WRITE(MW27)MBLK
        ENDIF
      ENDIF
!
      IF(INCLUD.GT.NENERG)INCLUD=NENERG
!
      BAUX=JPRINT.GE.4.OR.BPRINT
      IF(BAUX.AND.BPRNT0)THEN
        WRITE(MW6,10580)INCLUD,(DADJUS(I),I=1,NPARAM)
        IF(IPOLFN.LT.0)THEN
          NP0=-IPOLFN
          DO N=1,NP0
            N0=N*NPARAM
            WRITE(MW6,10610)N,(DADJUS(N0+I)-DONE,I=1,NPARAM)
                                                           !DADJUS(N0+I)
          ENDDO
        ENDIF
        WRITE(MW6,10570)2*DG0
      ENDIF
      IF(MODE.EQ.1.AND.IUNIT(MRW14).GT.0)WRITE(MRW14,10520)
!
      BPUNCH=IUNIT(MRW3).LT.0        !WRITE ENERGY-ORDERED CONFIG.DAT_EO
      IF(BPUNCH)THEN
!
        OPEN(MRW3,FILE='CONFIG.DAT_EO',STATUS='REPLACE')
        IUNIT(MRW3)=1
!
        IF(ECORR.NE.DZERO)THEN
          ETEST=ECORR/DTWO                                    !ECORR RYD
          IF(ECORR.LT.DZERO)THEN
            ETEST=ETEST-DECORE                           !ECORR ABSOLUTE
          ELSE
            ETEST=ETEST+DMIN                   !ECORR RELATIVE TO GROUND
          ENDIF
          DO J=1,NENERG
            I=IORIG(J)
            IF(DENERG(I).GT.ETEST)GO TO 720
          ENDDO
          J=NENERG+1
  720     KKX=J-1
        ELSE
          KKX=NENERG
        ENDIF
!
        I00=MB
        I0=I00+1                                                    !MB0
!
! HAVE LOST INFO ON SIGN OF MB BY HERE. SAFEST JUST TO CHECK FOR S.O.
!
        K2=I00
        DO K=I00,1,-1
          CALL SO2NL(K,N,L)
          IF(QN(K).NE.INT(N,QP).OR.QL(K).NE.INT(2*L,QP))THEN   !NOT S.O.
            K2=-K2
            GO TO 750
          ENDIF
        ENDDO
!
  750   I0N=I0
        MXORBN=MXORB
!
        ALLOCATE(KNEW(MXORBN))                 !ORBITAL MAP S.O. TO E.O.
!
        DO K=1,MXORBN
          KNEW(K)=K
        ENDDO
!
        IF(BADF00)THEN
!
          IF(MXCONFH.LT.0)THEN              !RECOVER/CHECK GROUND CONFIG
            NELEC=NW+NF
            JHZ=QCFGX(0,0,NZION)    !NO OF STAGES OF ELEMENT NOT IN S.O.
            JZ=NZION-NELEC+1
            IF(JZ.LE.JHZ)THEN
              KLEN=QCFGX(0,JZ,NZION)
              ALLOCATE(QCFG(0:KLEN))
              DO K=0,KLEN
                QCFG(K)=QCFGX(K,JZ,NZION)          !COPY-IN GROUND CONFG
              ENDDO
            ELSE
              JH0=QCFG0(0,0)                 !NO OF S.O. STAGES ARCHIVED
              JH=JH0-NELEC+1                   !H-LIKE IN THE LAST POSTN
              KLEN=QCFG0(0,JH)
              ALLOCATE(QCFG(0:KLEN))
              DO K=0,KLEN
                QCFG(K)=QCFG0(K,JH)                !COPY-IN GROUND CONFG
              ENDDO
            ENDIF
!            if(klen.ne.mxorb)write(mw0,*)'klen,mxorb=',klen,mxorb
            LXX=MIN(KLEN,MXORB)
            I1=IORIG(1)
            DO L=I0,LXX
              IF(NEL(L,I1).NE.QCFG(L))THEN
                WRITE(MW0,*)                                            &
     &          ' *** STRONG WARNING: PROMOTIONS HAVE GENERATED A "NEW"'&
     &          ,' AND INCORRECT GROUND CONFIG!'
                WRITE(MW6,*)                                            &
     &          ' *** STRONG WARNING: PROMOTIONS HAVE GENERATED A "NEW"'&
     &          ,' AND INCORRECT GROUND CONFIG!'
                WRITE(MW6,*)'OBS GROUND CF: ',(QCFG(K),K=I0,KLEN)
                WRITE(MW6,*)'NEW GROUND CF: ',(NEL(K,I1),K=I0,MXORB)
                GO TO 760
              ENDIF
            ENDDO
  760       DEALLOCATE(QCFG)
          ENDIF
!
          IF(EXCITE.GT.DZERO)THEN
            ETEST=EXCITE/DTWO+DMIN
            DO J=1,KKX
              I=IORIG(J)
              IF(DENERG(I).GT.ETEST)GO TO 770
            ENDDO
            J=NENERG+1
  770       KKX=J-1
          ENDIF
          IF(MXCONFH.NE.0)KKX=MIN(KKX,-MXCONFH)
!          write(mw0,*)'mxconfh=',mxconfh,kkx
!
! LOOK FOR NEW COMMON CLOSED SHELLS AND EMPTY SHELLS IN REDUCED CFG SET
!
          ALLOCATE(KCLOSE(MXORB),KZERO(MXORB))
!
          DO K=1,MXORB
            KZERO(K)=0                                  !FLAG ALL EMPTY
            KCLOSE(K)=1                                 !FLAG ALL CLOSED
          ENDDO
!
          DO J=1,KKX
            I=IORIG(J)
            DO L=I0,MXORB
              IF(NEL(L,I).NE.0)KZERO(L)=1               !NOT EMPTY
              LFULL=2*QL(L)+2
              IF(NEL(L,I).NE.LFULL)KCLOSE(L)=0          !NOT CLOSED
            ENDDO
          ENDDO
!
          DO L=I0,MXORB
            IF(KCLOSE(L).NE.0)THEN
              I00=I00+1
              KNEW(I00)=L
!         write(mw0,*)i00,-l
            ENDIF
          ENDDO
!
          IF(I00.GT.MB)K2=-I00
          I0N=I00+1
!
          DO L=I0,MXORB
            IF(KZERO(L).NE.0.AND.KCLOSE(L).EQ.0)THEN
              I00=I00+1
              KNEW(I00)=L
            ENDIF
          ENDDO
!
!          do i=1,i00
!            write(mw0,*)i,knew(i)
!          enddo
!
          MXORBN=I00
!
        ENDIF
!
! WRITE EO CONFIG.DAT
!
        I1=ABS(K2)+1
        IF(K2.LT.0)I1=1
!
        WRITE(MRW3,10650)K2,MXORBN
        WRITE(MRW3,10660)(QN(KNEW(L)),QL(KNEW(L))/2,L=I1,MXORBN)
!
        ALLOCATE(MNAL(I0:MXORB),MXAL(I0:MXORB))
!
        I=IORIG(1)
        DO L=I0,MXORB
          MNAL(L)=NEL(L,I)
          MXAL(L)=NEL(L,I)
        ENDDO
!
        DO J=2,KKX
          I=IORIG(J)
          DO L=I0,MXORB
            MNAL(L)=MIN(MNAL(L),NEL(L,I))
            MXAL(L)=MAX(MXAL(L),NEL(L,I))
          ENDDO
        ENDDO
!
        FORM=FORM2
        DO L=I0,MXORB
          IF(MXAL(L).GT.9)FORM=FORM3
        ENDDO
!
        WRITE(MRW3,10650)KKX
        WRITE(MRW3,FORM)(MNAL(KNEW(L)),L=I0N,MXORBN)
        WRITE(MRW3,FORM)(MXAL(KNEW(L)),L=I0N,MXORBN)
        DO J=1,KKX
          I=IORIG(J)
          WRITE(MRW3,FORM)(NEL(KNEW(L),I),L=I0N,MXORBN),IZERO
        ENDDO
!
        DEALLOCATE(MNAL,MXAL)
        DEALLOCATE(KNEW)
        IF(BADF00)DEALLOCATE(KCLOSE,KZERO)
!
      ENDIF
!
      IF(IUNIT(MW21).GT.0)WRITE(MW21,10270)      !NENERG need NSPECE now
!
      IF(MENGB.GE.-1)THEN
        ELEM=CELMNT(NZION)
        NZAM=NZA-1
        FIP=ADASIP(ELEM,NZAM)
        if(badas)then
          lab4='    '
        else
          lab4='(0Y)'
        endif
        WRITE(MRW25,10290)ELEM,NZAM,NZION,NZA,FIP,lab4
        ISMX=0
        DO K=1,KMAX                             !CHECK MAX STRING LENGTH
          IS=4*LMX(K)
          ISMX=MAX(ISMX,IS)
        ENDDO
        IF(ISMX.GT.MXSTRG)THEN                   !THIS IS A FORMAT ISSUE
          WRITE(MW6,*)                                                  &
     &              '***SR.CARATE: adf04 CONFIGURATION STRING TRUNCATED'
          WRITE(MW0,*)                                                  &
     &              '***SR.CARATE: adf04 CONFIGURATION STRING TRUNCATED'
        ENDIF                                !NOT A DIMENSION ONE PER SE
        MSTRG4=MXSTRG/4                       !MXSTRG IS A MULTIPLE OF 4
      ENDIF
!
!********************************************
!
! WRITE ENERGY-ORDERED CF LIST
!
!********************************************
!
      DF=DZERO                             !INITIALIZE FUNCTIONAL ENERGY
      DS=DZERO                             !INITIALIZE FUNCTIONAL WEIGHT
      IF(IOPTIM.NE.0)DS=DONE
      LL=-INCLUD
!
      IPP=0
      ISP=0
      LSP=0
      IE0=0
      NSPECE=0
      EMIN=EIONPOT
      IF(EMIN.GT.DZERO)THEN
        IAUTO=0
      ELSE
        IAUTO=-1
      ENDIF
      DECMIN=-D1P20
!
! LIST DEGENERATE CONFIGS BY ASCENDING CF INDEX
!
      IF(BCONT.AND.BPRNT0)THEN
        J0=1
  800   MSUM=1
        DO J=J0,NENERG
          I=IORIG(J)
          IF(DENERG(I).LT.(DECMIN+TOLB2))THEN                      !A.U.
            MSUM=MSUM+1
          ELSE
            IF(MSUM.GT.1)GO TO 850
          ENDIF
          DECMIN=DENERG(I)
        ENDDO
        J=NENERG+1
!
  850   DECMIN=DENERG(I)
        DO M=MSUM,1,-1
          I=IORIG(J-M)
          DWRK(M)=I
        ENDDO
!
        CALL HPSRTI(MSUM,DWRK,IWRK2)
!
        DO M=1,MSUM
          I=IWRK2(M)
          I=NINT(DWRK(I),SP)
          IORIG(J-M)=I
        ENDDO
        IF(J.LT.NENERG)THEN
          J0=J+1
          GO TO 800
        ENDIF
        DECMIN=-D1P20                                  !RE-SET FOR LATER
      ENDIF
!
! BEGIN CONFIG ENERGY LOOP
!
      IKOW=0
      DO J=1,NENERG
!
        I=IORIG(J)                              !J=EO -> I=SO
!
        DAU=DENERG(I)
        DENERG(I)=DENERG(I)-DMIN
        DRY=DENERG(I)*DTWO
!
        IF(I.GT.NCUT.OR.BECOR.AND.                                      &
     &     (DRY*ECORR.GT.ECORR*ECORR.OR.DRY.GT.ESKPL.AND.DRY.LT.ESKPH)) &
     &     THEN                                             !CORRELATION
          IORIG(J)=-I
          MBCOR=MCOR
        ELSE
          IORIG(J)=I
          MBCOR=MBLK
          if(j.le.lupe)NSPECE=NSPECE+1
          IKOW=IKOW+1
        ENDIF
!
        DD=DZERO
!
! LL=-INCLUD
        IF(LL.EQ.0)GO TO 950
!
        IF(LL.GT.0)THEN
          DO K=1,LL
            IF(INDEXW(K).EQ.I)THEN
              DD=WGHT(K)
              GO TO 900
            ENDIF
          ENDDO
          IF(IOPTIM.EQ.0)GO TO 950
        ENDIF
!
        IF(BINCF)IKOW=I
        IF(IKOW.GT.INCLUD.AND.IOPTIM.EQ.0)GO TO 950             !IKOW<-J
!
        IF(IORIG(J).LT.0)GO TO 950      !OMIT CORR. FROM DF FOR INCLUD>0
!
! WEIGHT ENERGY FOR FUNCTIONAL:
!(N.B.IWGHT.LT.0 IS IGNORED SINCE -2 IS MEANINGLESS AND -1 IS REDUNDANT)
!
! STATISTICAL WEIGHTED MEAN
!
        IF(ABS(IWGHT).EQ.2)DD=MSTAT(I)/TOTW
!
! EQUAL WEIGHTED (ARITHMETIC) MEAN
!
        IF(ABS(IWGHT).EQ.1)DD=DONE/INCLUD
!
! ADD TO ENERGY FUNCTIONAL (HERE, ANY AND ALL CORRELATION IS OMITTED)
!
  900   IF(IOPTIM.EQ.0)THEN                        !STANDARD
          DF=DAU*DD+DF
          DS=DS+DD
        ENDIF
!
  950   DEM=DRY*DKCM
        DWRK(I)=DEM
!
        MYRGE=MBLK
        IF(IWRK3(I).GT.0)THEN                      !CONT
          IF(DRY.GT.(DECMIN+TOLB))IE0=IE0+1
          IWRK2(I)=IE0
          MI=-I
!W          M2=QCG(NF,I)
!W          M1=QL(M2)+1
        ELSE
          MI=I
        ENDIF
        IF(MYRGE.EQ.MBLK)ISP=MSTAT(I)
        IPP=QCP(I)/2
        LSP=0
        IF(MBCOR.EQ.MBLK)DECMIN=DRY
!
        IF(IAUTO.GT.0.AND.DENERG(I)-EMIN.LE.TOLE)IAUTO=J+1
        IF(IWRK3(I).GT.0.AND.IAUTO.LT.0)THEN
          IAUTO=J
          EMIN=DENERG(I)
        ENDIF
!
        IF(.NOT.BAUX)GO TO 1000
!
        II=MSTAT(I)      !*(1-QCP(I))
!W        IF(MI.LT.0)II=II*(M1+M1)                !AS CA OMITS CONTINUUM
        W=ABS(II)-1
        W=W/2
!
        IF(MODE.GT.0)THEN
          IF(BPRNT0)THEN
            if(mi.gt.0)then
              WRITE(MW7,10210)J,IORIG(J),II,MI,DRY
            else
              WRITE(MW7,10210)J,IORIG(J),II,MI,DRY,ie0
            endif
          ELSE
            WRITE(MW27)int(IORIG(J)),int(IZERO),int(II),int(IZERO),     &
     &                 int(IZERO),int(MI),DRY,int(ie0)
          ENDIF
        ENDIF
!
        IF(BPRNT0)THEN
          if(mi.gt.0)then
            WRITE(MW6,10560)J,I,DEM,II,MI,MBCOR,DD,DRY
          else
            WRITE(MW6,10560)J,I,DEM,II,MI,MBCOR,DD,DRY,ie0
          endif
        ENDIF
        IF(MODE.EQ.1.AND.IORIG(J).GT.0.AND.IUNIT(MRW14).GT.0)           &
     &     WRITE(MRW14,10550)ISP,IPP,I,DRY,MYRGE
!
!        IF(BPUNCH.AND.J.LE.KKX)WRITE(MRW3,FORM)(NEL(L,I),L=I0,MXORB),
!     &                               IZERO
!
        IF(MENGB.GE.-1.and.IORIG(J).GT.0.and.j.le.lupe)THEN
          ISS=0
          K=I
          LMXK=LMX(K)
          IF(LMXK.LE.MSTRG4)THEN
            L1=1
          ELSE                    !TRUNCATE AS TOO LONG FOR ADF04 FORMAT
            L4=LMXK-MSTRG4
            L1=L4+1
          ENDIF
          L2=4*(L1-1)+1           !+2
          IS=0
          DO L=L1,LMXK
            JJK=ABS(QN(QLB(L,K)))
            IF(JJK.GT.999)THEN
              IS=IS+1
              J1000=JJK/1000
              STRING(IS)=NUMB(J1000)
              JJK=JJK-J1000*1000
            ENDIF
            IF(JJK.GT.99)THEN
              IS=IS+1
              J100=JJK/100
              STRING(IS)=NUMB(J100)
              JJK=JJK-J100*100
            ENDIF
            IS=IS+1
            IF(JJK.GT.9)THEN
              J10=JJK/10
              STRING(IS)=NUMB(J10)
              JJK=JJK-J10*10
            ELSE
              STRING(IS)=' '
            ENDIF
            IS=IS+1
            STRING(IS)=NUMB(JJK)
            IS=IS+1
            JJK=MIN(INT(QL(QLB(L,K))/2,SP),MXLAB1)
            STRING(IS)=BIGL(JJK)
            IS=IS+1
            N=MOD(INT(QSB(L,K),SP),I50)
            STRING(IS)=NUMB(N)
          ENDDO
          DO L=IS+1,MXSTRG
            STRING(L)=' '
          ENDDO
          if(badas)then                                      !adf04 only
            if(iunit(MRW25).gt.0)then
              cstan=' '
              ceiss=' '
              if(ismx.le.mstrgh)then
                f542="(i5,1a16,3x,'(',a1,')',a1,'(',f10.1,')',f15.1)"
                write(cstan(1:16),'(16a1)')(string(l),l=1,mstrgh)
                call xxcftr(ione,cstan,ceiss)
                IF(IUNIT(MRW25).GT.0)WRITE(MRW25,f542)nspece,ceiss(1:16)&
     &                                     ,numb(iss),numb(lsp),w,dem
              else
                f543="(i5,1a32,3x,'(',a1,')',a1,'(',f10.1,')',f15.1)"
                write(cstan(1:32),'(32a1)')(string(l),l=l2,mxstrg)
                call xxcftr(ione,cstan,ceiss)
                IF(IUNIT(MRW25).GT.0)WRITE(MRW25,f543)nspece,ceiss(1:32)&
     &                                     ,numb(iss),numb(lsp),w,dem
              endif
            endif
          else                                   !adf04 or adsex.in.form
            IF(ISMX.LE.MSTRGH)THEN
              F542="(I5,16(A1),3X,'(',A1,')',A1,'(',F10.1,')',F15.1)"
              IF(IUNIT(MW21).GT.0)WRITE(MW21,F542)NSPECE,               &
     &                                  (STRING(L),L=1,MSTRGH),NUMB(ISS)&
     &                                  ,NUMB(LSP),W,DEM
              IF(IUNIT(MRW25).GT.0)WRITE(MRW25,F542)NSPECE,             &
     &                                   (STRING(L),L=1,MSTRGH),        &
     &                                   NUMB(ISS),NUMB(LSP),W,DEM
            ELSE
              F543="(I5,32(A1),3X,'(',A1,')',A1,'(',F10.1,')',F15.1)"
              IF(IUNIT(MW21).GT.0)WRITE(MW21,F543)NSPECE,               &
     &                                  (STRING(L),L=L2,MXSTRG),        &
     &                                  NUMB(ISS),NUMB(LSP),W,DEM
              IF(IUNIT(MRW25).GT.0)WRITE(MRW25,F543)NSPECE,             &
     &                                   (STRING(L),L=L2,MXSTRG),       &
     &                                   NUMB(ISS),NUMB(LSP),W,DEM
            ENDIF
          endif
        ENDIF
!
 1000 ENDDO
!
!  *** END ENERGY WRITE LOOP
!
      IF(BAUGER)DEALLOCATE(DDY)
      DEALLOCATE(LMX,QSB,QLB)
      deallocate(decorn)
!
      IF(MODE.EQ.1.AND.IUNIT(MRW14).GT.0)WRITE(MRW14,10550)IZERO,IZERO, &
     &   IZERO,2*DG0
!
      IF(IUNIT(MW21).GT.0)WRITE(MW21,10280)
!
      IF(IDW.NE.0)THEN
        WRITE(MRW10)NMETA                                       !4CALGX0
        NNN=NENERG                                              !4CALGX0
        IF(BECOR)NNN=-NNN                                       !4CALGX0
        WRITE(MRW10)NNN,KCUT                                    !4CALGX0
        WRITE(MRW10)(IORIG(I),I=1,NENERG)                       !4CALGX0
        WRITE(MRW10)(DENERG(abs(IORIG(I)))*DTWO,I=1,NENERG)     !4CALGX0
      ENDIF
!
      IF(IAUTO.LT.0)IAUTO=NENERG+1
!
! ALTERNATE FORM OF ENERGY FUNCTIONAL - ORIGINAL SS DIFFERENCE BETWEEN
! CALCULATED AND OBSERVED TERM-AV ENERGIES, RELATIVE TO GROUND IN CM,
! AND FLAGGED BY USER INPUT INDEXW .LT. 0, SO DS=0, ASSUMING IOPTIM=0.
!
      IF(DS.EQ.DZERO)THEN
        DS=DONE
        DECORE=DZERO
        DO I=1,LL
          II=-INDEXW(I)
          IF(II.EQ.0)THEN                   !ASSUME INPUT ENERGY ORDERED
            II=IORIG(I)
            INDEXW(I)=-II                            !SET SYMMETRY ORDER
          ENDIF
          DO J=1,I
            JJ=-INDEXW(J)
!            IF(JJ.EQ.0)JJ=IORIG(J)
            DF=(DWRK(II)-DWRK(JJ)-WGHT(I)+WGHT(J))**2+DF
          ENDDO
          IF(BAUX)WRITE(MW6,10010)I,DWRK(II),WGHT(I),DF
        ENDDO
      ENDIF
!
! FINALIZE ENERGY FUNCTIONAL DF
!
      DF=DF/DS
!
! 7600 CONTINUE
!
!      IF(NF.LE.0)GO TO 750                                      !RETURN
!
!
!********************************************
!
!   ***COMPUTE MULTIPOLE RADIATIVE DATA***
!
!********************************************
!
!
      NGF=0
      SGF=DZERO
      IF(.NOT.BRADAT.OR.NPRNT5.EQ.-2)GO TO 1700
!
      NPOSX=(IOS-IRK)
      if(nposx.le.0)go to 1700
!
      BOMRC=.FALSE.
!
      MXORB2=MXORB*MXORB      !MXORB -> MXORBR UNNECESS. FOR CA   !FLAGX
!
      i1=1
!!      i1=mb+1                                                   !FLAGX
      i2=i1
!
      BDEL=MDEL.GT.0
      IF(IDIAG.LT.0.AND.BDEL)WLG0=DTEN**MDEL
      DEM=2*DG0                               !GROUND ENERGY (RYD)
!
      IF(BPRNT0.AND.MODE.GT.0)WRITE(MW7,10180)NZION,MION
      IF(.NOT.BPRNT0.AND.MODE.GT.0)WRITE(MW27)int(NZION),int(MION)
!
      IF(MENGB.GE.-1)THEN                     !INITIALIZE OMEGA BORN
!
        WRITE(MW6,10530)
        TOLO=D1M10
!
        if(nmeta.gt.0)then
          nmin=min(NMETA,NSPECE)
          ixr=irow(nmin,nspece,ione1,nspece)
          ixc=0
          if(idw.eq.0.and.ABS(MENGB).eq.1)ixc=icol(nmin,nspece,ione1)
          nomwrt=max(ixr,ixc)
        else
          NOMWRT=(NSPECE*(NSPECE+1-2*ione1))/2
        endif
!
        ITEST4=IBUFF4
        ITEST4=ITEST4+1
        IF(NOMWRT/2.GT.IBUFF4.AND.ITEST4.LT.IBUFF4)THEN !nomwrt is i4...
          WRITE(MW0,*)'*** SR.CARATE: TOO MANY CONFIGS FOR I*4'
          WRITE(MW6,*)'*** SR.CARATE: TOO MANY CONFIGS FOR I*4',        &
     &                ', SET DEFAULT INTEGER SP=8 IN MODULE PRECSN'
          GO TO 1600
        ENDIF
!
        IF(ABS(MENGB).EQ.1)THEN              !INFINITE ENERGY ONLY
!
          BSCRO=.TRUE.       !(REMOVE "ELSE" TO USE INTERNAL - WASTEFUL)
!
          ALLOCATE(OMR(NOMWRT),OMC(NOMWRT),STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'CARATE: ALLOCATION FAILS FOR OMR,OMC'
            NF=0
            GO TO 1600
          ENDIF
          BOMRC=.TRUE.
          NOMWRX=NOMWRT
!
          IF(NOMWRT.GT.NOMWRX)THEN           !NO LONGER POSSIBLE
            NNN=2*NOMWRT/MENG+1
            WRITE(MW6,10540)NNN
            WRITE(MW0,*)'*** WORKING ARRAYS TOO SMALL IN SR.CARATE'
            GO TO 2000
          ENDIF
          DO I=1,NOMWRX
            OMR(I)=DZERO
            OMC(I)=DZERO
          ENDDO
!
        ELSE                                  !FINITE ENERGY
!
          BSCRO=.TRUE.      !.T. USE SCRATCH FILE, .F. STORE INTERNALLY
!
          IF(.NOT.BSCRO)THEN
            ALLOCATE(OMEGA(0:MXNXB1,NOMWRT),STAT=IERR)
            IF(IERR.NE.0)THEN
              BSCRO=.TRUE.
            ELSE
              BSCRO=.FALSE.
            ENDIF
          ENDIF
          NOMWRY=NOMWRT
!
!
          IF(BSCRO)THEN
!            WRITE(MW0,*)'CARATE: USING SCRATCH FOR BORN MULTIPOLE SUM'
!            WRITE(MW6,*)'CARATE: USING SCRATCH FOR BORN MULTIPOLE SUM'
          ELSE
            DO N=1,NOMWRT
              DO NX=0,MXNXB1
                OMEGA(NX,N)=0
              ENDDO
            ENDDO
          ENDIF
!
          DO NX=1,MXNXB
            XS(NX)=SQRT(DONE-DONE/XB(NX))
          ENDDO
!
        ENDIF
!
        MSC0=80
        MSC=MSC0-1
!
      ENDIF
!
      IF(MENGB.EQ.1)THEN
        WLGO=D1M7/DZA2
      ELSE
        WLGO=D1M5/DZA2
      ENDIF
!                 INITIALIZE GEOMETRIC COEFFICIENTS
      ALLOCATE(DG(0:IXBLM))
!
      DG(0)=DZERO
      IF(MPOLE.LE.8)THEN
        IP=1
        DO I=2,MPOLE,2
          IP=IP*(I+1)*2
          IM=I/2
          DG(IM)=2*(I+1)*(IM+1)
          DG(IM)=DG(IM)/(IM*REAL(IP,WP)*REAL(IP,WP))
        ENDDO
      ELSE
        TIP=1
        DO I=2,MPOLE,2
          TIP=TIP*(I+1)*2
          IM=I/2
          DG(IM)=2*(I+1)*(IM+1)
          DG(IM)=DG(IM)/(IM*TIP*TIP)
!          write(mw0,*)im,tip,2*(i+1)*(im+1),im*tip*tip,dg(im)
        ENDDO
      ENDIF
!
      if(btime)call nrb_time(timei)
!
      MLAM=MPOL00-2
 1100 MLAM=MLAM+2
      NGROUP=MLAM/2
!
      IF(NGROUP.EQ.1)THEN
        MP=0
        IF(BPRNT0)THEN
          WRITE(MW6,*)' '
          IF(.NOT.BELONG)WRITE(MW6,10310)
          WRITE(MW6,10300)NGROUP
        ENDIF
        IF(WLG1.LT.DZERO)THEN
          WLG=D1M2
          IF(IDIAG.LT.0.AND.BDEL)WLG=WLG0
        ELSE
          WLG=DZERO
        ENDIF
        WLG=MAX(WLG,WLG1)
        WLGS=DKON
        IF(NPRNT5.GE.0)WLGS=D1M20
!        MPR=5
      ELSE
        MP=5
        IF(BPRNT0)THEN
          WRITE(MW6,*)' '
          IF(.NOT.BELONG)WRITE(MW6,10460)
          IF(NGROUP.LT.10)THEN
            WRITE(MW6,10440)NGROUP,MP
          ELSE
            WRITE(MW6,10450)NGROUP,MP
          ENDIF
        ENDIF
        IF(WLG2.LT.DZERO)THEN
          WLG=D1M7
        ELSE
          WLG=DZERO
        ENDIF
        WLG=MAX(WLG,WLG2)
        WLGS=DKON
!        MPR=5
      ENDIF
!
      BBORN=MENGB.GT.1.OR.(MENGB.EQ.1.AND.NGROUP.NE.1)
      BFOTJ=.NOT.BFOT.OR..NOT.BLAG
!      BFOTJ=BFOTJ.OR.NGROUP.NE.1            !UNCOMMENT TO WRITE E1 ONLY
!
      IF(BSCRO)THEN                                         !MENGB.GE.-1
        MSC=MSC0+NGROUP
        OPEN(MSC,STATUS='SCRATCH',FORM='UNFORMATTED')
      ENDIF
!
      JOS=0
      KTRAN=0
!
      JJMN=1+ione1
      JJMX=NENERG
      IF(JRAD.GT.0)THEN
        IF(JRAD.EQ.2.OR.JRAD.EQ.3.OR.JRAD.EQ.5)JJMN=MAX(JJMN,IAUTO)
        IF(JRAD.EQ.1)JJMX=MIN(IAUTO-1,NENERG)
      ENDIF
      JJMX=MIN(JJMX,LUPMX)
      JJMN=MAX(JJMN,LUPMN-1+ione1)
!
      ILF=ione1
!
!***********************************
! START LOOP OVER UPPER ENERGY CFGS
!***********************************
!
      DO JJ=JJMN,JJMX
!
        ILF=ILF+1
        J=IORIG(JJ)
        if(j.lt.0)go to 1300
        IF(.NOT.BFOT.AND.IWRK3(J).GT.0)GO TO 1300        !CONT BUT NO PI
!
        IIMN=1
        IIMX=JJ-ione1
        if(nmeta.gt.0)iimx=min(iimx,nmeta)
        IF(JRAD.GT.0)THEN
          IF(JRAD.EQ.3)IIMN=MAX(IONE,IAUTO)
          IF(JRAD.EQ.1.OR.JRAD.EQ.2.OR.JRAD.EQ.4)IIMX=MIN(IAUTO-1,IIMX)
        ENDIF
        IIMN=MAX(IIMN,LLOWMN-1+ione1)
        IIMX=MIN(IIMX,LLOWMX)
!
!***********************************
! START LOOP OVER LOWER ENERGY CFGS
!***********************************
!
        ILI=0
!
        DO II=IIMN,IIMX
!
          ILI=ILI+1
          KTRAN=KTRAN+1
          I=IORIG(II)
          if(i.lt.0)go to 1200
          IF(IWRK3(I).GT.0)GO TO 1200          !LOWER CANNOT BE CONT
!
          IF(ABS(MENGB).EQ.1.AND.MOD(NGROUP,ITWO).EQ.1)THEN
            IX=IROW(ILI,ILF,ione1,NSPECE)
            IF(OMR(IX).LT.-TOLO)GO TO 1200     !DIPOLE ALREADY COMPUTED
          ENDIF
!
          BINT=I.LE.J                          !DOWN TRUE
          IF(BINT)THEN
            M1=I
            M2=J
          ELSE
            M1=J
            M2=I
          ENDIF
          I8=M1
          J8=M2
          NP8=ICOL8(I8,J8,IONE)
          NP8=NP8+IADJ8
          K2=NAD(NP8)
          K1=NAD(NP8-1)+1
!
! FIND REQUIRED MULTIPOLE (COULD PRE-DECODE WITH NPOS AS PER DIAGON...)
!
          DO K=K1,K2
            MX=INT(NRK(K)/MXORB2,SP)
            MK=MX
!!        MK=MK+MPOL0/2                                           !FLAGX
            IF(MK.EQ.NGROUP)GO TO 1120            !EXISTS
          ENDDO
          GO TO 1200
!
 1120     n4=MX*MXORB2
          n4=INT(NRK(K)-n4,SP)
!!      if(irlx.lt.0)then
!!        i1=icfgp(m2)*mb+1
!!        i2=icfgp(m1)*mb+1
!!      endif
          M0=int(n4/MXORB,SP)
          NG=M0+I1                        !ORB OF HIGHER ALGEB CF
          NT=n4-M0*MXORB+I2               !ORB OF LOWER ALGEB CF
          M2=MIN(NG,NT)
          M1=NG+NT-M2
          IN=ICOL(M2,M1,IZERO)
!
          dry=denerg(j)-denerg(i)
          if(iwrk3(j).gt.0)dry=dry+dyy(nrel)
          if(dry.gt.dzero)then
            dry=dry+dry
            db=dg(ngroup)*(dry*dfsc)**(mlam-1)/dfsc
          else
            db=dzero
          endif
          if(db.eq.dzero)then                    !avoids overflow*zero
            btest=.not.bfotj.and.iwrk3(j).gt.0
            if(bborn.or.btest)then               !born/pi maybe o.k.
              dlen=dzero
              dvel=dzero
              dacc=dzero
              dry=drk(k)
              obox=dzero
              go to 1140
            else
              go to 1200
            endif
          endif
!
          IN=ICOL(M2,M1,IZERO)
          INV=IXD28+IN
!
! N.B. NGROUP CANNOT BE ZERO HERE BECAUSE DG(0)=0 (FOR BORN)
!
          DB=DOSC(IN,NGROUP/2)
          DRY=DRK(K)                      !ALREADY SQUARED
          DLEN=DB*DB*DRY                  !LENGTH
          IF(DLEN.EQ.DZERO)GO TO 1200
!
          OBOX=DZERO
          IF(MENGB.EQ.-1.AND.ABS(DLEN).GT.WLGO)OBOX=D1P30
!
          IF(BVEL)THEN
            DB=DOSC(INV,NGROUP/2)
            DVEL=DB*DB*DRY                !VELOCITY
          ELSE
            DVEL=DZERO
          ENDIF
!
          IF(BACC)THEN
            DB=ACC(IN)
            DACC=DB*DB*DRY                !ACCELERATION
          ELSE
            DACC=DZERO
          ENDIF
!
 1140     IF(.NOT.BFOTJ.AND.IWRK3(J).GT.0)THEN
                                          !PHOTO
            M7=NFOSS(ngroup/2,M1,M2)
            IF(M7.GT.0)THEN
              DO M8=1,MENG
                DB=DFOSS(M7,M8,1)
                DFOT(M8)=DB*DB*DRY
              ENDDO
            ENDIF
          ENDIF
!
          IF(BINT)THEN
            NU=NG
            NL=NT
          ELSE
            NU=NT
            NL=NG
          ENDIF
!                           CANCELLING OF BINOMS IS INELEGANT, BUT CLEAR
          NUX=NEL(NU,J)
          NLX=NEL(NL,I)
          LWJ=2*QL(NU)+2
          LWI=2*QL(NL)+2
          NWJ=QBINOM(LWJ,NUX)
          NWI=QBINOM(LWI,NLX)
          MWJ=QBINOM(LWI,NLX-1)*NWJ
          MWI=QBINOM(LWJ,NUX-1)*NWI
!
!      if(mwj.ne.mstat(j))write(mw0,*)'j',j,mwj,mstat(j)
!      if(mwi.ne.mstat(i))write(mw0,*)'i',i,mwi,mstat(i)
!
!      NWT=NUX*NLX*NWJ*NWI                        !ABSORBED INTO ALGEBRA
          NWT=1
!
! BORN MULTIPOLES
!
          IF(BBORN)THEN !BORN
            DO IE=1,MENGB
              OBO(IE)=DZERO
            ENDDO
            OMG1=DZERO
            DLAM=2*NGROUP+1
            NH=NGROUP/2
            IN=ICOL(M2,M1,IZERO)
            IF(BINDB(IN,NH))THEN
              IX=INDX(IN)
            ELSE
              WRITE(MW6,*)JJ,II,J,I,NGROUP,M2,M1
              WRITE(MW0,*)'CARATE: BORN M1 M2 NOT FOUND'
              GO TO 2000
            ENDIF
!                   !NOT GREAT, BUT UTILIZES GENERAL (MIXED) CASE SET-UP
            DO N=1,MB4(0)
              L=INDL(N)
              K=INDK(N)
              if(l.ne.k)stop 'carate inl, indk error'
              IF(L.EQ.IX)THEN
                DO IE=1,MENGB
                  DB=DRY*BL(IE,N,NH)
                  OBO(IE)=OBO(IE)+DB
                ENDDO
                IF(NGROUP.EQ.1)THEN
                  DB=DRY*TM2(N)
                  OMG1=OMG1+DB
                ENDIF
                GO TO 1150                        !AS WE ARE DONE FOR CA
              ENDIF
            ENDDO
 1150       DB=DEIGHT*DLAM*NWT
            DO IE=1,MENGB
              OBO(IE)=DB*OBO(IE)
            ENDDO
            OBOX=OBO(MINFB)
            OMG1=DB*OMG1
          ENDIF
!
! ELECTRIC MULTIPOLE
!
          JOS=JOS+1
          DRY=DENERG(J)-DENERG(I)
          IF(DRY.EQ.DZERO)then
            if(mengb.lt.-1)GO TO 1200                !CASE E2 DEGENERATE
            dry=d1m10
          endif
!
          IF(IWRK3(J).GT.0)DRY=DRY+DYY(NREL)
          GFA=DACC/DRY**4                             !as squared
!      gfa=dacc                                       !if orb ener. used
          DRY=DRY+DRY
          MI=II
          MJ=JJ
!     IF(IWRK3(I).GT.0)MI=-MI
          IF(IWRK3(J).GT.0)MJ=-MJ
          WLG=ABS(WLG)
          IF(IWRK3(J).GT.0)WLG=-WLG
!
          DB=DG(NGROUP)*(DRY*DFSC)**(MLAM-1)/DFSC
          SEK=DLEN*NWT                           !SEK_L
          GFL=DB*SEK                             !GF_L
          IF(IWRK3(J).LT.0)AEK=C1*GFL*DRY*DRY/MWJ
                                                 !AEK
          IF(IWRK3(J).GT.0)AEK=C2*GFL/MWI        !PI
!
          IF(AEK*AEK.LT.AEK*WLG.AND.OBOX.LT.WLGO.AND.GFL*GFL.LT.WLGS)   &
     &       GO TO 1200
!
          DB=DB*NWT*DTEN**MP
          DVEL=DVEL/(DRY*DRY)                    !skip if orb ener. used
          GFV=DB*DVEL                            !GF_V
          GFLV=DB*SQRT(DVEL)*SQRT(DLEN)          !SQRT(GF_L*GF_V)
          GFA=DB*GFA                             !GF_A
          WLEN=D1P8/(DRY*DKCM)                   !WAVELENGTH(A)
          GFL=GFL*DTEN**MP                       !GF_L STILL
          IF(.NOT.BELONG.AND.AEK.GT.WLG)THEN     !USE VEL AEK,SEK
            AEK=GFV*AEK/GFL
            SEK=GFV*SEK/GFL
          ENDIF
          FAB=GFL/MWI                            !F(UP)_L
          FEM=GFL/MWJ                            !F(DOWN)_L
!
          IF(NGROUP.EQ.1)THEN
            APOL=DFOUR*FAB/(DRY*DRY)             !POLARIZABILITY
            IF(.NOT.BELONG)APOL=APOL*GFV/GFL
            OMG=DFOUR*GFL/DRY                    !MP=0, NGROUP=1
            IF(ABS(MENGB).EQ.1)THEN
              OMGINF=-ABS(OMG)
              OMG=OMG*LOG(EINF*DZ2)
              OMG=-ABS(OMG)                      !TAG DIPOLE NEGATIVE
              IF(OMG.GE.-TOLO)OMG=DZERO      !ZERO VANISHINGLY SMALL CPT
            ELSEIF(MENGB.GT.1)THEN
              OMG=-ABS(OMG)                      !4S/3
              if(nmeta.eq.0)nmeta=iimx           !pwb
            ENDIF
            if(idw.eq.0)then
              if(nmeta.eq.0)nmeta=nenerg         !for RM
            else
              if(nmeta.eq.0)nmeta=iimx
            endif
          ELSE
            APOL=OBOX                            !COPY BORN IN
            OMG=OBOX
            OMGINF=OMG
          ENDIF
!
! DETERMINE BORN OMEGAS
!
          BPRNTO=.FALSE.
          IF(MPOL00.EQ.0)THEN                 !MPOL0 CATCHES E1
            IF(ABS(MENGB).EQ.1)THEN          !INFINITE ENERGY BORN ONLY
              BPRNTO=.TRUE.
              IXC=ICOL(ILI,ILF,ione1)
              IF(IXC.LE.NOMWRX)OMC(IXC)=OMC(IXC)+OMG
              IXR=IROW(ILI,ILF,ione1,NSPECE)
              IF(IXR.LE.NOMWRX)OMR(IXR)=OMR(IXR)+OMG
              OMEGAB(MXNXB1)=OMGINF
            ELSEIF(MENGB.GT.1.AND.abs(OBO(MINFB)).GT.WLGO)THEN
                                                            !FINITE BORN
              BPRNTO=.TRUE.
              CALL BRNINT(BPRNT0,NLAGB,MXNXB,MV0,MV1,DRY,V0,V1,XB,XS,   &
     &                    DB0,DB1,OMG1,OBO,OMEGAB)
              OMEGAB(MXNXB1)=OMG                   !INFINITE ENERGY
!          if(nlagb.lt.0)go to 3000                !brnint failure
            ENDIF
          ENDIF
!
! OUTPUT ELECTRIC MULTIPOLE DATA.
!
          IF(BPRNT0)WRITE(MW6,10090)JOS,MBLK,MJ,MI,AEK,SEK,GFL,FAB,FEM, &
     &                              WLEN,GFV,GFLV,GFA,APOL
          IF(BPRNTO)THEN
            T=ABS(AEK)
            IF(BSCRO)THEN
              WRITE(MSC)MJ,MI,T,(OMEGAB(K),K=1,MXNXB1)
            ELSE
              OMEGA(0,KTRAN)=OMEGA(0,KTRAN)+REAL(T,RP)
              T=REAL(OMEGA(MXNXB1,KTRAN),WP)
              KMX=MXNXB1
              IF(MOD(NGROUP,ITWO).EQ.1.AND.T.LT.-TOLO)KMX=MXNXB
                                                             !OLD DIPOLE
              DO K=1,KMX
                OMEGA(K,KTRAN)=OMEGA(K,KTRAN)+REAL(OMEGAB(K),RP)
              ENDDO
            ENDIF
          ENDIF
!
          IF(MODE.LT.1)GO TO 1180
          DB=DENERG(I)+DENERG(I)+DEM
          IF(IWRK3(I)*IWRK3(J).LT.0)GO TO 1160
!
          IF(BPRNT0)THEN
            mi=MSTAT(I)
            if(mi.gt.99999)mi=0                 !as I5 - use unformatted
            mj=MSTAT(J)
            if(mj.gt.99999)mj=0                 !as I5 - use unformatted
            WRITE(MW7,10100)J,J,mj,I,I,mi,AEK,DRY,DB
          ELSE
            WRITE(MW27)int(J),int(J),int(MSTAT(J)),int(I),int(I),       &
     &                 int(MSTAT(I)),AEK,DRY,DB
          ENDIF
          GO TO 1180
!
 1160     IF(BFOTJ)GO TO 1200
!
          DC0=C2*DG(NGROUP)*REAL(NWT,WP)/(REAL(MWI,WP)*DFSC)
          T=DENERG(J)-DENERG(I)
          DO M8=1,MENG
            DRY=T+DYY(M8)
            DRY=DRY+DRY
            T1=DRY*DFSC
            TT=T1**NGROUP
            DFOT(M8)=DC0*TT*DFOT(M8)*TT/T1
            IF(BPRNT0.AND.ABS(DFOT(M8)).LT.D1M99)DFOT(M8)=DZERO
          ENDDO
!
          DRY=DENERG(J)+DENERG(J)+DEM
!
! PI DAS IS ALWAYS LENGTH, EVEN WHEN VEL/ACC SET.
!
          IF(BPRNT0)THEN
            mi=MSTAT(I)
            if(mi.gt.99999)mi=0                 !as I5 - use unformatted
            WRITE(MW17,10100)I,I,mi,-J,J,IWRK2(J),AEK,DB,DRY
            WRITE(MW17,10240)(DFOT(M8),M8=1,MENG)
          ELSE
            WRITE(MW29)int(I),int(I),int(MSTAT(I)),int(-J),int(J),      &
     &                 int(IWRK2(J)),AEK,DB,DRY
            WRITE(MW29)(DFOT(M8),M8=1,MENG)
          ENDIF
          GO TO 1200
!
! IN ELECTRIC DIPOLE CASE ADD CONTRIBUTION TO FUNCTIONAL G
!
 1180     IF(NGROUP.EQ.1.AND.INCLUD.NE.0)THEN
!
            IF(LL.GT.0)THEN  !EXCLUDE TRANSITIONS OF ZERO-WEIGHT TERMS
              NN=-1
              DO K=1,LL
                IF(INDEXW(K).EQ.I.OR.INDEXW(K).EQ.J)THEN
                  NN=NN+1
                  IF(NN.GT.0)GO TO 1190
                ENDIF
              ENDDO
              GO TO 1200
            ENDIF
!
 1190       NGF=NGF+1
            GFL=ABS(GFL)
            GFV=ABS(GFV)
            GFLV=ABS(GFLV)
            SGF=(GFL+GFV-2*GFLV)/(GFL+GFV+2*GFLV)+SGF
!
          ENDIF
!
!
 1200   ENDDO                                !END LOOP OVER LOWER CFGS
!
!
 1300 ENDDO                                  !END LOOP OVER UPPER CFGS
!
!
!     END MULTIPOLE LOOP OVER RADIATIVE TRANSITIONS
!
      IF(MLAM.LT.MPOLE)GO TO 1100
!
      DEALLOCATE(DG)
!
      if(btime)then
        call nrb_time(timef)
        times=timef-timei
!par        if(iam.ge.0)then                                        !par
!par          write(iwp,*)'proc',iam,' for carate:'                 !par
!par          write(iwp,*)'    radiative time=',nint(times),'sec'   !par
!par          call flush(iwp)                                       !par
!par        else                                                    !par
        write(iw,*)'radiative time=',nint(times),'sec'
!par        endif                                                   !par
      endif
!
!     WRITE AN INFINITE ENERGY OMEGA FILE
!
      IF(MENGB.GE.-1)THEN                   !BBORN
!
        lupe=NSPECE
!
        IF(ABS(MENGB).EQ.1)THEN            !INF ENG BORN, ROW *AND* COL
!
          IF(MENGB.EQ.-1)THEN
            DO I=1,NOMWRT
              OMR(I)=MIN(OMR(I),D1P30)
              OMC(I)=MIN(OMC(I),D1P30)
            ENDDO
          ENDIF
!
          DO K=1,lupe                       !NENERG
            I=IORIG(K)
!            i=abs(i)
            IWRK3(K)=(1-QCP(I))*MSTAT(I)
            IWRK4(K)=0
            DWRK(K)=DENERG(I)*DTWO/DZ2
          ENDDO
!
          if(nmeta.eq.0)nmeta=nspece                         !case no E1
          if(nmeta.lt.nspece)then
            ixr=irow(nmeta,nspece,ione1,nspece)
            if(ixr.lt.nomwrt)nomwrt=ixr
            ixc=icol(nmeta,nspece,ione1)
          else
            ixc=nomwrt
          endif
          if(nmeta0.eq.0)nmeta=-nmeta
!
          F713='(1PE14.8,6E11.3/(14X,6E11.3))'    !SUPPRESS IFORT REMARK
!
          WRITE(MRW23,*)NZION,MION
          WRITE(MRW23,*)NSPECE,ABS(MENGB),NOMWRT
          WRITE(MRW23,*)(IWRK3(I),IWRK4(I),I=1,NSPECE)
          WRITE(MRW23,10340)(DWRK(I),I=1,NSPECE)
          WRITE(MRW23,F713)EINF,(OMR(I),I=1,NOMWRT)
!
          IF(IDW.EQ.0)THEN                           !COLUMNWISE AS WELL
            NOMWRT=(NSPECE*(NSPECE+1-2*ione1))/2
            if(ixc.lt.nomwrt)nomwrt=ixc
!
            WRITE(MRW23,*)NZION,MION
            WRITE(MRW23,*)NSPECE,ABS(MENGB),-NOMWRT
            WRITE(MRW23,*)(IWRK3(I),IWRK4(I),I=1,NSPECE)
            WRITE(MRW23,10340)(DWRK(I),I=1,NSPECE)
            WRITE(MRW23,F713)EINF,(OMC(I),I=1,NOMWRT)
          ENDIF
!
        ENDIF                                 !SUM BORN MULTIPOLES
!
! WRITE DATA TO ADF04 FILE
!
        BEXP=.FALSE.                          !TRUE=1.0E+0, FALSE=1.0+0
        IF(NSPECE.LT.1000)THEN
          i1=0
          IF(BEXP)THEN
            F761='(F5.2,4X,"1", 8X,20(1PE10.2))'
            F762='(2I4,22(1PE10.2))'
          ELSE
            F761='(F5.2,4X,"1", 6X, 20(A5, A3))'
            F762='(2I4, 22(A5, A3))'
          ENDIF
        ELSE
          i1=1
          IF(BEXP)THEN
            F761='(F5.2,4X,"1",10X,20(1PE10.2))'
            F762='(2I5,22(1PE10.2))'
          ELSE
            F761='(F5.2,4X,"1", 8X, 20(A5, A3))'
            F762='(2I5, 22(A5, A3))'
          ENDIF
        ENDIF
!
!        WRITE(MRW25,542)-1
!                                      !now write orbital energy in s.o.
        cardx=' '
        cardx(4:5)='-1'
        orbfmt='(1x,f7.?)'
!
! truncate to spectroscopic orbitals
        if(bort)then
          isob=0
          inx=0
          do i=1,mxorb
            if(dey(i).ne.dzero)then
              if(dadjus(i).lt.dzero)go to 1350
              isob=i
              in=abs(qn(i))
              inx=max(inx,in)
            endif
          enddo
        else
          isob=mxorb
          inx=abs(qn(isob))
        endif
! re-map
 1350   isox=0
        inx=(inx*(inx+1))/2
!
 1400   allocate(isorb(0:inx))
!
        do i=1,inx
          isorb(i)=0
        enddo
        do i=1,isob
          in=qn(i)
          il=ql(i)/2
          iso=(in*(in-1))/2+il+1
          if(iso.le.inx)isorb(iso)=i
          isox=max(isox,iso)
        enddo
!
        if(isox.gt.inx)then
          deallocate(isorb)
!         write(mw6,*)'***sr.carate: isorb buffer too short, need ',isox
          inx=isox
          go to 1400
        endif
!
        is=9+2*i1
        ie=is+abs(isox)*8
        IF(ie.GT.mxlenx)THEN
                            !note, >200(=7d) not passed by cadwx,adasexj
!          write(mw6,*)'***sr.carate: cardx too short, need mxlenx=',ie
          isox=-(mxlenx-is)/8
        endif
        if(isox.lt.0)then
!          write(mw6,*)'***adf04ca note: truncated orbital energy list'
!!          write(mw0,*)'***adf04ca note: truncated orbital energy list'
          isox=-isox
        endif
! print
        do ix=1,isox
          ie=is+7
          i=isorb(ix)
          t=dzero
          if(i.gt.0)then                !break into two for bounds check
            if(dey(i).ne.dzero)then
              in=icol(i,i,izero)
              t=dey(i)-duy(in)
              if(bmvdr.and.bmvd)t=t+dmass(in)+dcd(in)
              t=-2*t
            endif
          endif
          imt=max(itwo,ifive-max(izero,int(log10(max(t,d1m30)),sp)))
          write(orbfmt(8:8),'(i1)')imt
          write(cardx(is:ie),orbfmt)t
          is=ie+1
        enddo
!
        orbfmt=' '
        orbfmt(1:7)='(a    )'
        write(orbfmt(3:6),'(i4)')ie
        write(MRW25,orbfmt)cardx(1:ie)
!
        deallocate(isorb)
!
        IF(BEXP)THEN
          WRITE(MRW25,F761)REAL(NZA),(XB(K),K=1,MXNXB)
        ELSE
          MSCP=MSC+1
          OPEN(MSCP,STATUS='SCRATCH',FORM='FORMATTED')
          WRITE(MSCP,10390)(XB(K),K=1,MXNXB)
          BACKSPACE(MSCP)
          READ(MSCP,10400)(XMANT(K),IEXP(K),K=1,MXNXB)
          WRITE(MRW25,F761)REAL(NZA),(XMANT(K),IEXP(K),K=1,MXNXB)
        ENDIF
!
        DO M=MSC0,MSC                     !RE-POINT BORN MULTIPOLE FILES
          REWIND(M)
        ENDDO
!
        if(nenerg.eq.1)go to 1500
!
        IOLD=JJMN               !1+ione1
        JOLD=IIMN               !1
        INEW=IOLD
        JNEW=JOLD
        KTRAN=0
!
 1450   IF(BSCRO)THEN
!
          BBORN=.FALSE.
!        DAS=DZERO
          DO K=0,MXNXB1
            OMEGAB(K)=DZERO
          ENDDO
!
          IP=IORIG(IOLD)
          IP=QCP(IP)
          JP=IORIG(JOLD)
          JP=QCP(JP)
          IF(IP.NE.JP)THEN
            MMN=MSC0+1                     !ODD MULTIPOLES
            MMX=MSC+MOD(MSC,ITWO)-1
          ELSE
            MMN=MSC0
            MMX=MSC-MOD(MSC,ITWO)
          ENDIF
!
          IFLAGO=999
          DO M=MMN,MMX,2
            READ(M,END=1460,ERR=1460)I,J,(XS(K),K=0,MXNXB1)
            IF(I.GT.IOLD.OR.J.GT.JOLD)THEN
              BACKSPACE(M)
              GO TO 1460
            ELSE
              if(jold.gt.iimx)then
                if(nmeta0.eq.0)then
                  go to 1460         !unfortunate interchange of i,j use
                else
                  stop '370'
                endif
              endif
              BBORN=.TRUE.
              KMX=MXNXB1
              IF(IP.NE.JP)THEN
                LAM=MOD(M,I80)
                IF(LAM.EQ.1.AND.ABS(XS(MXNXB1)).GT.TOLO)IFLAGO=1 !E1 LIM
                IF(LAM.GT.IFLAGO)KMX=MXNXB    !DON'T OVEFRWRITE E1 LIMIT
              ENDIF
              DO K=0,KMX
                OMEGAB(K)=OMEGAB(K)+XS(K)
              ENDDO
            ENDIF
 1460     ENDDO
!
        ELSE
          KTRAN=KTRAN+1
          DO K=0,MXNXB1
            OMEGAB(K)=REAL(OMEGA(K,KTRAN),WP)
          ENDDO
        ENDIF
!
        IF(BBORN)THEN
          DO K=0,MXNXB
            OMEGAB(K)=ABS(OMEGAB(K))
            IF(OMEGAB(K).LT.D1M99)OMEGAB(K)=DZERO
          ENDDO
          IF(OMEGAB(0).LT.D1M30)OMEGAB(0)=D1M30
          IF(OMEGAB(MXNXB1).GT.D1P30)OMEGAB(MXNXB1)=D1P30
          IF(BEXP)THEN
            WRITE(MRW25,F762)INEW,JNEW,(OMEGAB(K),K=0,MXNXB1)
          ELSE
            BACKSPACE(MSCP)
            WRITE(MSCP,10390)(OMEGAB(K),K=0,MXNXB1)
            BACKSPACE(MSCP)
            READ(MSCP,10400)(XMANT(K),IEXP(K),K=0,MXNXB1)
            WRITE(MRW25,F762)INEW,JNEW,(XMANT(K),IEXP(K),K=0,MXNXB1)
          ENDIF
        ENDIF
!
 1500   JOLD=JOLD+1
        IF(JOLD.GT.IOLD-ione1.or.JOLD.GT.IIMX.and.nmeta0.ne.0)THEN
 1520     IOLD=IOLD+1
          IF(IOLD.GT.lupe)THEN                 !NENERG        !TERMINATE
            WRITE(MRW25,F762)-1
            WRITE(MRW25,F762)-1,-1
            if(.not.badas)then                      !adas skip comments
              WRITE(MRW25,10350)
              NREC=1
 1525         NREC=NREC+1
              BACKSPACE(MR5)
              BACKSPACE(MR5)
              READ(MR5,10410)CARD4
              IF(CARD4.NE.'A.S.'.AND.CARD4.NE.'S.S.')GO TO 1525
              REWIND(MR5)
              DO N=1,NREC
                READ(MR5,10370)CARD
                WRITE(MRW25,10360)CARD
              ENDDO
              DATE='        '
              CALL DATE_AND_TIME(DATE)
              WRITE(MRW25,10380)DATE(7:7),DATE(8:8),DATE(5:5),DATE(6:6),&
     &                          DATE(3:3),DATE(4:4)
            endif
            DO M=MSC0,MSC
              CLOSE(M)
            ENDDO
            IF(.NOT.BEXP)CLOSE(MSCP)
          ELSE
            IF(IORIG(IOLD).LT.0)GO TO 1520
            JOLD=IIMN          !1
            JNEW=IIMN          !1
            INEW=INEW+1
            GO TO 1450
          ENDIF
        ELSE
          IF(IORIG(JOLD).LT.0)GO TO 1500
          JNEW=JNEW+1
          GO TO 1450
        ENDIF
      ENDIF
!
! DE-ALLOCATE
!
 1600 CONTINUE
!
      IF(BOMRC)THEN
        DEALLOCATE(OMR,OMC,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'CARATE: DE-ALLOCATION FAILS FOR OMR,OMC'
          NF=MIN(NF,IZERO)
        ENDIF
        BOMRC=.FALSE.
      ENDIF
!
      IF(ALLOCATED(OMEGA))THEN
        DEALLOCATE(OMEGA,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'CARATE: DE-ALLOCATION FAILS FOR OMEGA'
          NF=MIN(NF,IZERO)
        ENDIF
      ENDIF
!
      IF(NF.LE.0)GO TO 1800                                      !RETURN
!
! UPDATE FUNCTIONAL (RE-ENTRY POINT IF NO RADIATION)
!
      IF(NGF.NE.0)SGF=DTWO*SGF/NGF
 1700 DRY=DF
      IF(IOPTIM.EQ.0)DRY=DRY+DECORE
      DRY=DRY*DTWO
      IF(BPRNT0)THEN
        WRITE(MW6,10600)INCLUD,DRY,SGF,NGF,JPRINT    !BELOW IS REDUNDANT
!    IF(DRY.NE.DZERO.AND.IWGHT.EQ.1)WRITE(MW6,10615) !AS WEIGHTS SHOW IT
      ENDIF
      IF(JPRINT.EQ.-2)THEN
        DF=SGF
        if(includ.ne.0)WRITE(MW6,10590)
        DECORE=DZERO
      ENDIF
!
! WRITE TERMINATORS
!
 1800 IF(MODE.GT.0)THEN
        IF(BPRNT0)WRITE(MW7,10220)MBLK
        IF(.NOT.BPRNT0)WRITE(MW27)int(IZERO),int(IZERO),int(IZERO),     &
     &                            int(IZERO),int(IZERO),int(IZERO),     &
     &                            DZERO,DZERO,DZERO
      ENDIF
      IF(.NOT.BFOTJ)THEN
        IF(BPRNT0)WRITE(MW17,10220)MBLK
        IF(.NOT.BPRNT0)WRITE(MW29)int(IZERO),int(IZERO),int(IZERO),     &
     &                            int(IZERO),int(IZERO),int(IZERO),     &
     &                            DZERO,DZERO,DZERO
      ENDIF
!
! LOCAL DEALLOCATE
!
      IF(ALLOCATED(DPA))THEN
        DEALLOCATE(DPA,STAT=IERR)   !
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'CARATE: DE-ALLOCATION FAILS FOR DPA'   !,DP
          NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(ITMP))THEN
        DEALLOCATE(ITMP,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'CARATE: DE-ALLOCATION FAILS FOR ITMP'
          NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(DENERG))DEALLOCATE(DENERG,IWRK2,IORIG)
!
      IF(ALLOCATED(DWRK))DEALLOCATE(DWRK,IWRK3,IWRK4)
!
! CLOSE SOME FILES
!
      IF(IUNIT(MW1).GT.0)THEN
        CLOSE(MW1)
        IUNIT(MW1)=-1
      ENDIF
      IF(IUNIT(MRW3).GT.0)THEN
        CLOSE(MRW3)
        IUNIT(MRW3)=-1
      ENDIF
      IF(IUNIT(MW4).GT.0)THEN
        CLOSE(MW4)
        IUNIT(MW4)=-1
      ENDIF
      IF(IUNIT(MW21).GT.1)THEN
        CLOSE(MW21)
        IUNIT(MW21)=-1
      ENDIF
      IF(IUNIT(MRW23).GT.1)THEN               !so par scratch not closed
        CLOSE(MRW23)
        IUNIT(MRW23)=-1
      ENDIF
      IF(IUNIT(MRW25).GT.1)THEN
        CLOSE(MRW25)
        IUNIT(MRW25)=-1
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
 1900 IF(NF.GT.0)NF=-1
      GO TO 1800                                            !DE-ALLOCATE
!
 2000 IF(NF.GT.0)NF=-1
      GO TO 1600                                            !DE-ALLOCATE
!
!-----------------------------------------------------------------------
!
10010 FORMAT(I6,' CALC ',F10.1,'     OBS ',F10.1,'   SQ-DIF.SUM',E16.5)
10020 FORMAT(88X,'R OF 3 LAST P(R):',3F9.2)
10030 FORMAT(' ',I3,I7,I3,F14.5,13X,I4)
10040 FORMAT(//' GAM ( N,  L,NION, Z,SIG/D/P)  EPSILON/RY      <1/R>  ',&
     &  '<Z/R-V>      <R>   <R**2>   <R**3>   (ADJUST, REND, 3 LAST P) '&
     &  ,'IN',I8,' STEPS')
10050 FORMAT(//' GAM ( N,  L,NION, Z,Q.D/D/P)  EPSILON/RY      <1/R>  ',&
     &  '<Z/R-V>      <R>   <R**2>   <R**3>   (ADJUST, REND, 3 LAST P) '&
     &  ,'IN',I8,' STEPS')
10060 FORMAT(5I4,F9.5,F13.5,1X,3F9.5,2F9.4,2X,F8.4,F6.2,1X,3(1PE9.2))
10070 FORMAT(22X,'2MXLBD=',I3)
10080 FORMAT(//'   C      W (P)  H(ZZ)/2RY',14X,'   CF  E(CORE)/2RY =', &
     &       F10.4,F11.4)
10090 FORMAT(1X,I4,A4,2I4,1PE15.3,0PF14.7,F16.6,3X,2F10.5,F12.4,4F12.4)
10100 FORMAT(6I5,1PE15.5,2(0PF15.6))
10110 FORMAT(I9,2I4,1PE15.3,2(0PF15.4))
10120 FORMAT(60X,F15.6)
10130 FORMAT(//8X,'W',3X,'C  CP',8X,'AA*SEC',6X,'ECONT(A.U)',7X,        &
     &       'E-I(A.U)')
10140 FORMAT(8X,'I-S',12X,'C-S',11X,'AUTO-IONIZATION DATA',7X,'Z=',I2,  &
     &       3X,'N=',I2/3X,'CF',4X,'C',4X,'W',3X,'CF',4X,'C',4X,'W',6X, &
     &       'AA*SEC',9X,'E-C(RYD)',6X,'E-I(RYD)')
10150 FORMAT(5I5,4X,'X',1PE15.5,2(0PF15.6))
10160 FORMAT(I3,'CFCA',2X,'G',3X,'Z=',I2,4X,'N=',I2,2X,'NL',62(I3,I2))
10170 FORMAT(I5,'CA',2X,'G',3X,'Z=',I2,4X,'N=',I2,2X,'NL',62(I3,I2))
10180 FORMAT(8X,'I-S',12X,'G-S',15X,'RADIATIVE DATA',9X,'Z=',I2,3X,'N=',&
     &       I2/3X,'CF',4X,'C',4X,'W',3X,'CF',4X,'C',4X,'W',6X,'AR*SEC',&
     &       9X,'DEL(RYD)',6X,'E-G(RYD)')
10190 FORMAT('+',67X,'(AA DATA INCLUDES CFG-AV ENERGY CORRECTION)')
10200 FORMAT(4X,'NCFGS=',I5,39X,'E1/RY=',F15.6/4X,'I',4X,'C',9X,'W',13X,&
     &       'CF',5X,'(EI-E1)/RY')
10210 FORMAT(2I5,I10,5X,I10,F15.6,I10)
10220 FORMAT(A4)
10230 FORMAT(I3,' E(RYD) ',2X,'Z=',I2,4X,'N=',I2,5X,'Config-Average',8X,&
     &       'EIONMIN=',F15.6)
10240 FORMAT(5(1PE15.5))
10250 FORMAT(8X,'I-S',12X,'C-S',10X,'PHOTO-IONIZATION DATA',7X,'Z=',I2, &
     &       3X,'N=',I2/3X,'CF',4X,'C',4X,'W',3X,'CF',4X,'C',3X,'EO',6X,&
     &       ' P/CM2',9X,'E-I(RYD)',6X,'E-C(RYD)')
10260 FORMAT(2I5,4X,I1,I2,1X,10(I2,A1))
10270 FORMAT(' &ADASEX NCFG= XXX',' &END')                      !,I3
10280 FORMAT('NAME:'/'DATE:'/'.')
10290 FORMAT(A2,'+',I2,2I10,F15.4,A4)
10300 FORMAT('   E',I1,'-DATA  I  IP',6X,'A(EK)*SEC         S    ',12X, &
     &       'G*F',8X,'F(ABS)   -F(EMI)    WAVEL/AE',5X,                &
     &       'GF(VEL)  V(GFL*GFV)',5X,'GF(ACC)',2X,'ALPHA(POL)')
10310 FORMAT(24X,'VELOCITY',6X,'VELOCITY',91X,'VELOCITY')
10320 FORMAT(/' GAM   I(A,C) = ONE-BODY INTEGRALS')
10330 FORMAT(1X,I3,9F14.7/(4X,9F14.7))
10340 FORMAT(1P,5E16.6)
!10350 FORMAT(1PE14.8,6E11.3/(14X,6E11.3))
10350 FORMAT('C',79('-')/'C'/'C')
10360 FORMAT('C ',A200)
10370 FORMAT(A200)
10380 FORMAT('C'/'C'/'C',79('-')/'C'/'C',1X,                            &
     &       'AUTOSTRUCTURE PLANE-WAVE BORN'/'C'/'C NAME:'/'C DATE: ',  &
     &       2(A1),'/',2(A1),'/',2(A1)/'C'/'C',79('-'))
10390 FORMAT(22(1PE9.2))
10400 FORMAT(22(A5,1X,A3))
10410 FORMAT(A4)
10420 FORMAT(I6,40(F6.3))
10430 FORMAT(/"CONFIGURATION OVERLAP MATRIX (SET TO ZERO IF CF'S DIFFER"&
     &       ," BY MORE THAN 2 PAIRS) CASE IRLX=2:"/6X,40(I6))
10440 FORMAT('   E',I1,'-DATA  I  IP',6X,'A(EK)*SEC         S    ',4X,  &
     &       '10**',I1,'*','  G*F',7X,'*F(ABS)   -F(EMI)    WAVEL/AE',  &
     &       4X,'*GF(VEL) *V(GFL*GFV)',4X,'*GF(ACC)',3X,'OMG(BORN)')
10450 FORMAT('  E',I2,'-DATA  I  IP',6X,'A(EK)*SEC         S    ',4X,   &
     &       '10**',I1,'*','  G*F',7X,'*F(ABS)   -F(EMI)    WAVEL/AE',  &
     &       4X,'*GF(VEL) *V(GFL*GFV)',4X,'*GF(ACC)',3X,'OMG(BORN)')
10460 FORMAT(24X,'VELOCITY',6X,'VELOCITY')
10470 FORMAT(' CORE CONTRIB. ',F12.4,F12.5)
10480 FORMAT(//9X,'ONE-BODY RELATIVISTIC CORRECTIONS TO INDIVIDUAL ',   &
     &       'ORBITALS IN UNITS OF 2*RY',35X,'CA.JPRINT =',I4/9X,       &
     &       'GAM    N    LE(NON.REL)',8X,'E(MASS)',6X,'E(DAR)',7X,     &
     &       'E(TOT)',23X,'<P**2/RY>')
10490 FORMAT(7X,3I5,F14.6,3X,2F12.6,F13.7,20X,F12.6)
10500 FORMAT(/' ONE-BODY RELATIVISTIC INTEGRALS'/' I(R)  I(  A,  C ) = '&
     &       ,6X,'MASS',9X,'DARWIN',24X,'<P**2>')
10510 FORMAT(I5,3X,2I4,3X,2F14.7,16X,F14.7)
10520 FORMAT(8X,'W P',3X,'CF',7X,'ENERGY(RYD)')
10530 FORMAT(//'*** ATTN: BECAUSE BORN MULTIPOLES ARE BEING COMPUTED',  &
     &     ' FOR NON-E1 TRANSITIONS, RADIATIVE DATA IS NOT COMPUTED FOR'&
     &     ,' THOSE E3 TRANSITIONS'/10X,'FOR WHICH E1 DATA ALREADY',    &
     &     ' EXISTS (SO AS NOT TO OVERWRITE THE E1-LIMIT)'/)
10540 FORMAT(/' *** WORKING ARRAYS TOO SMALL IN SR.CARATE, INCREASE',   &
     &       ' MXAAI TO:',                                              &
     &       I6/' *** OR REDUCE NUMBER OF SPECTROSCOPIC CFGS')
10550 FORMAT(I9,I2,I5,F18.6,3X,A4)
10560 FORMAT(2I10,F13.0,I7,I5,A4,F8.3,F18.6,I10)
10570 FORMAT(8X,' I',9X,'C',8X,'K*CM',2X,'     W   CF',5X,'WEIGHTS',8X, &
     &       '(EI-E1)/RY     E1/RY =',F14.6)
10580 FORMAT(//I6,' (IF .GT. 0: LOWEST STAT-WEIGHTED) CFS ARE',         &
     &       ' MINIMIZED;      SCALING PARAMETERS ',5F9.5,/((84X,5F9.5))&
     &       )
10590 FORMAT(68X,'*WARNING*  G WILL BE MINIMIZED, AS JPRINT=-2')
10600 FORMAT(//9X,'INCLUD =',I5,9X,'FUNCTIONAL F =',1PE14.7,9X,         &
     &       'FUNCTIONAL G =',E10.3,' (',I4,' TRANSITIONS)',9X,         &
     &       'CA.JPRINT=',I2//)
!10615 FORMAT(9X,'THE ENERGY FUNCTIONAL IS THE ARITHMETIC MEAN OF THE ',
!     &       'CONFIGURATION (AVERAGE) ENERGIES'//)
10610 FORMAT(33X,I1,'-POLE PERTURBED TFDA POTENTIAL SCALING PARAMETERS '&
     &       ,5F9.5,/((84X,5F9.5)))
10620 FORMAT(80A1)
10630 FORMAT(/25X,' Q.E.D. CONTRIBUTIONS /2RY'/8X,'  GAM    N    L',3X, &
     &       'VACUUM POLARIZ.',6X,'SELF ENERGY',9X,'TOTAL')
10640 FORMAT(8X,3I5,3(2X,F15.7),2F10.5)
10650 FORMAT(2I5)
10660 FORMAT(30(I3,I2))
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!-----------------------------------------------------------------------
      FUNCTION ICOL8(I8,J8,IONE1)
!
      INTEGER(SP) IONE1
      INTEGER(EP) I8,J8,ICOL8
!
      ICOL8=((J8-1)*(J8-2*IONE1))/2+I8
!
      END FUNCTION ICOL8
!-----------------------------------------------------------------------
      FUNCTION IROW(ILI,ILF,IONE1,NENG)
!
      INTEGER(SP) ILI,ILF,IONE1,NENG,IROW
!
      IROW=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE1))/2
!
      END FUNCTION IROW
!-----------------------------------------------------------------------
!
      END SUBROUTINE CARATE
!
!                             *******************
!
      SUBROUTINE CASYM(KACT,MXCF)
!
!-----------------------------------------------------------------------
!
!  SR.CASYM
!     SETS-UP THE CA "SYMMETRIES" AND "CHANNEL" LIST BASED-UPON THE USER
!     SPECIFIED MINLT, MAXLT.
!     SLIGHT OVERKILL FOR CA, BUT "REUSES" SYMLS .c.f. ALGXLS.
!
!  IT IS CALLED BY:
!    SR.ALGX
!
!  IT CALLS:
!    SR.DIMUSE
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_QTG,    ONLY: MTGD,NXLL,NTT,NTG,JTGD,QTGS,QTGL,QTGD    &
     &                        ,NFI,NFK,NFQ
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      use common_misc,   only: ione1,ione0
!
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,INAST0=>NASTB                            &
     &                        ,INASTJ0=>NASTJB,LFACT,JFACT              &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
!T      USE COMMON_NRBDWX, ONLY: MAXLX0
      USE COMMON_NRBIAD, ONLY: IADD
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION KACT(MXCF,*)
!
!-----------------------------------------------------------------------
!
      if(ione1.eq.0)then
        write(mw6,*)'Re-setting IONE1=1 since elastic not coded for CA'
        write(mw0,*)'Re-setting IONE1=1 since elastic not coded for CA'
        ione1=1
      endif
!
!-----------------------------------------------------------------------
!
! INITIALIZATIONS
!
      BPRNT0=JPRINT.NE.-3
!
      BTHRSH=LVMAX.GE.0
!
! SCATTERING SYMMETRY RESTRICTIONS
!
      IF(MXLAMX.EQ.1000)THEN                     !MAX EXCHANGE MULTIPOLE
        IF(MAXLX.GE.100)THEN
!X          MXLAMX=NXLL+3                    !TWICE MAX ORB L+3 (was +1)
          MXLAMX=NXLL/2+NMULTX-1             !NMULTX=NO. LAMBDAS:  GEFGW
        ELSE
!          MXLAMX=(MAXLX+1)/2
          MXLAMX=MAXLX-NXLL/2
        ENDIF
      ENDIF
!
!      IF(MAXLX.GE.100)MAXLX=2*MXLAMX                !MAX L FOR EXCHANGE
      IF(MAXLX.GE.100)MAXLX=MXLAMX+NXLL/2            !MAX L FOR EXCHANGE
!T      IF(MAXLX.LT.MAXLT+2)THEN      !CA only for comparison with LS/BP
!T        MAXLX=MAX(MAXLX,QCL0/2-1)   !NEED ALL CHANNELS TO SCALE DIRECT
!T      ENDIF
!T      MAXLX0=MAXLX                !PASS THRU TO CAFLGLX FOR CHECK ONLY
!
      WRITE(MW6,10050)
      WRITE(MW6,10100)MAXLX
      IF(MXLAMX.NE.1000)WRITE(MW6,10020)MXLAMX
      IF(NMULTX.LT.100)WRITE(MW6,10030)NMULTX
!
      IF(INAST0.GT.0)THEN                        !FOR PARALLEL OPERATION
!
        WRITE(MW6,10110)
        MAXLT=0
        DO I=1,INAST0
          IS=LSPI(I)/10000
          if(is.ne.0)then              !case user specifies serial as ls
            IP=LSPI(I)-IS*10000
            IL=IP/10
            IP=IP-IL*10
          else                                  !internal parallel spec.
            IL=LSPI(I)
          endif
          WRITE(MW6,10120)I,IL
          LSPI(I)=IL                                               !ibid
          MAXLT=MAX(MAXLT,IL)
        ENDDO
        MAXLT=-MAXLT                                     !FLAG FOR CALGX
!
      ELSE
!
        IF(BTHRSH)THEN
!
          MAXL=LVMAX+QCL0/2
          IF(MAXLT.EQ.1000)MAXLT=MAXL
          IF(MAXLT.GT.MAXL)THEN
            WRITE(MW6,10050)
            WRITE(MW6,10060)MAXL,LVMAX
            WRITE(MW6,10050)
            MAXLT=MAXL
          ELSEIF(MAXLT.LT.MAXL)THEN
            WRITE(MW6,10050)
            WRITE(MW6,10070)MAXLT,LVMAX,MAXL
            WRITE(MW6,10050)
!            MAXLT=MAXL                       !ALLOW USER TO RESTRICT...
          ENDIF
!
          MINL=LVMIN-QCL0/2
          MINL=MAX(IZERO,MINL)
          IF(MINLT.GT.MINL)THEN
            WRITE(MW6,10050)
            WRITE(MW6,10080)MINLT,LVMIN,MINL
            WRITE(MW6,10050)
!            MINLT=MINL                       !ALLOW USER TO RESTRICT...
          ELSEIF(MINLT.LT.MINL)THEN
            WRITE(MW6,10050)
            WRITE(MW6,10090)MINL,LVMIN
            WRITE(MW6,10050)
            MINLT=MINL
          ENDIF
!
        ELSE
!
          IF(MAXLT.EQ.1000)MAXLT=30
          IF(MAXLT.GT.100)THEN
            MAXLT=100
            WRITE(MW0,*)'*** SR.CASYM: REDUCING MAXLT TO',MAXLT
            MINLT=MIN(MINLT,MAXLT)
          ENDIF
!
          IF(MINLT.LT.0)MINLT=0
!
        ENDIF
!
        WRITE(MW6,10130)MINLT,MAXLT
!
      ENDIF
!
      WRITE(MW6,10050)
!
! SET-UP SCATTERING SYMMETRY (L-VALUE) LIST
!
      IF(INAST0.GT.0)THEN
!
        INAST=INAST0
        LFACT=100
!
      ELSE
!
        INAST=0
!
        FACTL=REAL(LFACT,WP)/D100
        IL=MINLT
        IAXSL=0
!
   50   INAST=INAST+1
        BLX=INAST.LE.IAXSL
        IF(BLX)LSPI(INAST)=IL
!
        if(lfact.gt.100)il0=il
        IF(IL.GT.MAX(MAXLX,15_SP))IL=NINT(IL*FACTL,SP)
        IL=IL+1
        IF(IL.LE.MAXLT)GO TO 50
!
        IF(IAXSL.EQ.0)THEN
          ALLOCATE(LSPI(INAST))
          IAXSL=INAST
          INAST=0
          IL=MINLT
          GO TO 50
        ENDIF
!
        if(lfact.gt.100)then
          if(lrglam.gt.il0)lrglam=il0               !case factl "misses"
          maxlt=il0
        endif
!
        CALL DIMUSE('MAXSL',INAST)
!
        IF(INAST.GT.MAXSL)THEN
          IF(MAXSL.GT.0)WRITE(MW6,10040)INAST,MAXSL
        ENDIF
!
      ENDIF
!
! SET-UP "CHANNEL LIST" - WE NEED THE NUMBER OF INTERACTIONS.
!
      NNN=0
      INAST0=INAST                     !SINCE WILL REDUCE IF NO CHANNELS
      IX=0
!
      DO I0=1,INAST0
!
        IX=IX+1
        IL=LSPI(IX)
        MTL=IL+IL
!
!          if(il.gt.maxlx)go to 60                             !nx
        IF(BPRNT0)WRITE(MW6,10160)IX,IL
!
!        lcon0=4*((nmultx-1)/2)                                   !local
        LUP=0
        LLOW=999
        NN=0
!
        DO KF=1+ione1,KMAX
          DO KG=1,KF-ione1
!
            IF(KACT(KG,KF).GE.0)THEN
!
              L1=KACT(KF,KG)
              L1=QL(L1)
              L2=KACT(KG,KF)
              L2=QL(L2)
!
              L12M=ABS(L1-L2)
              L12=L1+L2
!
              LCON=L12
   55         LMIN=MTL-LCON
              IF(LMIN.LT.0)THEN                !EFFECTIVE MULTIPOLE LOOP
                LCON=LCON-IFOUR
                IF(LCON.GE.L12M)GO TO 55
                LMIN=ABS(MTL-L12M)
              ENDIF
!
              LCON=MIN(L12,LCONDW-1)                             !GLOBAL
!              lcon0=3*abs(l1-l2)                                !local
!              if(l12m.eq.2)lcon=min(lcon,14)                    !dipole
!
              MT=MTL-LCON
              IF(LMIN.LT.MT)THEN
                LMIN=MT
                IF(MOD(L12/2,ITWO).NE.MOD(LCON/2,ITWO))LMIN=LMIN+2
                                                                  !ALIGN
              ENDIF
!
              LMAX=MTL+L12
              MT=MTL
!              MT=MAX(MT,LMIN) !NEED MEMORY REPOINTED AS ACCESSES>LCONDW
              MT=MT+LCON
              IF(LMAX.GT.MT)THEN
                LMAX=MT
                IF(MOD(LMIN/2,ITWO).NE.MOD(LMAX/2,ITWO))LMAX=LMAX-2
                                                                   !ALGN
              ENDIF
!
              IF(LMAX.GE.LMIN)THEN
                IF(BPRNT0)WRITE(MW6,10150)KF,KG,LMIN/2,LMAX/2
                NN=NN+1+(LMAX-LMIN)/4
                LUP=MAX(LUP,LMAX)
                LLOW=MIN(LLOW,LMIN)
              ENDIF
!
            ENDIF
!
          ENDDO
        ENDDO
!
! 60    continue
!
        IF(BTHRSH.AND.(LVMAX.LT.LLOW/2.OR.LVMIN.GT.LUP/2))NN=0  !DROP
!
        IF(NN.GT.0)THEN
          NNN=NNN+NN
          IF(.NOT.BPRNT0)WRITE(MW6,10140)IX,IL,NN
        ELSE                                            !QUIETLY DISCARD
          INAST=INAST-1
          DO I=IX+1,INAST0
            LSPI(I-1)=LSPI(I)
          ENDDO
          IX=IX-1
        ENDIF
!
      ENDDO                                           !END SYMMETRY LOOP
!
      IADD=NNN                    !N.B. USED TO ALLOCATE NAD IN SR.CALGX
!
      IF(IADD.GT.MAXAD)THEN
        IF(MAXAD.GT.0)WRITE(MW6,10010)IADD,MAXAD
      ENDIF
!
! NOT USED
! 999  WRITE(MW6,190)
!      NF=-1                                                      !ABORT
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT('SR.CASYM: ALLOCATION INCREASES NUMBER OF MATRIX ',        &
     &       ' ELEMENTS IADD =',I10,'.GT.MAXAD=',I10)
10020 FORMAT(/44X,' MAX EXCHANGE LAMDA (MXLAMX)=',I3)
10030 FORMAT(/44X,' No. OF MULTIPOLES (NMULTX) =',I3)
!  190 FORMAT( ' SR.CASYM: FAILURE - CASE SKIPPED')
10040 FORMAT('***SR.CASYM: ALLOCATION INCREASES NUMBER OF SYMMETRIES ', &
     &       ' IAXSL =',I3,' .GT. MAXSL=',I3)
10050 FORMAT(//1X,136('-')//)
10060 FORMAT(/' NOTE: REDUCING MAXLT TO',I3,', THAT NEEDED BY LVMAX=',  &
     &       I3)
10070 FORMAT(/' ***WARNING: YOU HAVE SET MAXLT=',I3,', LESS THAN THAT', &
     &       ' FORMALLY NEEDED BY LVMAX=',I3/22X,'SET MAXLT=',I3,       &
     &       ', TO SATISFY TRIANGLE RELATION')
10080 FORMAT(/' ***WARNING: YOU HAVE SET MINLT=',I3,', GREATER THAT',   &
     &       ' FORMALLY NEEDED BY LVMIN=',I3/22X,'SET MINLT=',I3,       &
     &       ', TO SATISFY TRIANGLE RELATION')
10090 FORMAT(/' NOTE: INCREASING MINLT TO',I3,', THAT NEEDED BY LVMIN=',&
     &       I3)
10100 FORMAT(' *** PARTIAL WAVE SYMMETRY RESTRICTIONS:',5X,'MAXIMUM',   &
     &       ' EXCHANGE L (MAXLX) =',I3)
10110 FORMAT(//'   SY   L')
10120 FORMAT(1X,2I4)
10130 FORMAT(//' MINLT=',I2,3X,'MAXLT=',I3)
10140 FORMAT(' SY=',I3,5X,' LF=',I4,5X,'NC=',I4)
10150 FORMAT(20X,2I5,2X,2I4)
10160 FORMAT(/' SY=',I3,5X,'  L=',I4,'    C','   CP',3X,'LP=...,+2')
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE CASYM
!
!                             *******************
!
      SUBROUTINE CAVE(KF,EAV)
!
!-----------------------------------------------------------------------
!
!  SR.CAVE DETERMINES THE AVERAGE ENERGY OF CONFIGURATION KF
!  USING ORBITALS (PREVIOUSLY GENERATED) STORED IN COMMON /RADF/.
!  IT OMITS ANY COMMON CLOSED-SHELL CORE SINCE WE ARE ONLY INTERESTED
!  IN RELATIVE DIFFERENCES BETWEEN CONFIGURATIONS: RELAXED-UNRELAXED.
!
!  IT IS CALLED BY:
!    SR.CAVE0
!
!  IT CALLS:
!    SR.YLAMK
!    SR.WEDDLE
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
      USE COMMON_REL,    ONLY: DMASS,DCD,D2LL
!
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBNF2, ONLY: DETA,DXSI,DZL,DXTWO
      USE COMMON_NRBQED, ONLY: VPINT,SLFINT,QED
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBVAL, ONLY: FACT,IVAL,NNEW,NNOLD,BJUMP,BJUMP2,BRAD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TOLW=D1M3)    !TOLERANCE FOR MATCHING OCCUPATION NOS WK
!
      ALLOCATABLE :: DA(:),DPA(:),POT(:),DP(:)
!
!-----------------------------------------------------------------------
!
! LOCAL
      ALLOCATE(DA(MAXRS),DPA(MAXRS),POT(MAXRS),DP(MAXRS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CAVE: ALLOCATION FAILS FOR DA,DPA,POT,DP'
        NF=0
        EAV=DZERO
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
      BMVDR=ALLOCATED(DCD)
!
!-----------------------------------------------------------------------
!
      BREL2=ABS(IREL).EQ.2
      AJUST=DONE
!
! RESTRICT RANGE OF ORBITALS
! (N.B. FOR CUP='CA', ENERGIES ARE CALCULATED IN CARATE AND SO WE CAN
!  OMIT RYDBERG HERE, AS WE MUST SINCE RELAXED ARE COMPUTED ONCE ONLY)
!
      MXB=0
      DO J=1,MXORB         !FIRST (RELAXED) CALL   !SECOND (UNIQUE) CALL
        IF(DEY(J)*NEL(J,KF).NE.DZERO.AND.QN(J).GT.0.AND.ival(j).EQ.0)   &
     &     MXB=J
      ENDDO
!      write(mw0,*)kf,mxb
!
! INITIALIZE POT(I)
!
      DO I=1,MAXRS
        POT(I)=DZERO
      ENDDO
!
      IDIR=0                                  !INCLUDE DIRECT 2-BODY
      IXCH=0                                !INCLUDE EXCHANGE 2-BODY
!t      idir=1
!t      ixch=1
!
! FORM CONFIGURATION AVERAGE POTENTIAL
!
      DO J=1,MXB                           !LOOP OVER FIRST ELECTRON
!
        IF(NEL(J,KF).NE.0)THEN
!
          IF(IDIR.EQ.0)THEN                 !PRE-CALC DIRECT YLAMK=0
!
            IF(BREL2)THEN
              DO I=1,MAXRS
                DP(I)=DPNL(I,J)*DPNL(I,J)+DQNL(I,J)*DQNL(I,J)
              ENDDO
            ELSE
              DO I=1,MAXRS
                DP(I)=DPNL(I,J)*DPNL(I,J)
              ENDDO
            ENDIF
!
            MI=QL(J)+2
!
            CALL YLAMK(IZERO,MI,DP,DPA,DD1,DD2,MNH,DHNS,MJH,IZERO)
!                                                             !NO RETARD
            F0=REAL((MI-1),WP)/REAL((2*MI-3),WP)
            MJX=MIN(INT(QL(J),SP),IEIGHT)
!
          ENDIF
!
          K0=MAX(J,MB+1)                  !EXCLUDE ANY CLOSED CORE  !MB0
!
          DO K=MXB,K0,-1                  !LOOP OVER SECOND ELECTRON
!
            BEQNL=J.EQ.K
!
            C=NEL(K,KF)
            IF(BEQNL)C=(C-DONE)/DTWO
!
            IF(ABS(C).GT.TOLW)THEN
!
              C=C*ABS(NEL(J,KF))
!
              IF(IDIR.EQ.1)GO TO 5
!
! DIRECT
!
              IF(BEQNL.AND.MJX.GT.0)THEN
!
                IF(BREL2)THEN
                  DO I=1,MAXRS
                    DP(I)=DPNL(I,J)*DPNL(I,J)+DQNL(I,J)*DQNL(I,J)
                  ENDDO
                ELSE
                  DO I=1,MAXRS
                    DP(I)=DPNL(I,J)*DPNL(I,J)
                  ENDDO
                ENDIF
!
                DO MJ=2,MJX,2
!
                  CALL YLAMK(MJ,MI,DP,DA,DD1,DD2,MNH,DHNS,MJH,IZERO)
!                                                             !NO RETARD
                  DC1=VCC(INT(QL(J),SP),2*MJ,INT(QL(J),SP),IZERO,IZERO, &
     &                IZERO)
                  F=-F0*DC1*DC1/(MI-1)
!                write(mw6,*)j,k,ql(j),2*mj,ql(j),'  f=',f
!
                  DO I=1,MAXRS
                    DPA(I)=DPA(I)+F*DA(I)
                  ENDDO
!
                ENDDO
!
              ENDIF
!
              IF(BREL2)THEN
                DO I=1,MAXRS
                  POT(I)=POT(I)-C*DPA(I)                                &
     &                   *(DPNL(I,K)*DPNL(I,K)+DQNL(I,K)*DQNL(I,K))
                ENDDO
              ELSE
                DO I=1,MAXRS
                  POT(I)=POT(I)-C*DPA(I)*DPNL(I,K)*DPNL(I,K)
                ENDDO
              ENDIF
!
! EXCHANGE
!
    5         IF(.NOT.BEQNL.AND.IXCH.EQ.0)THEN
!
                ME1=ABS(QL(J)-QL(K))/2
                ME2=(QL(J)+QL(K))/2
                MI=ME2+2
                ME2=MIN(ME2,8_SP)
!
                IF(BREL2)THEN
                  DO I=1,MAXRS
                    DP(I)=DPNL(I,J)*DPNL(I,K)+DQNL(I,J)*DQNL(I,K)
                  ENDDO
                ELSE
                  DO I=1,MAXRS
                    DP(I)=DPNL(I,J)*DPNL(I,K)
                  ENDDO
                ENDIF
!
                DO MJ=ME1,ME2,2
!
                  CALL YLAMK(MJ,MI,DP,DA,DD1,DD2,MNH,DHNS,MJH,IZERO)
!                                                             !NO RETARD
                  DC1=VCC(INT(QL(J),SP),2*MJ,INT(QL(K),SP),IZERO,IZERO, &
     &                IZERO)
                  G=-DC1*DC1/(2*QL(K)+2)
                  G=G*AJUST                        !TRY SCALING EXCHANGE
!                write(mw6,*)j,k,ql(j),2*mj,ql(k),'  g=',g
!
                  IF(BREL2)THEN
                    DO I=1,MAXRS
                      POT(I)=POT(I)-C*G*DA(I)                           &
     &                       *(DPNL(I,J)*DPNL(I,K)+DQNL(I,J)*DQNL(I,K))
                    ENDDO
                  ELSE
                    DO I=1,MAXRS
                      POT(I)=POT(I)-C*G*DA(I)*DPNL(I,J)*DPNL(I,K)
                    ENDDO
                  ENDIF
!
                ENDDO
!
              ENDIF
!
            ENDIF
!
          ENDDO
!
        ENDIF
!
      ENDDO
!
! TWO-BODY
!
      CALL WEDDLE(DZERO,POT,E,MNH,DHNS,MJH,MAXRS)
!
      E2BODY=-E                                                    !A.U.
!
! ONE BODY (EXCLUDE ANY CLOSED CORE)
!
      E1BODY=DZERO
!
      DO J=MB+1,MXB                                                 !MB0
        NELC=NEL(J,KF)
        IF(NELC.GT.0)THEN
!          write(mw6,*)'j=',j,'  ne=',nelc
          IN=ICOL(J,J,IZERO)
          E=DEY(J)
!          write(mw6,200)dey(j)-duy(in),duy(in)
! 200      format('eps=',1p,d12.5,'  V-Z/R=',d12.5)
          IF(BMVDR.AND.(BMVD.OR.NJO.NE.0))E=E+DCD(IN)+DMASS(IN)
!          if(bmvd.or.njo.ne.0)write(mw6,201)dcd(in),dmass(in)
! 201      format('darwin=',1p,d12.5,'  mass=',d12.5)
          IF(QED.NE.0.AND.QN(J).GT.0)E=E+VPINT(J)+SLFINT(J)
!          if(qed.ne.0.and.qn(j).gt.0)write(mw6,202)vpint(j),slfint(j)
! 202      format('vac=',1p,d12.5,'  self=',d12.5)
          IF(KUTOO.EQ.98)E=E+DXSI(IN)
!          if(kutoo.eq.98)write(mw6,203)dxsi(in)
! 203      format('dxsi=',1p,d12.5)
          E1BODY=E1BODY+NELC*E
        ENDIF
      ENDDO
!
!      write(mw6,204)kf,e1body,e2body
! 204  format(/'cf=',i3,'  e1body=',1p,d12.5,'  e2body=',d12.5)
!
      EAV=E1BODY+E2BODY
!
!-----------------------------------------------------------------------
!
! LOCAL
      DEALLOCATE(DA,DPA,POT,DP,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CAVE: DE-ALLOCATION FAILS FOR DA,DPA,POT,DP'
        NF=0
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE CAVE
!
!                             *******************
!
      SUBROUTINE CAVE0(ICAV)
!
!-----------------------------------------------------------------------
!
!  SR.CAVE0 DETERMINES CONFIGURATION AVERAGE ENERGIES BOTH USING AN
!  INTERNAL RELAXED ORBITALS BASIS (ICAV.GT.0) AND THEN USING THE
!  EXISTING (UNIQUE) ORBITAL BASIS (ICAV.LT.0). THE TWO ARE STORED
!  SEPARATELY IN ECAVX AND ECAV TO ENABLE THE LATTER TO BE UPDATED
!  E.G. DURING MINIMIZATION. THE DIFFERENCE IS THEN APPLIED TO THE
!  DIAGONAL OF THE HAMILTONIAN IN SR.DIAGON AND SR.DIAGFS.
!
!  IT IS CALLED BY:
!    SR.CALCFX
!    SR.MINIM
!
!  IT CALLS:
!    SR.CAVE
!    SR.RADIAL
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CADJ,   ONLY: DALAN,BALAN
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_CMESH,  ONLY: MHF,MRAD,MSTEP,IXTRA,xmax
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBCAV, ONLY: ECAVX,ECAV,AJUSTX
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,VSC,XC1,XC2,NPITER
      USE COMMON_NRBPOT, ONLY: ALFD,RCUT,ALAV,RCAV,IPOLFN
      USE COMMON_NRBSTO, ONLY: ALF,TEL,MSHELL,MCFSTO,MC,MCFMX,MEXPOT    &
     &                        ,NOCC,NLSTOE,BFIX,BSTO,MXSHLL
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      ALLOCATABLE ::  DEXTRE(:),MSTOH(:),DEYH(:),SCREEH(:),TELH(:)
!
!-----------------------------------------------------------------------
!
      IF(ICAV.GT.0)THEN                       !NEW SELF-CONSISTENT BASIS
!
! HOLD USER VALUES
!
        ALLOCATE(MSTOH(MXORB),DEYH(MXORB),SCREEH(MXORB),TELH(MXORB))
!
        MAUTOH=MAUTO
        MDENH=MDEN
        MEXH=MEXPOT
        MHFH=MHF
        MRADH=MRAD
        MCFMXH=MCFMX
        BSTOH=BSTO
        NOCCH=NOCC
!
        DO I=1,MXORB
          MSTOH(I)=MCFSTO(I)
          TELH(I)=TEL(I)
          DEYH(I)=DEY(I)
          SCREEH(I)=SCREEN(I)
        ENDDO
!
! NOW SET-UP FOR A SELF-CONSISTENT CALCULATION
!
        MAUTO=MIN(IZERO,MAUTO)
        MHF=0
        MRAD=0
        MCFMX=MXORB
        BSTO=.TRUE.
        MDEN=-10
        IF(NOCC.EQ.0)THEN                     !ELSE STICK WITH USER INPT
          MEXPOT=0                            !FULL EXCHANGE
          NOCC=-1000                          !NON-UNIQUE, I.E. FAC=NO
        ELSEIF(NOCC.LT.0)THEN                 !USE INDIVIDUAL CF OCC NOS
          NOCC=-1000
        ELSE                                  !BUT ALLOW FAC='YES' POT
          NOCC=1000
        ENDIF
!
        NP0=0
        IF(IPOLFN.LT.0)NP0=-IPOLFN
        NPARM3=(NP0+1)*NPARAM                 !IXVAR
!
        ALLOCATE(DEXTRE(NPARM3))
!
        DO I=1,NPARM3                         !ASSIGN GLOBAL SCALE VALUE
          DEXTRE(I)=AJUSTX
          IF(BALAN)DALAN(I)=AJUSTX
        ENDDO
!
      ELSE
!
        WRITE(MW6,10010)
!
      ENDIF
!
! LOOP OVER THE KMAX CONFIGURATIONS
!
      DO K=1,KMAX
!
        IF(ICAV.GT.0)THEN
!
          DO I=1,MXORB
            MCFSTO(I)=K
            IF(NEL(I,K).NE.0)THEN
              IF(QN(I).GE.80)THEN
                DEY(I)=DZERO
!                SCREEN(I)=DZERO
              ELSEIF(SCREEH(I).GT.-D999)THEN
                SCREEN(I)=SCREEH(I)
                DEY(I)=DONE
              ENDIF
            ELSEIF(QN(I).LT.70)THEN
              DEY(I)=DZERO
!              SCREEN(I)=DZERO
            ENDIF
          ENDDO
!
          CALL RADIAL(DEXTRE)                 !UPDATE RADIAL FUNCTIONS
!
          IF(NF.LE.0)GO TO 100                !FAILURE
!
          DO I=1,NPARAM                       !RE-SET
            IF(SCREEN(I).GT.-D999)THEN
              DO N=0,NP0
                N0=N*NPARAM+I
                DADJUS(N0)=DZERO
              ENDDO
            ENDIF
          ENDDO
!
        ENDIF
!
        CALL CAVE(K,EAV)
!
        IF(NF.LE.0)GO TO 100                  !FAILURE
!
        IF(ICAV.GT.0)THEN
          ECAVX(K)=EAV
          MAXRS=0                             !RESET INITIAL RADIAL MESH
        ELSE
          ECAV(K)=EAV
          WRITE(MW6,10020)K,ECAVX(K),ECAV(K),ECAVX(K)-ECAV(K)
        ENDIF
!
      ENDDO                                   !END LOOP OVER CFS
!
  100 IF(ICAV.GT.0)THEN                       !RE-INSTATE
!
        MAUTO=MAUTOH
        MDEN=MDENH
        MEXPOT=MEXH
        MHF=MHFH
        MRAD=MRADH
        MCFMX=MCFMXH
        BSTO=BSTOH
        NOCC=NOCCH
!
        DO I=1,MXORB
          MCFSTO(I)=MSTOH(I)
          TEL(I)=TELH(I)
          IF(SCREEH(I).GT.-D999)THEN
            DEY(I)=DEYH(I)
            SCREEN(I)=SCREEH(I)
          ENDIF
        ENDDO
!
        DEALLOCATE(DEXTRE,MSTOH,DEYH,SCREEH,TELH)
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(//'  CONFIGURATION AVERAGE ENERGIES/2RY:'/45X,'CF',10X,    &
     &       'ECAVX',12X,'ECAV',12X,'DIFFERENCE')
10020 FORMAT(42X,I5,2X,1P,2D17.7,3X,D15.5)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE CAVE0
!
!                             *******************
!
      SUBROUTINE CALCFX(N,DX,DF)
!
!-----------------------------------------------------------------------
!
!  SR.CALCFX HAS BEEN WRITTEN ACCORDING TO THE REQUIREMENTS OF SR.VA04A.
!  THE ROUTINE RETURNS THE VARIATIONAL FUNCTIONAL DF; DF DEPENDS UPON
!  N.LE.MXVAR SCALING PARAMETERS DX, SOME OF WHICH MAYBE VARIATIONAL.
!
!  IT IS CALLED BY:
!    SR.VA04A
!
!  IT CALLS:
!    SR.CARATE
!    SR.CAVE0
!    SR.DIAGFS
!    SR.DIAGON
!    SR.RADIAL
!    SR.SOCC
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CADJ,   ONLY: DAJNEW,DF0,IEQUAL,ICOUNT
      USE COMMON_CADJ,   ONLY: DALAN,BALAN
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_GENINF, ONLY: SCALER
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR
      USE COMMON_MINIM,  ONLY: EIONPOT,EIMXLS,EIMXIC                    &
     &                        ,WLG1,WLG2,IWGHT,IWGHT0,IOPTIM            &
     &                        ,JUPMX,JUPMN,JLOWMX,JLOWMN                &
     &                        ,LUPMX,LUPMN,LLOWMX,LLOWMN                &
     &                        ,NMETAR,NMETARJ,NMETAP,NMETAPJ,NRSLMX
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
      USE COMMON_TFU,    ONLY: TFU
      USE COMMON_TRANLS, ONLY: NADRU,NAI,IEORD
!
      USE COMMON_NRBAL1, ONLY: ISCALR
      USE COMMON_NRBCAV, ONLY: ECAVX,ECAV,AJUSTX,ICAV0=>ICAV
      USE COMMON_NRBDEL, ONLY: ISHFTLS,ISHFTIC,NOBS,NOBSJ,MDELE,MULTS   &
     &                        ,DELELS,DELEIC,DELECF,EFLG0,EFLGJ0        &
     &                        ,TOLB,TOLE
      USE COMMON_NRBPOT, ONLY: ALFD,RCUT,ALAV,RCAV,IPOLFN
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION DX(*)
!
!-----------------------------------------------------------------------
!
! ASSIGN VALUES DX TO SCALING FACTORS DAJNEW(I)
!
      NP0=0
      IF(IPOLFN.LT.0)NP0=-IPOLFN
      NPARM3=(NP0+1)*NPARAM
!
      DO I=1,NPARM3      !=SIZE OF PARAMETER ARRAYS, DEFINED IN SR.MINIM
        J=IEQUAL(I)
        IF(J.GT.0)THEN
!          write(mw6,*)i,j,dx(j)
!          IF(J.LE.N)THEN                          !CONTROLLED BY IEQUAL
          DAJNEW(I)=DX(J)
          IF(BALAN)THEN                            !TRANSFER TO POT SUBS
            DALAN(I)=DX(J)
            DADJUS(I)=DZERO                        !SO RE-COMP ALL ORBS
            if(dalan(i).lt.dzero)then
              write(mw6,10010)i,dalan(i)
              write(mw0,                                                &
     &"('***SR.CALCFX:STO SUBSHELL POTENTIAL LAMBDAS MUST BE POSITIVE')"&
     &)
              nf=-1
              go to 300
            endif
          ENDIF
!          ENDIF
        ENDIF
      ENDDO
!
      IF(ISCALR.GT.0)SCALER=DAJNEW(ISCALR)     !SLATER SCALING PARAMETER
!
! UPDATE RADIAL FUNCTIONS & CA ENERGIES
!
      CALL RADIAL(DAJNEW)
!
      IF(ICAV0.NE.0)THEN                       !UNIQUE
        ICAV=-ABS(ICAV0)
!
        CALL CAVE0(ICAV)
!
      ENDIF
!
      IF(NF.LE.0)GO TO 300
!
      IF(NSL0.LT.0)THEN                        !CA
!
        CALL CARATE(DECORE,DESUM)
!
        GO TO 200
      ENDIF
!
! DIAGONALIZE ENERGY MATRIX;  DESUM+DECORE=DF+DF0
! DESUM IS THE ENERGY SUM, WITHOUT THE CORE CONTRIBUTION DECORE;
! IN THE ALTERNATIVE CASE JPRINT=-2 DIAGON RETURNS DESUM=G, DECORE=0
!
      CALL DIAGON(DECORE,DESUM)                !H(LS)
!
      IF(NF.LE.0)GO TO 100
!
      IF(NJO.GT.0)THEN                         !COMPUTE FINE-STRUCTURE
!
        CALL SOCC                              !BLUME & WATSON
!
        IF(NF.LE.0)GO TO 100
!
        CALL DIAGFS(DECORE,DESUM)              !H(IC)
!
      ENDIF
!
!
  100 CONTINUE
!
      IF(ALLOCATED(TFU))THEN
        DEALLOCATE(TFU,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'CALCFX: DE-ALLOCATION FAILS FOR TFU'
          NF=MIN(NF,IZERO)
        ENDIF
      ENDIF
!
      IF(ALLOCATED(NADRU))THEN
        DEALLOCATE(NADRU,NAI,IEORD,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'CALCFX: DE-ALLOCATION FAILS FOR NADRU,NAI,IEORD'
          NF=MIN(NF,IZERO)
        ENDIF
      ENDIF
!
  200 IF(NF.LE.0)GO TO 300
!
      IF(IOPTIM.EQ.0)THEN
        IF(DF0.EQ.DZERO)DF0=DECORE
        DF=(DECORE-DF0)+DESUM
        DECORE=-DF0
        DESUM=DF-DECORE
      ELSE
        DF=DESUM
        DECORE=DZERO
      ENDIF
!
! PRINT THE COMPUTED VALUE OF THE FUNCTIONAL
!
      WRITE(MW6,10020)DF,DESUM,DECORE,ICOUNT
!
      ICOUNT=ICOUNT-1
      IF(ICOUNT.NE.0)RETURN
!
      WRITE(MW6,10030)
      N=0                                                     !FOR VA04A
      RETURN
!
  300 N=-1                                                    !FOR VA04A
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(/'***SR.CALCFX: STO SUBSHELL POTENTIAL LAMBDAS MUST BE',   &
     &       ' POSITIVE: SUBSHELL, LAMBDA=',I5,F10.4)
10020 FORMAT(/' CALCFX-FUNCTIONAL FX=',E15.8,', =(E-ECORE0)/2RY=',      &
     &       2E16.9,24X,'COUNTDOWN INDEX =',I4)
10030 FORMAT(' SR.CALCFX: PARAMETERS IMAXIT AND NEXTRE ALLOW NO MORE',  &
     &  ' ITERATIVE STEPS -- IT MAY NOT BE SENSIBLE TO RESUME ITERATING'&
     &  )
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE CALCFX
!
!                             *******************
!
      SUBROUTINE CASC
!
!-----------------------------------------------------------------------
!
!  SR.CASC CALCULATES CASCADE COEFFICIENTS.
!
!    NOTE: IF THE NUMBER OF LOWER LEVELS (NG) IS GREATER THAN IN THE
!    NUMBER OF LEVELS WITHIN THE GROUND CONFIG THEN THERE IS A CHOICE
!    OF WHETHER OR NOT TO INCLUDE E1 TRANSTIONS BETWEEN THE NG LEVELS
!    IN THE CASCADE COEFFICIENTS.
!    DEFAULT IS TO INCLUDE THEM, SO POPULATION MODELING WITH THESE
!    COEFFICIENTS SHOULD INCLUDE ONLY FORBIDDEN RADIATIVE RATES STILL.
!    SEE COMMENT FLAG ***INCLUDE E1 CASC THRU NG BELOW.
!
!  IT IS CALLED BY:
!    SR.MINIM
!
!  IT CALLS:
!    SR.DIMUSE
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR
      USE COMMON_MINIM,  ONLY: MPNCH,KUTCAS,BPRINT
      USE COMMON_QTG,    ONLY: NFI,NFK,NFQ
!
      USE COMMON_NRBCAS, ONLY: BCASC,AP,MADD
      USE COMMON_NRBCAS, ONLY: NENERG,JORIG
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      CHARACTER(LEN=2) NY,NO,NB
!
      ALLOCATABLE ::  ATOT(:),CAS(:),NPOS(:),NEX(:),NS(:)
!
      DATA  NY,NO/'  ','NO'/
!
!-----------------------------------------------------------------------
!
! OPEN PUNCHFILE
!
      IF(MPNCH.LT.0)THEN
        IF(IUNIT(MW2).LT.0)THEN
          WRITE(MW6,*)"TRYING TO RE-OPEN FILE='CASC'..."
          WRITE(MW0,*)'TRYING TO RE-OPEN UNIT=MW2'
          NF=-1
          RETURN
        ENDIF
        IUNIT(MW2)=1
        OPEN(MW2,FILE='CASC',STATUS='REPLACE')  !OPTIONAL CASCADE COEFFS
      ENDIF
!
! FIND NUMBER OF LEVELS IN LOWEST CONFIGURATION
!
      ALLOCATE(ATOT(NENERG),NPOS(NENERG),NEX(NENERG),NS(NENERG),        &
     &         STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CASC: ALLOCATION FAILS FOR ATOT,NPOS,NEX,NS'
        NF=0
        GO TO 200
      ENDIF
!
      NG=0
      BLCOR=.FALSE.
!
      DO I=1,NENERG
        ATOT(I)=DZERO
        NPOS(I)=0
        IOLD=JORIG(I)                           !EO -> SO
        BLCOR=BLCOR.OR.IOLD.LT.0
        IF(IOLD.GE.0)THEN
          N=NRR(IOLD)
          IF(NG.EQ.0)NFK1=NFK(N)
          IF(NFK(N).EQ.NFK1)NG=NG+1
        ENDIF
      ENDDO
!
      IF(KUTCAS.GT.0)NG=KUTCAS     !WAS.GT.NG, .GT.0 ALLOWS RESTRICTION
      IF(KUTCAS.GT.(NENERG-1))NG=NENERG-1
!
      IF(NG.LE.1)THEN                       !TRIVIAL RETURN
        WRITE(MW6,10010)
        GO TO 100
      ENDIF
!
      NCA=NG*(2*NENERG-NG-1)/2
      IF(NCA.GT.MXCAS)THEN
        IF(MXCAS.GT.0)WRITE(MW6,10050)NCA,MXCAS
      ENDIF
!
      ALLOCATE(CAS(NCA),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CASC: ALLOCATION FAILS FOR CAS'
        NF=0
        GO TO 100
      ENDIF
!
      CALL DIMUSE('MXCAS',NCA)
!
      NB=NO
      IF(MPNCH.LT.0)NB=NY
      WRITE(MW6,10030)KUTCAS,NG,MPNCH,NB
      IF(BLCOR)WRITE(MW6,10070)
      WRITE(MW6,10040)
!
! FOR A GIVEN LEVEL NU, STORE POINTER NPOS(NU)=I OF LAST TRANS. PROB.,
! STORED IN ARRAY AP(I).
!
      NAC=MADD(0)
      DO I=1,NAC
        NU=MADD(I)/NENERG+1
        ATOT(NU)=ATOT(NU)+AP(I)
        NPOS(NU)=I
      ENDDO
      DO I=1,NCA
        CAS(I)=DZERO
      ENDDO
!
      NS(1)=0
      NBEG=0
      DO I=2,NENERG
        IS=NS(I-1)+I-2
        IF(I.GT.NG+2)IS=NS(I-1)+NG
        NS(I)=IS
!
        IF(JORIG(I).GE.0)THEN
          IMT=I-1
          IM=MIN(IMT,NG)
          NFIN=NPOS(I)
          NM=0
          IF(NFIN.NE.0)THEN
            DO N=1,I
              NEX(N)=0
            ENDDO
            NBEG=NBEG+1
            DO N=NBEG,NFIN
              NL=MADD(N)-(I-1)*NENERG+1
              NEX(NL)=N
            ENDDO
            NBEG=NFIN
!
            DO N=1,IM
              NTRAN=NEX(N)
              IF(NTRAN.GT.0)THEN             !FOR STUPID COMPILERS
                CAS(IS+N)=AP(NTRAN)/ATOT(I)
                NM=N
              ENDIF
              IF(N.LT.IMT)THEN               !IMT NOT IM
                NP=N+1             !***INCLUDE E1 CASC THRU NG
!                NP=NG+1           !***EXCLUDE E1 CASC THRU NG
                DO J=NP,IMT
                  NTRAN=NEX(J)
                  IF(NTRAN.GT.0)THEN
                    IT=NS(J)
                    CAS(IS+N)=CAS(IS+N)+CAS(IT+N)*AP(NTRAN)/ATOT(I)
                    NM=N
                  ENDIF
                ENDDO
              ENDIF
            ENDDO
          ENDIF
!
          IF(NM.GT.0)WRITE(MW6,10060)(I,N,CAS(N+IS),N=1,NM)
          IF(MPNCH.LT.0)WRITE(MW2,10020)(I,N,CAS(N+IS),N=1,IM)
        ENDIF
!
      ENDDO
!
      DEALLOCATE(CAS,STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CASC: DE-ALLOCATION FAILS FOR CAS'
        NF=0
      ENDIF
!
  100 DEALLOCATE(ATOT,NPOS,NEX,NS,STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CASC: DE-ALLOCATION FAILS FOR ATOT,NPOS,NEX,NS'
        NF=0
      ENDIF
!
  200 IF(MPNCH.LT.0)THEN
        CLOSE(MW2,STATUS='KEEP')
        IUNIT(MW2)=-1
      ENDIF
!
      DEALLOCATE(JORIG,STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'CASC: DE-ALLOCATION FAILS FOR JORIG'
        NF=0
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(//20X,'CASCADE COEFFS NOT CALCULATED SINCE CONFIG 1 HAS',  &
     &       ' 1 LEVEL')
10020 FORMAT(5(I7,I5,F10.6))
10030 FORMAT(//35X,'CASCADE COEFFICIENTS'//'   CONTROL PARAMETERS FOR ',&
     &       'CASC:  INPUT KUTCAS=',I6,8X,'EFFECTIVE KUTCAS=',I6,8X,    &
     &       'MPNCH=',I4/3X,A2,' CASCADE COEFFICIENTS WILL BE PUNCHED')
10040 FORMAT(//7(6X,'K',3X,'KP','  C(KP,K) ')/)
10050 FORMAT('SR.CASC: ALLOCATION INCREASES NUMBER OF CASCADE',         &
     &       ' COEFFICIENTS NCA =',I10,' .GT. MXCAS=',I10/)
10060 FORMAT(7(I7,I5,F10.6))
10070 FORMAT('  TRANSITIONS INVOLVING CORRELATION LEVELS HAVE BEEN',    &
     &       ' OMITTED.     IF REQUIRED SET IC.JPRINT=1.')
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE CASC
!
!                             *******************
!
      FUNCTION CELMNT(NZION)
!
!
!-----------------------------------------------------------------------
!
!  FN.CELMNT RETURNS 2-CHARACTER ELEMENT SYMBOL FOR NUCLEAR CHRAGE NZION
!
!  IT IS CALLED BY:
!    SR.CARATE
!    SR.DIAGFS
!    SR.DIAGON
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      CHARACTER(LEN=2) ELEM2(92),CELMNT
!
      DATA                                                              &
     &ELEM2/'H ','HE','LI','BE','B ','C ','N ','O ','F ','NE','NA','MG' &
     &,'AL','SI','P ','S ','CL','AR','K ','CA','SC','TI','V ','CR','MN' &
     &,'FE','CO','NI','CU','ZN','GA','GE','AS','SE','BR','KR','RB','SR' &
     &,'Y ','ZR','NB','MO','TC','RU','RH','PD','AG','CD','IN','SN','SB' &
     &,'TE','I ','XE','CS','BA','LA','CE','PR','ND','PM','SM','EU','GD' &
     &,'TB','DY','HO','ER','TM','YB','LU','HF','TA','W ','RE','OS','IR' &
     &,'PT','AU','HG','TL','PB','BI','PO','AT','RN','FR','RA','AC','TH' &
     &,'PA','U '/
!
!-----------------------------------------------------------------------
!
      IF(NZION.LE.0.OR.NZION.GT.92)THEN
        CELMNT='  '
      ELSE
        CELMNT=ELEM2(NZION)
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION CELMNT
!-CGNRC
!-CGNRC                             *******************
!-CGNRC
!-CGNR      SUBROUTINE CGNR(DEXTRE,NVAR,IMAXIT)
!-CGNRC
!-CGNRC-----------------------------------------------------------------
!-CGNRC
!-CGNRC  SR.CGNR INTERFACE WITH THE NUMERICAL RECIPES CONJUGATE GRADIENT
!-CGNRC  CODE SUITE
!-CGNRC
!-CGNRC  THE SOURCE IS *NOT* PROVIDED HERE DUE TO THEIR LICENSING
!-CGNRC  RESTRICTIONS. LINK AT THE COMPILATION STAGE TO YOUR OWN COPY
!-CGNRC  OF THE LIBRARY.
!-CGNRC  THIS HAS BEEN TESTED TO WORK WITH VANILLA RIGHT-OUT-OF-THE-TIN
!-CGNRC  UNMODIFIED NUMERICAL RECIPES CODE. IT *MUST* BE THE REAL *8
!-CGNRC  VERSION, FORCING IT VIA A COMPILER SWITCH IS NOT RECOMMENED.
!-CGNRC
!-CGNRC  IT IS CALLED BY:
!-CGNRC    SR.MINIM
!-CGNRC
!-CGNRC  IT CALLS:
!-CGNRC    SR.FRPRMN
!-CGNRC    FN.FUNC
!-CGNRC
!-CGNRC-----------------------------------------------------------------
!-CGNRC
!-CGNR      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!-CGNR      USE PARAM
!-CGNR      USE UTILITY
!-CGNR      USE CONSTANTS
!-CGNRC
!-CGNR      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM
!-CGNR     X                        ,ITOL,INCLUD,JPRINT,JEND
!-CGNRC
!-CGNR      USE COMMON_NRBPOT, ONLY: ALFD,RCUT,ALAV,RCAV,IPOLFN
!-CGNRC
!-CGNRC-----------------------------------------------------------------
!-CGNRC
!-CGNR      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
!-CGNR      IMPLICIT LOGICAL(BP) (B)
!-CGNR      IMPLICIT INTEGER(SP) (I-N)
!-CGNR      IMPLICIT INTEGER(QP) (Q)
!-CGNRC
!-CGNRC      INCLUDE './INCLUDE'
!-CGNRC
!-CGNR      PARAMETER (NMAX=50)                      !NUM. REC. DEFAULT
!-CGNR      DIMENSION pcom(NMAX),xicom(NMAX)         !NUM. REC. COMMON
!-CGNR      COMMON /f1com/ pcom,xicom,ncom           !NUM. REC. COMMON
!-CGNRC
!-CGNR      DIMENSION DEXTRE(*)
!-CGNRC
!-CGNR      NP0=0
!-CGNR      IF(IPOLFN.LT.0)NP0=-IPOLFN
!-CGNR      NPARM3=(NP0+1)*NPARAM
!-CGNRC
!-CGNR      NVAR=-NVAR
!-CGNRC
!-CGNR      IF(NVAR.GT.NMAX)THEN                  !SHIRELY, SOME MISTAKE
!-CGNR        WRITE(MW6,1081)NVAR,NMAX
!-CGNR        WRITE(MW0,*)' TOO MANY VARIATIONAL PARAMETERS...!!!'
!-CGNR        GO TO 999
!-CGNR      ENDIF
!-CGNRC
!-CGNR      TOL=D1M6                                  !SUBJECT TO CHANGE
!-CGNR      IF(NP0.GT.0)TOL=D1M6                      !   "     "    "
!-CGNRC
!-CGNRc      LIMIT=NVAR*IMAXIT+IMAXIT+2        !200 IS NUM. REC. DEFAULT
!-CGNRc      itout=limit                      !itmax= in modified frprmn
!-CGNRc
!-CGNR      ncom=-NPARM3                              !PASS THRU TO FUNC
!-CGNR      DUMMY=FUNC(DEXTRE)                  !INITIALIZE DEXTRE STORE
!-CGNRC
!-CGNR      ncom=NVAR                          !PASS THRU TO FUNC, DFUNC
!-CGNRC
!-CGNR      CALL FRPRMN(DEXTRE,NVAR,TOL,ITOUT,DF)!REQUIRES REAL *8 VERSN
!-CGNRC
!-CGNR      WRITE(MW6,1082)ITOUT
!-CGNRC
!-CGNR      IF(ITOUT.EQ.1)THEN
!-CGNR        WRITE(MW6,1084)TOL,DF
!-CGNR        WRITE(MW0,*)
!-CGNR     &       'NR CONJUGATE GRADIENT DOES NOT CHANGE FUNCTIONAL..'
!-CGNR        GO TO 999
!-CGNR      ENDIF
!-CGNRC
!-CGNR      IF(ITOUT.EQ.200)THEN    !LIMIT
!-CGNR        WRITE(MW6,1083)TOL,DF
!-CGNR        WRITE(MW0,*)
!-CGNR     &       'NR CONJUGATE GRADIENT HAS FAILED TO CONVERGE..'
!-CGNR        GO TO 999
!-CGNR      ENDIF
!-CGNRC
!-CGNRc      write(mw0,*)DF,imaxit,limit,itout,icount
!-CGNRC
!-CGNRC-----------------------------------------------------------------
!-CGNRC
!-CGNR      RETURN
!-CGNRC
!-CGNR  999 IMAXIT=-1
!-CGNRC
!-CGNR      RETURN
!-CGNRC
!-CGNRC-----------------------------------------------------------------
!-CGNRC
!-CGNR 1084 FORMAT(//' *** NR CONJUGATE GRADIENT DOES NOT CHANGE'
!-CGNR     &,' FUNCTIONAL:,2(1PD10.2))
!-CGNR 1083 FORMAT(//' *** NR CONJUGATE GRADIENT HAS FAILED TO CONVERGE'
!-CGNR     &,' TO CONVERGE TO THE REQUESTED ACCURACY:',2(1PD10.2))
!-CGNR 1082 FORMAT(I5,' ITERATIONS COMPLETED BY NR CONJUGATE GRADIENT'
!-CGNR     &,' METHOD')
!-CGNR 1081 FORMAT(//' *** CGNR: NUMBER OF VARIATIONAL PARAMETERS '
!-CGNR     &,'EXCEEDS THAT ALLOWED BY NUMERICAL RECIPES - SOME MISTAKE?'
!-CGNR     &,2I4)
!-CGNRC
!-CGNRC-----------------------------------------------------------------
!-CGNRC
!-CGNR      END SUBROUTINE CGNR
!-CGNRC
!-CGNRC                             *******************
!-CGNRC
!-CGNR      FUNCTION FUNC(X)
!-CGNRC
!-CGNRC-----------------------------------------------------------------
!-CGNRC
!-CGNRC  FN.FUNC EVALUATES THE COST (C) OF THE FUNCTIONAL AT X(N).
!-CGNRC
!-CGNRC  IT IS CALLED BY:
!-CGNRC    SR.CGNR
!-CGNRC
!-CGNRC  IT CALLS:
!-CGNRC    SR.CALCFX
!-CGNRC
!-CGNRC-----------------------------------------------------------------
!-CGNRC
!-CGNRC
!-CGNR      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!-CGNR      USE PARAM
!-CGNR      USE UTILITY
!-CGNR      USE CONSTANTS
!-CGNRC
!-CGNRC-----------------------------------------------------------------
!-CGNRC
!-CGNR      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
!-CGNR      IMPLICIT LOGICAL(BP) (B)
!-CGNR      IMPLICIT INTEGER(SP) (I-N)
!-CGNR      IMPLICIT INTEGER(QP) (Q)
!-CGNRC
!-CGNRC      INCLUDE './INCLUDE'
!-CGNRC
!-CGNR      PARAMETER (NMAX=50)                      !NUM. REC. DEFAULT
!-CGNR      DIMENSION pcom(NMAX),xicom(NMAX)         !NUM. REC. COMMON
!-CGNR      COMMON /f1com/ pcom,xicom,ncom           !NUM. REC. COMMON
!-CGNRC
!-CGNR      DIMENSION XOLD(MXVAR),X(*)
!-CGNRC
!-CGNR      DATA NOLD/0/
!-CGNRC
!-CGNR      SAVE NOLD,XOLD
!-CGNRC
!-CGNRC-----------------------------------------------------------------
!-CGNRC
!-CGNRC FIRST CALL MUST BE WITH N=-NPARAM TO STORE ALL SCALING PARAMETRS
!-CGNRC IN XOLD. THEN SUBSEQUENT CALLS WITH N=NVAR.GT.0. X(I.GT.NVAR)
!-CGNRC ARE SUPPLEMENTED BY THOSE FROM XOLD. THIS IS BECAUSE (NUM. REC.)
!-CGNRC CG USES DIFFERENT VECTORS FOR ADJUSTED VALUES, RATHER THAN
!-CGNRC OVERWRITING THE ORIGINAL, NECESSARILY. SO THE DORMANT VALUES ARE
!-CGNRC NOT PRESENT.
!-CGNRC
!-CGNR      N=ncom
!-CGNRC
!-CGNR      IF(N.LT.0)THEN                          !STORE IN XOLD
!-CGNR        NOLD=-N
!-CGNR        DO I=1,NOLD
!-CGNR          XOLD(I)=X(I)
!-CGNR        ENDDO
!-CGNR        C=DZERO
!-CGNR        GO TO 10
!-CGNR      ELSEIF(N.GT.0)THEN                      !SUPPLEMENT X
!-CGNR        IF(NOLD.EQ.0)THEN
!-CGNR          WRITE(MW6,*)'*** CG: FUNC, NOT INITIALIZED'
!-CGNRC          STOP '*** CG: FUNC, NOT INITIALIZED'
!-CGNR          C=DZERO
!-CGNR          GO TO 10
!-CGNR        ENDIF
!-CGNR        DO I=N+1,NOLD
!-CGNR          X(I)=XOLD(I)
!-CGNR        ENDDO
!-CGNR      ELSE
!-CGNR        WRITE(MW6,*)'*** CG: FUNC, ILLEGAL INPUT N=0'
!-CGNRC        STOP '*** CG: FUNC, ILLEGAL INPUT N=0'
!-CGNR        C=DZERO
!-CGNR        GO TO 10
!-CGNR      ENDIF
!-CGNRC
!-CGNR      CALL CALCFX(NOLD,X,C)
!-CGNRC
!-CGNR      IF(NOLD.EQ.0)THEN
!-CGNR        WRITE(MW6,*)'*** CG: FUNC, CALCFX ABORTED'
!-CGNRC        STOP '*** CG: FUNC, CALCFX ABORTED'
!-CGNR        C=DZERO
!-CGNR        GO TO 10
!-CGNR      ENDIF
!-CGNRC
!-CGNR 10   FUNC=C
!-CGNRC
!-CGNRC-----------------------------------------------------------------
!-CGNRC
!-CGNR      RETURN
!-CGNRC
!-CGNRC-----------------------------------------------------------------
!-CGNRC
!-CGNR      END SUBROUTINE FUNC
!-CGNRC
!-CGNRC                             *******************
!-CGNRC
!-CGNR      SUBROUTINE DFUNC(X,G)
!-CGNRC
!-CGNRC-----------------------------------------------------------------
!-CGNRC
!-CGNRC  SR.DFUNC EVALUATES THE GRADIENT (G(N)) OF THE FUNCTIONAL AT X.
!-CGNRC
!-CGNRC  IT IS CALLED BY:
!-CGNRC
!-CGNRC  IT CALLS:
!-CGNRC    FN.FUNC
!-CGNRC
!-CGNRC-----------------------------------------------------------------
!-CGNRC
!-CGNR      USE PRECSN, ONLY: BP,QP,SP,EP,WP
!-CGNR      USE PARAM
!-CGNR      USE UTILITY
!-CGNR      USE CONSTANTS
!-CGNRC
!-CGNRC-----------------------------------------------------------------
!-CGNRC
!-CGNR      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
!-CGNR      IMPLICIT LOGICAL(BP) (B)
!-CGNR      IMPLICIT INTEGER(SP) (I-N)
!-CGNR      IMPLICIT INTEGER(QP) (Q)
!-CGNRC
!-CGNRC      INCLUDE './INCLUDE'
!-CGNRC
!-CGNR      PARAMETER (NMAX=50)                      !NUM. REC. DEFAULT
!-CGNR      DIMENSION pcom(NMAX),xicom(NMAX)         !NUM. REC. COMMON
!-CGNR      COMMON /f1com/ pcom,xicom,ncom           !NUM. REC. COMMON
!-CGNRC
!-CGNR      DIMENSION X(*),G(*)
!-CGNRC
!-CGNRC-----------------------------------------------------------------
!-CGNRC
!-CGNR      N=ncom
!-CGNRC
!-CGNR      DX=D1M4                    !SUBJECT TO CHANGE
!-CGNR      DX2=DX+DX
!-CGNRC
!-CGNR      DO I=1,N
!-CGNR        X(I)=X(I)+DX
!-CGNR        FP=FUNC(X)
!-CGNR        X(I)=X(I)-DX2
!-CGNR        FM=FUNC(X)
!-CGNR        X(I)=X(I)+DX
!-CGNR        G(I)=(FP-FM)/DX2
!-CGNR      ENDDO
!-CGNRC
!-CGNRC-----------------------------------------------------------------
!-CGNRC
!-CGNR      RETURN
!-CGNRC
!-CGNRC-----------------------------------------------------------------
!-CGNRC
!-CGNR      END SUBROUTINE DFUNC
!
!                             *******************
!
      SUBROUTINE CGNR(DEXTRE,NVAR,IMAXIT)
!
!-----------------------------------------------------------------------
!
!  SR.CGNR: THIS IS A DUMMY REPLACEMENT FOR THE INTERFACE ROUTINE TO THE
!  NUMERICAL RECIPES CONJUGATE GRADIENT BRANCH
!
!  IT IS CALLED BY:
!    SR.MINIM
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION DEXTRE(*)
!
!-----------------------------------------------------------------------
!
! SUPPRESS COMPILER WARNINGS (SIGH...)
!
      DDUM=DEXTRE(1)
      NDUM=NVAR
!
      WRITE(MW6,10010)
!
      WRITE(MW0,*)                                                      &
     &      '*** CGNR: DUMMY INTERFACE ROUTINE TO NUM REC CONJ GRAD ***'
!
      IMAXIT=-1
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(//'*** THIS IS A DUMMY INTERFACE ROUTINE FOR THE NUMERICAL'&
     &       ,                                                          &
     & ' RECIPES CONJUGATE GRADIENT METHOD. SET NVAR.GT.0 TO USE VA04A.'&
     & /'*** OR UNCOMMENT NON-DUMMY CGNR ROUTINE, RECOMPILE *AND* ',    &
     & 'LINK TO YOUR OWN LICENSED NUMERICAL RECIPES LIBRARY!'///)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE CGNR
!
!                             *******************
!
      FUNCTION CNORM(E,Z,L)
!
!-----------------------------------------------------------------------
!
! FN.CNORM RETURNS NORMALIZATION COEFFICIENT FOR A COULOMB FUNCTION OF
! ENERGY E, ANGULAR MOMENTUM L IN A CHARGE Z (<0) - BASED ON FCF4.
!
!  IT IS CALLED BY:
!    SR.FCF6
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
      PI=ACOS(-DONE)
      ZZ=Z*Z
!
      IF(E.GT.D1M40)GO TO 500
      IF(ABS(Z).GT.D1M15)GO TO 200
!
  100 CNORM=DZERO                                     !FAILURE
!
      RETURN
!
  200 IF(Z.LT.DZERO)GO TO 400
  300 CNORM=-DONE
      GO TO 100
!
  400 C=-Z*(PI+PI)
      GO TO 800
!
  500 EK=SQRT(E)
      T1=PI*Z/EK
      T2=ABS(T1)
      IF(T2.GT.D1M2)GO TO 600
!
      C=DTHREE*EK/(DTHREE+T1*(DTHREE+T1*(DTWO+T1)))
      GO TO 800
!
  600 IF(T2.LT.D80)GO TO 700
      IF(Z.LT.DZERO)GO TO 400
      GO TO 300
!
  700 C=DONE-EXP(T1+T1)
      C=-(PI+PI)*Z/C
  800 C2=DONE
!
      IF(L.GT.0)THEN
        DO J=1,L
          CJ=J
          CJ2=J+J
          C2=C2*CJ*(CJ2+DONE)
          C=C*(ZZ+E*CJ*CJ)
  820     IF(C+C2.GE.D1P70)THEN
            C2=D1M5*C2
            C=D1M10*C
            GO TO 820
          ENDIF
        ENDDO
      ENDIF
!
      CNORM=SQRT(C)/C2
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION CNORM
!
!                             *******************
!
      SUBROUTINE CONFG(ICFG0,K2,MXORBR,MXORB,MXCONF,MXCCF,IFILL0,ival0)
!
!-----------------------------------------------------------------------
!
!  SR.CONFG GENERATES CONFIGURATION INPUT FOR THE A.S. OPTION
!
!     ICFG.EQ. 0 DEFAULT: READS USER INPUT OF THE VALENCE OCCUPATION NOS
!                         FOR THE MXCONF CONFIGS.
!         .EQ. 1 READS GLOBAL MIN AND MAX ALLOWED OCCUPATION NOS
!               (MNAL,MXAL) THEN AS ICFG=0, PLUS NUMBER OF EXCITATIONS
!                IN POSITION MXORB+1.
!         .EQ. 2 READS MNAL,MXAL FOR EACH(BASE)MXCONF CONFIG.
!         .GE. 0 WRITES THIS INFO TO A CONFIG.DAT FILE
!         .LT. 0 READS A PREVIOUSLY WRITTEN CONFIG.DAT FILE
!
!         MXCONF IS THUS REDEFINED FOR ICFG.NE.0.
!
!  IT IS CALLED BY:
!    SR.CONFG0
!
!  IT CALLS:
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_DBD2,   ONLY: QL,QN,DEY
      USE COMMON_MQVC,   ONLY: LBASSH=>NEL,IDIFF1=>NPLUS1
!
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,NAST                          &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX                     &
     &                        ,MXBORB,MXVORB,MXFORB,NGRP
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
      USE ADF00, ONLY: BADF00,MSC00
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      CHARACTER(LEN=6) FORM,FORM2,FORM3
      CHARACTER(LEN=4) CSTAR
!
      LOGICAL BEX                         !INQUIRE REQUIRES DEFAULT KIND
!
      PARAMETER (MXD17=20)
!
      PARAMETER (FORM2='(60I2)')
      PARAMETER (FORM3='(40I3)')
!
      dimension ival0(0:mxorbr)
!
      ALLOCATABLE :: NGROUP(:)
!
      ALLOCATABLE :: MNAL(:,:),MXAL(:,:),MXN(:,:)                       &
     &              ,IBASSH(:,:),JBASSH(:,:),LOCSH(:)                   &
     &              ,NXCITE(:),IOCSH(:),NSPARE(:),IGRP(:),JGRP(:)       &
     &              ,NI(:),NTOTI(:),MN(:)
!
!-----------------------------------------------------------------------
!
! SOME INITIALIZATIONS
!
      NCON1=0
      NGRP0=0
!
      NOPTN=MXCONF
      IFILL1=MOD(IFILL0,ITEN)
      IFILL2=IFILL0/10
!
      ICFG=MOD(ICFG0,ITEN)
!
      IF(ABS(ICFG).GT.2)THEN                    !ILLEGAL OPTIONAL VALUE
        WRITE(MW6,*)'*SR.CONFIG: ERROR, ICFG HAS ILLEGAL VALUE:',ICFG
        WRITE(MW0,*)'*SR.CONFIG: ERROR, ICFG HAS ILLEGAL VALUE:'
        GO TO 1200
      ENDIF
!
      IF(BADF00)THEN
        IREAD=MSC00
      ELSE
        IREAD=MR5
      ENDIF
!
      IWRITE=MW6
!
      BPUNCH=ICFG0.GE.0
      BTWO=.FALSE.                        !***BTWO*** FIRST TREAT N-ELEC
      BBUG=.TRUE.              !WRITE CFG INFO READ FROM IREAD TO IWRITE
      BBUG2=.TRUE.   !WRITE TO SCREEN IF CFG BUFFER ALLOCATION INCREASED
!
      IF(IUNIT(MRW3).LE.0)THEN
        IF(BPUNCH)THEN
          OPEN(MRW3,FILE='CONFIG.DAT',STATUS='REPLACE')
        ELSE
          INQUIRE(FILE='CONFIG.DAT',EXIST=BEX)
          IF(BEX)THEN
            OPEN(MRW3,FILE='CONFIG.DAT',STATUS='OLD')
            WRITE(IWRITE,10010)IREAD
            IREAD=MRW3
          ELSE
            WRITE(MW6,*)'USER INPUT FILE "CONFIG.DAT" MISSING, ',       &
     &                  'BUT IS REQUIRED BECAUSE OF ICFG SETTING'
            WRITE(MW0,*)'USER INPUT FILE "CONFIG.DAT" MISSING, ',       &
     &                  'BUT IS REQUIRED BECAUSE OF ICFG SETTING'
            GO TO 1200
          ENDIF
        ENDIF
        IUNIT(MRW3)=1
      ELSE
        REWIND(MRW3)
      ENDIF
!
      IF(IEQ(0).GT.0)THEN
        IXD17=MXD17
        ALLOCATE(NGROUP(IXD17))
      ENDIF
!
! NUMBER OF CONFIGURATION SETS TO BE READ, AND ORBITALS
!
      IF(.NOT.BPUNCH)THEN                         !READ AN OLD CONFG.DAT
!
        ICFG=1
!
        READ(IREAD,*)K2,MXORB
!
        IF(MXORB.GT.IAXGR)THEN          !ONLY IF USER HAS CHANGED BUFFER
          WRITE(IWRITE,10030)MXORB
          WRITE(MW0,*)'INCREASE BUFFER IAXGR IN SR.ALGEB0'
          GO TO 1200
        ENDIF
!
        MXORBR=MXORB
        MXVORB=MXORB-ABS(K2)
!
      ENDIF
!
      I00=ABS(K2)
      I0=I00+1
      I1=I0
      IF(K2.LT.0)I1=1
!
      IF(.NOT.BPUNCH)READ(IREAD,*)(QN(L),QL(L),L=I1,MXORB)
!
  100 IF(.NOT.BPUNCH)READ(IREAD,*)NOPTN
!
      IF(NOPTN.GT.MAXCF)THEN
        IF(MAXCF.GT.0)WRITE(IWRITE,10020)MAXCF,NOPTN
      ENDIF
!
      IF(BBUG)WRITE(IWRITE,10070)NOPTN,MXORB
!
      JAXCF=MAX(NOPTN,IAXCF)
!
      IF(ICFG.EQ.0)THEN
!
        ALLOCATE(MNAL(MXORB,1),MXAL(MXORB,1),JBASSH(MXORB,JAXCF),       &
     &           JGRP(JAXCF),STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'CONFG: ALLOCATION FAILS FOR MNAL,MXAL,IBASSH...'
          NF=0
          GO TO 1100
        ENDIF
!
        MNAL=0
        MXAL=0
!
      ELSE
!
        ALLOCATE(MNAL(MXORB,JAXCF),MXAL(MXORB,JAXCF),MXN(MXORB,JAXCF),  &
     &           IBASSH(MXORB,JAXCF),JBASSH(MXORB,JAXCF),IGRP(JAXCF),   &
     &           JGRP(JAXCF),NXCITE(JAXCF),IOCSH(JAXCF),NSPARE(JAXCF),  &
     &           NI(MXORB),NTOTI(MXORB),MN(MXORB),STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'CONFG: ALLOCATION FAILS FOR MNAL,MXAL,IBASSH...'
          NF=0
          GO TO 1100
        ENDIF
!
      ENDIF
!
! A CONFIGURATION SET CONSISTS OF MIN OCCUPATION NOS, MAX
! OCCUPATION NOS, OCCUPATION NOS OF A BASIC CONFIGURATION
! TOGETHER WITH NUMBER OF EXCITATIONS FROM THE BASIC CONFIG.
!
      IFLG3=0
      NCON=NOPTN
      IF(IEQ(0).GT.0.AND.BPUNCH)THEN
        NGRP=0
      ELSE
        NGRP=999999
        IGROUP=0
      ENDIF
      M2=0
!
      IF(ICFG.EQ.0)THEN
!
  150   IF(IEQ(0).GT.0)THEN
          READ(IREAD,*)IGROUP,NOPTN
          NGRP=NGRP+1
          IF(NGRP0+NGRP.GT.IXD17)THEN
            IXXX=MAX(NCON*IXD17,NGRP0+NGRP)
            CALL RE_ALLOC(NGROUP,IONE,IXD17,IXXX,IERR)
            IXD17=IXXX
          ENDIF
          NGROUP(NGRP0+NGRP)=IGROUP
        ENDIF
!
        M1=M2+1
        M2=M2+NOPTN
!
        IF(M2.GT.JAXCF)THEN       !CASE OF SMALL BUFFER, OR V.LARGE READ
!
          JXXX=MAX(NCON*JAXCF,M2)
!
          IF(BBUG2)THEN
            WRITE(MW6,*)'*** CONFG: increasing MAXCF from ',JAXCF,      &
     &                  ' to: ',JXXX
            WRITE(MW0,*)'*** CONFG: increasing MAXCF from ',JAXCF,      &
     &                  ' to: ',JXXX
          ENDIF
!
          CALL RE_ALLOC2(MNAL,IONE,MXORB,IONE,JAXCF,MXORB,JXXX,IERR)
          CALL RE_ALLOC2(MXAL,IONE,MXORB,IONE,JAXCF,MXORB,JXXX,IERR)
          CALL RE_ALLOC2(JBASSH,IONE,MXORB,IONE,JAXCF,MXORB,JXXX,IERR)
!
          CALL RE_ALLOC(JGRP,IONE,JAXCF,JXXX,IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'SR.CONFG: RE-ALLOCATION FAILS FOR XBASSH ETC'
            NF=0
            GO TO 1100
          ENDIF
!
          JAXCF=JXXX
!
        ENDIF
!
        DO M=M1,M2
          JGRP(M)=IGROUP
!          NXCITE(M)=0
          READ(IREAD,*)(JBASSH(I,M),I=I0,MXORBR)
          IF(BBUG)WRITE(IWRITE,10100)M,(JBASSH(I,M),I=I0,MXORBR)
          DO I=I0,MXORBR
            mx=4*ql(i)+2
            if(jbassh(i,m).lt.0.or.jbassh(i,m).gt.mx)then
              WRITE(MW6,*)                                              &
     &                'SR.CONFG ERROR: CF HAS ILLEGAL OCC. NO. FOR L:  '&
     &                ,m,jbassh(i,m),ql(i)
              WRITE(MW0,*)                                              &
     &                   'SR.CONFG ERROR: CF HAS ILLEGAL OCC. NO. FOR L'
              GO TO 1200
            endif
            IF(JBASSH(I,M).GT.9)IFLG3=1
            MNAL(I,1)=MIN(MNAL(I,1),JBASSH(I,M))
            MXAL(I,1)=MAX(MXAL(I,1),JBASSH(I,M))
          ENDDO
          DO I=MXORBR+1,MXORB      !CASE ICFG=10, MXORBR.LT.MXORB
            JBASSH(I,M)=0
          ENDDO
        ENDDO
!
        IF(NGRP.LT.NCON)GO TO 150
!        NOPTN=M2
        NCON=M2
        GO TO 900
!
      ENDIF
!
!
      IF(ICFG.EQ.1)THEN
!
  200   IF(IEQ(0).GT.0.AND.BPUNCH)THEN
          READ(IREAD,*)IGROUP,NOPTN
          NGRP=NGRP+1
          IF(NGRP0+NGRP.GT.IXD17)THEN
            IXXX=MAX(NCON*IXD17,NGRP0+NGRP)
            CALL RE_ALLOC(NGROUP,IONE,IXD17,IXXX,IERR)
            IXD17=IXXX
          ENDIF
          NGROUP(NGRP0+NGRP)=IGROUP
        ENDIF
!
        M1=M2+1
        M2=M2+NOPTN
!
        IF(M2.GT.JAXCF)THEN       !CASE OF SMALL BUFFER, OR V.LARGE READ
!
          JXXX=MAX(NCON*JAXCF,M2)
!
          IF(BBUG2)THEN
            WRITE(MW6,*)'*** CONFG: increasing MAXCF from ',JAXCF,      &
     &                  ' to: ',JXXX
            WRITE(MW0,*)'*** CONFG: increasing MAXCF from ',JAXCF,      &
     &                  ' to: ',JXXX
          ENDIF
!
          CALL RE_ALLOC2(MNAL,IONE,MXORB,IONE,JAXCF,MXORB,JXXX,IERR)
          CALL RE_ALLOC2(MXAL,IONE,MXORB,IONE,JAXCF,MXORB,JXXX,IERR)
          CALL RE_ALLOC2(MXN,IONE,MXORB,IONE,JAXCF,MXORB,JXXX,IERR)
          CALL RE_ALLOC2(IBASSH,IONE,MXORB,IONE,JAXCF,MXORB,JXXX,IERR)
          CALL RE_ALLOC2(JBASSH,IONE,MXORB,IONE,JAXCF,MXORB,JXXX,IERR)
!
          CALL RE_ALLOC(NXCITE,IONE,JAXCF,JXXX,IERR)
          CALL RE_ALLOC(IOCSH,IONE,JAXCF,JXXX,IERR)
          CALL RE_ALLOC(NSPARE,IONE,JAXCF,JXXX,IERR)
          CALL RE_ALLOC(IGRP,IONE,JAXCF,JXXX,IERR)
          CALL RE_ALLOC(JGRP,IONE,JAXCF,JXXX,IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'SR.CONFG: RE-ALLOCATION FAILS FOR XBASSH ETC'
            NF=0
            GO TO 1100
          ENDIF
!
          JAXCF=JXXX
!
        ENDIF
!
        READ(IREAD,*)(MNAL(I,M1),I=I0,MXORBR)
        IF(BBUG)WRITE(IWRITE,10080)(MNAL(I,M1),I=I0,MXORBR)
        READ(IREAD,*)(MXAL(I,M1),I=I0,MXORBR)
        IF(BBUG)WRITE(IWRITE,10090)(MXAL(I,M1),I=I0,MXORBR)
!
        DO M=M1,M2
          IGRP(M)=IGROUP
          READ(IREAD,*,END=250)(IBASSH(I,M),I=I0,MXORBR),NXCITE(M)
          IF(BBUG)THEN
            WRITE(IWRITE,10100)M,(IBASSH(I,M),I=I0,MXORBR)
            IF(IEQ(0).LE.0.OR.BPUNCH)THEN
              WRITE(IWRITE,10110)NXCITE(M)
            ELSE
              WRITE(IWRITE,10120)IGRP(M)
            ENDIF
          ENDIF
          DO I=I0,MXORB
            MNAL(I,M)=MNAL(I,M1)
            MXAL(I,M)=MXAL(I,M1)
          ENDDO
          IFILL=IFILL1
          IF(BTWO)IFILL=IFILL2
          IF(IFILL.LT.0)IFILL=NXCITE(M)
          DO I=MXORBR+1,MXORB
            IBASSH(I,M)=0
            MNAL(I,M)=0
            MXAL(I,M)=IFILL
          ENDDO
        ENDDO
!
        IF(NGRP.LT.NCON)GO TO 200
!
        NOPTN=M2
        GO TO 300
!
  250   M=M-1
        WRITE(IWRITE,10040)NOPTN,M
        NOPTN=M
!        NCON=M
!
  300   IF(.NOT.BPUNCH)THEN    !JUST READ (PAST TENSE) A CONFIG.DAT FILE
!
          NOPTN0=NOPTN  !QUIETLY DROP DUPLICATE CFS, E.G. DUE TO MERGING
          DO M0=2,NOPTN0
            M=M0-NOPTN0+NOPTN
            DO L=1,M-1
              DO I=I0,MXORB
                IF(IBASSH(I,L).NE.IBASSH(I,M))GO TO 310
              ENDDO
              WRITE(MW0,*)'*** DUPLICATE CONFIGURATIONS',L,' AND',M0
              DO J=M+1,NOPTN                                       !DROP
                NXCITE(J-1)=NXCITE(J)
                DO I=I0,MXORB
                  IBASSH(I,J-1)=IBASSH(I,J)
                ENDDO
              ENDDO
              IF(M.LE.KCUT)KCUT=KCUT-1
              NOPTN=NOPTN-1
              GO TO 320
  310       ENDDO
  320     ENDDO
          NCON=NOPTN
!                                 TRANSFER TO FINAL LOCATION
          NEX=0
          IF(IEQ(0).GT.0)THEN
            DO M=1,NOPTN
              JGRP(M)=NXCITE(M)
              NXCITE(M)=0
              IEQ(0)=MAX(IEQ(0),JGRP(M))
            ENDDO
          ELSE
            DO M=1,NOPTN
              NEX=NEX+NXCITE(M)
            ENDDO
          ENDIF
          IF(NEX.EQ.0)THEN
            DO M=1,NOPTN
              DO I=I0,MXORB
                JBASSH(I,M)=IBASSH(I,M)
              ENDDO
            ENDDO
            GO TO 900
          ENDIF
!
        ENDIF
!
      ENDIF
!
!
      IF(ICFG.EQ.2)THEN
!
  350   IF(IEQ(0).GT.0)THEN
          READ(IREAD,*)IGROUP,NOPTN
          NGRP=NGRP+1
          IF(NGRP0+NGRP.GT.IXD17)THEN
            IXXX=MAX(NCON*IXD17,NGRP0+NGRP)
            CALL RE_ALLOC(NGROUP,IONE,IXD17,IXXX,IERR)
            IXD17=IXXX
          ENDIF
          NGROUP(NGRP0+NGRP)=IGROUP
        ENDIF
!
        M1=M2+1
        M2=M2+NOPTN
!
        IF(M2.GT.JAXCF)THEN       !CASE OF SMALL BUFFER, OR V.LARGE READ
!
          JXXX=MAX(NCON*JAXCF,M2)
!
          IF(BBUG2)THEN
            WRITE(MW6,*)'*** CONFG: increasing MAXCF from ',JAXCF,      &
     &                  ' to: ',JXXX
            WRITE(MW0,*)'*** CONFG: increasing MAXCF from ',JAXCF,      &
     &                  ' to: ',JXXX
          ENDIF
!
          CALL RE_ALLOC2(MNAL,IONE,MXORB,IONE,JAXCF,MXORB,JXXX,IERR)
          CALL RE_ALLOC2(MXAL,IONE,MXORB,IONE,JAXCF,MXORB,JXXX,IERR)
          CALL RE_ALLOC2(MXN,IONE,MXORB,IONE,JAXCF,MXORB,JXXX,IERR)
          CALL RE_ALLOC2(IBASSH,IONE,MXORB,IONE,JAXCF,MXORB,JXXX,IERR)
          CALL RE_ALLOC2(JBASSH,IONE,MXORB,IONE,JAXCF,MXORB,JXXX,IERR)
!
          CALL RE_ALLOC(NXCITE,IONE,JAXCF,JXXX,IERR)
          CALL RE_ALLOC(IOCSH,IONE,JAXCF,JXXX,IERR)
          CALL RE_ALLOC(NSPARE,IONE,JAXCF,JXXX,IERR)
          CALL RE_ALLOC(IGRP,IONE,JAXCF,JXXX,IERR)
          CALL RE_ALLOC(JGRP,IONE,JAXCF,JXXX,IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'SR.CONFG: RE-ALLOCATION FAILS FOR XBASSH ETC'
            NF=0
            GO TO 1100
          ENDIF
!
          JAXCF=JXXX
!
        ENDIF
!
        DO M=M1,M2
          IGRP(M)=IGROUP
          READ(IREAD,*)(MNAL(I,M),I=I0,MXORBR)
          IF(BBUG)WRITE(IWRITE,10080)(MNAL(I,M),I=I0,MXORBR)
          READ(IREAD,*)(MXAL(I,M),I=I0,MXORBR)
          IF(BBUG)WRITE(IWRITE,10090)(MXAL(I,M),I=I0,MXORBR)
          READ(IREAD,*)(IBASSH(I,M),I=I0,MXORBR),NXCITE(M)
          IF(BBUG)THEN
            WRITE(IWRITE,10100)M,(IBASSH(I,M),I=I0,MXORBR)
            IF(IEQ(0).LE.0.OR.BPUNCH)THEN
              WRITE(IWRITE,10110)NXCITE(M)
            ELSE
              WRITE(IWRITE,10120)IGRP(M)
            ENDIF
          ENDIF
          IFILL=IFILL1
          IF(BTWO)IFILL=IFILL2
          IF(IFILL.LT.0)IFILL=NXCITE(M)
          DO I=MXORBR+1,MXORB
            IBASSH(I,M)=0
            MNAL(I,M)=0
            MXAL(I,M)=IFILL
          ENDDO
        ENDDO
!
        IF(NGRP.LT.NCON)GO TO 350
        NOPTN=M2
!
      ENDIF
!
! perform sanity checks. this is to catch typos etc.
!
  400 do m=1,noptn
        if(nxcite(m).lt.0)nxcite(m)=0
        do i=i0,mxorbr
          if(mxal(i,m).lt.0)mxal(i,m)=0
          if(mnal(i,m).lt.0)mnal(i,m)=0
          if(ibassh(i,m).lt.0)ibassh(i,m)=0
          im=ibassh(i,m)-nxcite(m)
          if(mnal(i,m).lt.im)mnal(i,m)=im
          mx=4*ql(i)+2
          if(mnal(i,m).gt.mx)mnal(i,m)=mx
          if(mxal(i,m).gt.mx)mxal(i,m)=mx
          if(ibassh(i,m).gt.mx)ibassh(i,m)=mx
          ip=ibassh(i,m)+nxcite(m)
          if(mxal(i,m).gt.ip)mxal(i,m)=ip
          if(ival0(i).gt.0)mxal(i,m)=0                 !suppress Ryd orb
        enddo
      enddo
!
! DETERMINE NUMBER OF ELECTRONS
!
      NELC=0
      DO I=I0,MXORB
        NELC=NELC+IBASSH(I,1)
      ENDDO
      IF(BBUG)WRITE(IWRITE,10130)NELC
!
! CHECK OTHER CONFIGS FOR CONSISTENCY
!
      IFAIL=0
      DO M=2,NOPTN
        N=0
        DO I=I0,MXORB
          N=N+IBASSH(I,M)
        ENDDO
        IF(N.NE.NELC)THEN
          IFAIL=1
          WRITE(IWRITE,10140)M,N
        ENDIF
      ENDDO
!
      IF(IFAIL.NE.0)THEN
        WRITE(MW6,*)'SR.CONFG ERROR: CONFIGURATION MIS-MATCH'
        WRITE(MW0,*)'SR.CONFG ERROR: CONFIGURATION MIS-MATCH'
        GO TO 1200
      ENDIF
!
! PERFORM SOME CHECKS ON MNAL AND MXAL FOR CONSISTENCY
!
      IFAIL=0
      DO M=1,NOPTN
        NSPARE(M)=NELC
        DO I=I0,MXORB
          NSPARE(M)=NSPARE(M)-MNAL(I,M)
        ENDDO
        IF(NSPARE(M).LT.0)THEN
          WRITE(IWRITE,10150)M
          IFAIL=1
        ENDIF
      ENDDO
!
      IF(IFAIL.NE.0)THEN
        WRITE(MW6,*)'SR.CONFG ERROR: MNAL INCONSISTENCY'
        WRITE(MW0,*)'SR.CONFG ERROR: MNAL INCONSISTENCY'
        GO TO 1200
      ENDIF
!
      DO M=1,NOPTN
        DO I=I0,MXORB
          NE=MNAL(I,M)+NSPARE(M)
          IF(NE.LT.MXAL(I,M))THEN
            MXAL(I,M)=NE
            WRITE(IWRITE,10180)I,M
          ENDIF
          MXN(I,M)=MXAL(I,M)+1
        ENDDO
      ENDDO
!
! CHECK CONSISTENCY OF BASIC CONFIG WITH MNAL,MXAL AND
! STORE LAST OCCUPIED SHELL FOR EACH BASIC CONFIGURATION
!
      IFAIL=0
      DO M=1,NOPTN
        DO I=I0,MXORB
          J=MXORB-I+I0
          IF(IBASSH(J,M).GT.0)THEN
            IOCSH(M)=J
            DO L=I0,J
              IF(IBASSH(L,M).GT.MXAL(L,M).AND.                          &
     &           (l.gt.mxorbr.or.l.le.mxorbr.and.ival0(l).eq.0))THEN
                WRITE(IWRITE,10160)M
                IFAIL=1
              ELSEIF(IBASSH(L,M).LT.MNAL(L,M))THEN
                WRITE(IWRITE,10170)M
                IFAIL=1
              ENDIF
            ENDDO
            GO TO 500
          ENDIF
          IF(MNAL(J,M).GT.0)THEN
            WRITE(IWRITE,10170)M
            IFAIL=1
          ENDIF
        ENDDO
  500 ENDDO
!
      IF(IFAIL.NE.0)THEN
        WRITE(MW6,*)'SR.CONFG ERROR: BASIC CONFIG INCONSISTENCY'
        WRITE(MW0,*)'SR.CONFG ERROR: BASIC CONFIG INCONSISTENCY'
        GO TO 1200
      ENDIF
!
! LOOP OVER ALL POSSIBLE ELECTRON DISTRIBUTIONS
!
      NCON=0
      DO M=1,NOPTN
!
        n2cum=0
        do i=i0,mxorb
          n2cum=n2cum+mnal(i,m)
        enddo
!
        I=I00
!
  550   I=I+1
        n2cum=n2cum-mnal(i,m)
        NI(I)=0
!
  600   NI(I)=NI(I)+1
        NSTOP=I
!
        MI=MXN(I,M)-NI(I)
        IF(MI.LT.MNAL(NSTOP,M))GO TO 750
        NTOT=MI
        IF(I.GT.I0)NTOT=NTOT+NTOTI(I-1)
        NTOTI(I)=NTOT
        MN(I)=MI
        IF(NTOT+n2cum.GT.NELC)GO TO 750
        IF(NTOT.LT.NELC)GO TO 700
!
! CHECK FOR CORRECT PARITY (IF NECESSARY, BUT DO NOT SELECT N & N+1)
!
        IF(IPAR.LT.2.AND.(MXCCF.EQ.0.OR.BTWO))THEN
          LPAR=0
          DO L=I0,NSTOP
            IF(MOD(INT(QL(L),SP),ITWO).NE.0)LPAR=LPAR+MN(L)
          ENDDO
          IF(MOD(LPAR,ITWO).NE.IPAR)GO TO 700
        ENDIF
!
! TEST FOR EXCITATION ALLOWED FROM THE BASIC CONFIGURATIONS
!
        NEX=0
        DO L=I0,IOCSH(M)
          IF(L.GT.NSTOP)THEN
            NEX=NEX+IBASSH(L,M)
            GO TO 650
          ENDIF
          NB=IBASSH(L,M)
          NA=MN(L)
          IF(NA.LT.NB)NEX=NEX+NB-NA
  650   ENDDO
!
        IF(NEX.LE.NXCITE(M))THEN  !ALLOWED
!
          DO N=1,NCON               !SEE IF WE ALREADY HAVE IT
            DO L=I0,NSTOP
              IF(MN(L).NE.JBASSH(L,N))GO TO 660
            ENDDO
            GO TO 700               !OLD
  660     ENDDO
!
          IF(BTWO)THEN           !SEE IF N+1 CAN BE FORMED FROM N CONFIG
! IDIFF1 IS THE NO. OF PAIRS THEY DIFFER BY, PLUS 1 (FOR EXTRA ELECTRON)
!            IDIFF1=1            !FOR DR, EXISTING PROMO (OR R-MATRIX)
!            IDIFF1=3            !FOR DR, VIA NEW PROMO
            DO L=NSTOP+1,MXORB
              MN(L)=0
            ENDDO
            DO N=1,NCON1
              IDIFF=0
              LMAX=MAX(NSTOP,LOCSH(N))
              DO L=I0,LMAX
                IDIFF=IDIFF+ABS(LBASSH(L,N)-MN(L))
              ENDDO
              IF(mod(IDIFF,ITWO).EQ.0)THEN
                WRITE(MW6,*)'SR.CONFG ERROR: IDIFF=0!!'
                WRITE(MW0,*)'SR.CONFG ERROR: IDIFF=0!!'
!          write(mw0,*)n,idiff
!          write(mw0,*)(mn(l),l=i0,lmax)
!          write(mw0,*)(lbassh(l,n),l=i0,lmax)
                GO TO 1200
              ENDIF
              IF(IDIFF.le.IDIFF1)then
!                if(idiff.eq.3)then
!          write(mw6,*)n,idiff
!          write(mw6,*)(mn(l),l=i0,lmax)
!          write(mw6,*)(lbassh(l,n),l=i0,lmax)
!                endif
                GO TO 680  !O.K.
              endif
            ENDDO
!        write(mw0,*)n,idiff
            GO TO 700
          ENDIF
! NEW
  680     NCON=NCON+1
          IF(NCON.GT.JAXCF)THEN                               !GO TO 500
!
            JXXX=7*(JAXCF/5+1)
!
            IF(BBUG2)THEN
              WRITE(MW6,*)'*** CONFG: increasing MAXCF from ',JAXCF,    &
     &                    ' to: ',JXXX
              WRITE(MW0,*)'*** CONFG: increasing MAXCF from ',JAXCF,    &
     &                    ' to: ',JXXX
            ENDIF
!
            CALL RE_ALLOC2(MNAL,IONE,MXORB,IONE,JAXCF,MXORB,JXXX,IERR)
            CALL RE_ALLOC2(MXAL,IONE,MXORB,IONE,JAXCF,MXORB,JXXX,IERR)
            CALL RE_ALLOC2(MXN,IONE,MXORB,IONE,JAXCF,MXORB,JXXX,IERR)
            CALL RE_ALLOC2(IBASSH,IONE,MXORB,IONE,JAXCF,MXORB,JXXX,IERR)
            CALL RE_ALLOC2(JBASSH,IONE,MXORB,IONE,JAXCF,MXORB,JXXX,IERR)
!
            CALL RE_ALLOC(NXCITE,IONE,JAXCF,JXXX,IERR)
            CALL RE_ALLOC(IOCSH,IONE,JAXCF,JXXX,IERR)
            CALL RE_ALLOC(NSPARE,IONE,JAXCF,JXXX,IERR)
            CALL RE_ALLOC(IGRP,IONE,JAXCF,JXXX,IERR)
            CALL RE_ALLOC(JGRP,IONE,JAXCF,JXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'SR.CONFG: RE-ALLOCATION FAILS FOR XBASSH ETC'
              NF=0
              GO TO 1100
            ENDIF
!
            JAXCF=JXXX
!
          ENDIF
!
          JGRP(NCON)=IGRP(M)
!
          DO L=I0,NSTOP
            JBASSH(L,NCON)=MN(L)
            IF(MN(L).GT.9)IFLG3=IFLG3+1
          ENDDO
          DO L=NSTOP+1,MXORB
            JBASSH(L,NCON)=0
          ENDDO
!
        ENDIF
!
  700   IF(I.LT.MXORB)GO TO 550
        IF(I.GT.MXORB)GO TO 800
!
  750   IF(NI(I).LT.MXN(I,M))GO TO 600
        n2cum=n2cum+mnal(i,m)
        I=I-1
        IF(I.GT.I00)GO TO 750
!
  800 ENDDO
!
! DETERMINE GLOBAL MAX AND MIN OCCUPATIONS
!
      DO M=2,NOPTN
        DO L=I0,MXORB
          MNAL(L,1)=MIN(MNAL(L,1),MNAL(L,M))
          MXAL(L,1)=MAX(MXAL(L,1),MXAL(L,M))
        ENDDO
      ENDDO
!
! WRITE CONFIGS TO FILE
! (CURRENTLY, NO GROUP INFO WRITTEN, SO CUT-AND-PASTE TO UNIT5 & ADD.)
!
  900 IF(BPUNCH)THEN
        IF(IFLG3.EQ.0)THEN
          FORM=FORM2
        ELSE
          FORM=FORM3
        ENDIF
        IF(.NOT.BTWO)THEN
          WRITE(MRW3,10050)K2,MXORB
          WRITE(MRW3,10060)(QN(L),QL(L),L=I1,MXORB)
        ENDIF
        WRITE(MRW3,10050)NCON
        WRITE(MRW3,FORM)(MNAL(L,1),L=I0,MXORB)
        WRITE(MRW3,FORM)(MXAL(L,1),L=I0,MXORB)
        DO N=1,NCON
          WRITE(MRW3,FORM)(JBASSH(L,N),L=I0,MXORB),JGRP(N)
        ENDDO
      ENDIF
!
      IF(BTWO)THEN                        !FALSE ON FIRST PASS)
!
        DEALLOCATE(LOCSH,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'SR.CONFG: DE-ALLOCATION FAILS FOR (BTWO) LOCSH'
          NF=0
          GO TO 1100
        ENDIF
!
        MXCCF=NCON
        NCON=NCON+NCON1
!
        IF(NCON.GT.IAXCF)THEN
!
!          IXXX=NCON
!                     ESTIMATE TO REDUCE POSSIBILITY OF FURTHER RE-ALLOC
          IXXX=10*NCON1+MXCCF
!
          IF(BBUG2)THEN
            WRITE(MW6,*)'** CONFG: increasing MAXCF from ',IAXCF,       &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'** CONFG: increasing MAXCF from ',IAXCF,       &
     &                  ' to: ',IXXX
          ENDIF
!
          CALL RE_ALLOC2(LBASSH,IONE,MXORB,IONE,NCON1,IAXGR,IXXX,IERR)
!                                                     NOT MXORB
          CALL RE_ALLOC(ICFGP,IONE,NCON1,IXXX,IERR)
!
          IAXCF=IXXX
!
        ENDIF
!
! ARCHIVE N+1-ELEC AT END OF CF STORAGE
!
        NN=IAXCF-MXCCF
        DO N=1,MXCCF
          NN=NN+1
          ICFGP(NN)=JGRP(N)
          DO L=I0,MXORB
            LBASSH(L,NN)=JBASSH(L,N)
          ENDDO
        ENDDO
!
        GO TO 1000                       ! *** RETURN
!
      ENDIF                              !END N+1
!
      BTWO=MXCCF.NE.0                    ! ***BTWO***
!
      IF(NCON.GT.IAXCF)THEN
!
        DEALLOCATE(LBASSH,ICFGP,STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'SR.CONFG: DE-ALLOCATION FAILS FOR LBASSH=>NEL'
          NF=0
          GO TO 1100
        ENDIF
!
        IAXCF=NCON
        IF(BTWO)IAXCF=3*IAXCF       !3* TO REDUCE CHANCE OF N+1 RE-ALLOC
!                                            !IAXGR AS MXORB NOT MAXIMAL
        ALLOCATE(LBASSH(IAXGR,IAXCF),ICFGP(IAXCF),STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'SR.CONFG: ALLOCATION FAILS FOR LBASSH=>NEL,ICFGP'
          NF=0
          GO TO 1100
        ENDIF
!
      ENDIF
!
! ARCHIVE N-ELEC
!
      DO N=1,NCON
        ICFGP(N)=JGRP(N)
        DO I=I0,MXORB
          LBASSH(I,N)=JBASSH(I,N)
        ENDDO
      ENDDO
!
      IF(BTWO)THEN                                   !NOW TREAT N+1-ELEC
!
        ALLOCATE(LOCSH(NCON),STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'SR.CONFG: ALLOCATION FAILS FOR LOCSH'
          NF=0
          GO TO 1100
        ENDIF
!
        DO N=1,NCON
          DO I=I0,MXORB
            IF(LBASSH(I,N).GT.0)LOCSH(N)=I
          ENDDO
        ENDDO
!
        NCON1=NCON
        NGRP0=NGRP
!
        IF(ICFG0.LT.0)THEN
          DEALLOCATE(MNAL,MXAL,MXN,IBASSH,JBASSH,NXCITE,IOCSH,NSPARE,   &
     &               IGRP,JGRP,NI,NTOTI,MN,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)                                                &
     &               'SR.CONFG:DE-ALLOCATION FAILS FOR MNAL,MXAL,IBASSH'
            NF=0
            GO TO 1100
          ENDIF
          ICFG=1
          GO TO 100
        ENDIF
!
        IF(MXCCF.LT.0)THEN               !FORM N+1 SET
          IF(IEQ(0).GT.0)THEN
            WRITE(IWRITE,*)                                             &
     &            "***SR.CONFG: CANNOT USE MXCCF.LT.0 WITH BASIS='SRLX'"
            WRITE(MW0,*)"SR.CONFG: NEED MXCCF.GT.0 FOR BASIS='SRLX'"
            GO TO 1200
          ENDIF
          M1=1
          DO I=I0,MXORB
            IF(MXAL(I,M1).LT.4*QL(I)+2)MXAL(I,1)=MXAL(I,M1)+1
          ENDDO
          NOPTN=MIN(-MXCCF,NCON1)
          DO M=1,NOPTN
            DO I=I0,MXORB
              IBASSH(I,M)=JBASSH(I,M)
              MNAL(I,M)=MNAL(I,M1)
              MXAL(I,M)=MXAL(I,M1)
            ENDDO
            NXCITE(M)=NXCITE(M)+1
            II=LOCSH(M)
            IF(IBASSH(II,M).LT.4*QL(II)+2)THEN
              IBASSH(II,M)=IBASSH(II,M)+1
            ELSE
              II=II+1
              IBASSH(II,M)=1
              IF(MXORBR.LT.II)MXORBR=II
            ENDIF
          ENDDO
          IF(BBUG)THEN
            WRITE(IWRITE,10070)NOPTN,MXORBR
            WRITE(IWRITE,10080)(MNAL(I,M1),I=I0,MXORBR)
            WRITE(IWRITE,10090)(MXAL(I,M1),I=I0,MXORBR)
            DO M=1,NOPTN
              WRITE(IWRITE,10100)M,(IBASSH(I,M),I=I0,MXORBR)
              WRITE(IWRITE,10110)NXCITE(M)
            ENDDO
          ENDIF
          ICFG=1
          GO TO 400
        ELSE                             !MXCCF.GE.0
          IF(ICFG.EQ.0)THEN
            DEALLOCATE(MNAL,MXAL,JBASSH,JGRP,STAT=IERR)
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)                                              &
     &               'SR.CONFG:DE-ALLOCATION FAILS FOR MNAL,MXAL,JBASSH'
              NF=0
              GO TO 1100
            ENDIF
          ELSE
            DEALLOCATE(MNAL,MXAL,MXN,IBASSH,JBASSH,NXCITE,IOCSH,NSPARE, &
     &                 IGRP,JGRP,NI,NTOTI,MN,STAT=IERR)
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)                                              &
     &               'SR.CONFG:DE-ALLOCATION FAILS FOR MNAL,MXAL,IBASSH'
              NF=0
              GO TO 1100
            ENDIF
          ENDIF
          ICFG=ICFG0/10
          NOPTN=MXCCF
          GO TO 100
        ENDIF
!
      ENDIF
!
 1000 MXCONF=NCON
!
      IF(IEQ(0).GT.0.AND.ICFG0.GE.0)THEN              !CHECK GROUP NOS
        NGPMIN=9999
        NGPMAX=0
        NGRP=NGRP+NGRP0
!p        IEQ(0)=NGRP
        DO N1=1,NGRP
          NGPMIN=MIN(NGPMIN,NGROUP(N1))
          NGPMAX=MAX(NGPMAX,NGROUP(N1))
          DO N2=N1+1,NGRP
            IF(NGROUP(N2).EQ.NGROUP(N1))THEN
              WRITE(MW6,*)'SR.CONFG ERROR: GROUP NO. INCONSISTENCY'
              WRITE(MW0,*)'SR.CONFG ERROR: GROUP NO. INCONSISTENCY'
              DO N=1,NGRP
                IF(N.EQ.N1.OR.N.EQ.N2)THEN
                  CSTAR=' ***'
                ELSE
                  CSTAR='    '
                ENDIF
                WRITE(MW6,*)NGROUP(N),CSTAR
              ENDDO
              GO TO 1200
            ENDIF
          ENDDO
        ENDDO
        IF(NGPMIN.LE.0)THEN
          WRITE(MW6,*)'SR.CONFG ERROR: NEGATIVE GROUP NO. NOT ALLOWED'
          WRITE(MW0,*)'SR.CONFG ERROR: NEGATIVE GROUP NO. NOT ALLOWED'
          GO TO 1200
        ENDIF
        IF(NGPMAX.GT.NGRP)THEN
          WRITE(MW6,*)'SR.CONFG ERROR: NO GAPS IN GROUP NUMBERS ALLOWED'
          WRITE(MW0,*)'SR.CONFG ERROR: NO GAPS IN GROUP NUMBERS ALLOWED'
          GO TO 1200
        ENDIF
      ENDIF
!
      IF(ICFG.EQ.0)THEN
        DEALLOCATE(MNAL,MXAL,JBASSH,JGRP,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)                                                  &
     &               'SR.CONFG:DE-ALLOCATION FAILS FOR MNAL,MXAL,JBASSH'
          NF=0
        ENDIF
      ELSE
        DEALLOCATE(MNAL,MXAL,MXN,IBASSH,JBASSH,IGRP,JGRP,NXCITE,IOCSH,  &
     &             NSPARE,NI,NTOTI,MN,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)                                                  &
     &              'SR.CONFG: DE-ALLOCATION FAILS FOR MNAL,MXAL,IBASSH'
          NF=0
        ENDIF
      ENDIF
!
 1100 CONTINUE
!
      IF(IEQ(0).GT.0)DEALLOCATE(NGROUP)
!
      IF(IUNIT(MRW3).GT.0)THEN
        CLOSE(MRW3)
        IUNIT(MRW3)=-1
      ENDIF
!
      IF(BADF00)CLOSE(IREAD)
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
 1200 NF=-1
      GO TO 1100
!
!-----------------------------------------------------------------------
!
10010 FORMAT(/' NOTE: READING CONFIGURATIONS FROM FILE CONFIG.DAT:',    &
     &       ' ANY CONFIGURATION DATA ON UNIT',I3,' WILL BE IGNORED.'/)
10020 FORMAT(' SR.CONFG: ALLOCATION INCREASES STORAGE FROM MAXCF=',I5,  &
     &       ' TO IAXCF=',I7,' CONFIGURATIONS')
10030 FORMAT('SR.CONFG:  INCREASE BUFFER IAXGR IN SR.ALGEB0 TO',I5)
10040 FORMAT(/'SR.CONFG:  NO. OF CONFIGS REDUCED FROM',I5,' TO',I5,     &
     &       '; ALL THAT',' ARE PRESENT IN CONFIG.DAT FILE'/)
10050 FORMAT(2I5)
10060 FORMAT(30(I3,I2))
10070 FORMAT(/6X,'OPTION CHOSEN, NOPTN=',I5,' FOR ORBITALS MXORB=',I4)
10080 FORMAT(' THE MINIMUM NUMBER OF ELECTRONS ALLOWED IN THIS SHELL IS'&
     &       ,2X,(20I3))
10090 FORMAT(' THE MAXIMUM NUMBER OF ELECTRONS ALLOWED IN THIS SHELL IS'&
     &       ,2X,(20I3))
10100 FORMAT(' BASIC CONFIGURATION',I5,34X,(20I3))
10110 FORMAT(' THE MAXIMUM NUMBER OF ELECTRON EXCITATIONS REQUIRED=',I3)
10120 FORMAT(' GROUP NUMBER',I3)
10130 FORMAT(' TOTAL NUMBER OF ELECTRONS =',I3)
10140 FORMAT(' ERROR, CONFIGURATION ',I5,' HAS ',I3,' ELECTRONS')
10150 FORMAT(' ERROR, TOO MANY ELECTRONS REQUIRED BY MNAL FOR',         &
     &       ' CONFIGURATION',I5)
10160 FORMAT(' ERROR, BASIC OCCUPATION NO GT MXAL FOR CONFIG ',I5)
10170 FORMAT(' ERROR, BASIC OCCUPATION NO LT MNAL FOR CONFIG ',I5)
10180 FORMAT(' WARNING, MXAL TOO LARGE FOR ORBITAL ',I4,                &
     &       ' IN CONFIGURATION ',I5)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE CONFG
!
!                             *******************
!
      SUBROUTINE CONFG0(RUN,ICFG,MXVORB,MXCONF,MXCCF,KCUTCC,NXTRA,LXTRA &
     &                 ,LCONT,LCON0,KCUT0,IFILL)
!
!-----------------------------------------------------------------------
!
!  SR.CONFG0 READS USER INPUT, CONFIGURATIONS FOR CASE A.S. VIA
!  FREE-FORMAT OCCUPATION NUMBERS R-MATRIX STG2 STYLE. INDEED, IT CALLS
!  A MODIFIED SR.CONFIG TO APPLY PROMOTION RULES ETC.
!  ALSO, AUTOMATICALLY GENERATES N+1 ELECTRON CONFIGS FROM
!  N-ELECTRON TARGET, FOR BOUND-CONTINUUM PROBLEMS (DR/RR ETC.)
!
!  IT IS CALLED BY:
!    SR.ALGEB0
!
!  IT CALLS:
!    SR.CONFG
!    SR.DIMUSE
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      USE COMMON_ALGEB,  ONLY: BFOT
!!      COMMON /BASIC/NF,KX,KG,K1,K2,MGAP(7)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,IBSK2=>IBSK2,KG=>IBSK3,IBSK4=>IBSK4,IBSK5=>IBSK5   &
     &              ,IBSK6=>IBSK6,IBSK7=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9&
     &              ,IBSK10=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_DBD2,   ONLY: QL,QN,DEY
      USE COMMON_MQVC,   ONLY: MODD,KCUT,KMAX,NEL
!
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL1, ONLY: ISCALR
      USE COMMON_NRBAL2, ONLY: MDEL,MXORBR,MPOL00,MPOL0,MPOLE,MPOLX,CODE
      USE COMMON_NRBDR,  ONLY: IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR
      USE COMMON_NRBDR,  ONLY: LNEW,LCON,LSUM,LMAX,lcmin,BLOOP
      USE COMMON_NRBDW,  ONLY: IDW,btop
      USE COMMON_NRBKUTP,ONLY: KCUTP,LSKUTP,NASTKP
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
!p         &               ,MXBORB,MXVORB,MXFORB,NGRP   !& RM CONFG0 ARG
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      CHARACTER(LEN=4) RUN
!
      ALLOCATABLE :: KORDER(:),ival0(:)                           !LOCAL
!
!-----------------------------------------------------------------------
!
!      IF(MA.NE.K1.OR.MB.NE.K2)STOP 'SR.CONFG0: CLOSED-SHELLS MIX-UP'
!
      i69=69   !restrict checks on QL for/to QN as .ge.70 is just a flag
!
      BDR=IDR.NE.0
      KPOLE=MPOLE/2
      KPOL0=MPOL00/2                        !.LT.0 FLAGS HISTORIC SET-UP
      MPOL00=ABS(MPOL00)                               !NOW REMOVE FLAG
!
      MXCCF0=MXCCF
      IF(MXCCF.LT.0)THEN
        MXCCF=MOD(MXCCF,I999)
        IF(MOD(ICFG,ITEN).EQ.0)MXCCF=0               !INITIALIZE DEFAULT
      ENDIF
!
      IF(MXVORB.NE.0)THEN
!
! READ NL DEFINITIONS. CORE BASE CONFIGS WILL CONTAIN MXVORBS
!
        MXORB=ABS(MB)+ABS(MXVORB)
!
        IF(MXORB.GT.IAXGR)THEN
!
          WRITE(MW6,*)'*** CONFG0: increasing MAXGR from ',IAXGR,       &
     &                ' to: ',MXORB
          WRITE(MW0,*)'*** CONFG0: increasing MAXGR from ',IAXGR,       &
     &                ' to: ',MXORB
!
          IAXGR=MXORB
!
! EX-COMMON/CCLSH/
          DEALLOCATE(NEL)
!
          ALLOCATE(NEL(IAXGR,IAXCF),STAT=IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'SR.CONFG0: ALLOCATION FAILS FOR NEL'
            NF=0
            GO TO 200
          ENDIF
!
! EX-COMMON/NRBORB/
          DEALLOCATE(IEQ,IGRCF)
!
          ALLOCATE(IEQ(0:IAXGR),IGRCF(IAXGR),STAT=IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'SR.CONFG0: ALLOCATION FAILS FOR IEQ,IGRCF'
            NF=0
            GO TO 200
          ENDIF
!
! EX-COMMON/DBD2/
          DEALLOCATE(QL,QN,DEY)
!
          ALLOCATE(QL(IAXGR),QN(IAXGR),DEY(IAXGR),STAT=IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'SR.CONFG0: ALLOCATION FAILS FOR QL,QN,DEY'
            NF=0
            GO TO 200
          ENDIF
!
        ENDIF
!
        IF(MA.GT.1)THEN
          WRITE(MW6,10020)MA
          WRITE(MW0,*)                                                  &
     &          '*** SR.CONFG0: CLOSED SHELLS MUST BE ORBITALS 1,2,3...'
          GO TO 300
        ENDIF
!
        I0=ABS(MB)+1           !SO ALL CLOSED MUST BE BEFORE ALL OPEN
!
        IF(MB.LE.0)THEN
          KS=0
        ELSE
          KS=MB
        ENDIF
!
        IF(MXVORB.GT.0)THEN                           !REDEFINE, MAYBE
          READ(MR5,*)(QN(I),QL(I),I=KS+1,MXORB)
          DO I=KS+1,MXORB
            IF(QN(I).LT.1.OR.QL(I).LT.0.OR.QL(I).GE.QN(I).AND.          &
     &         qn(i).le.i69)THEN
              WRITE(MW6,10110)I,QN(I),QL(I)
              WRITE(MW0,*)'*** SR.CONFG0: ILLEGAL NL COMBINATION!'
              GO TO 300
            ENDIF
          ENDDO
        ELSE                                           !STANDARD ORDER
          MXVORB=-MXVORB
          II=INT(SQRT(DTWO*MXORB),SP)+1
          K=0
          DO I=1,II
            DO L=1,I
              K=K+1
              IF(K.LE.MXORB)THEN
                QN(K)=INT(I,QP)
                QL(K)=INT(L-1,QP)
              ENDIF
            ENDDO
          ENDDO
        ENDIF
!
! SET-UP DEFAULT PARTIAL WAVE EXPANSION FOR PROBLEM
!
        allocate(ival0(0:mxorb))
        ival0=0
        IF(LCON.lt.0.or.lcon0.lt.0)THEN
          IF(RUN.NE.'  '.OR.MXCCF.GT.0)then
            LC=0
            LC=MAX(LC,LXTRA)
            LC0=0
            LCONT=LCON
            LCONT0=LCON0
            DO I=I0,MXORB
              IF(QN(I).LT.80)then
                LC=MAX(LC,INT(QL(I),SP))
              elseif(qn(i).lt.90)then            !flag core re-arrange
                lc0=-1
                if(.not.bdr)ival0(i)=1
              else                        !flag user continuum present
                lc=-1
              endif
            ENDDO
            if(lc.ge.0)then
              if(bfot)then
                if(bdr)then
                  if(lcon0.lt.0.and.lc0.lt.0)lcon0=lc+2
                  if(lcmin.lt.0.and.kpol0.ge.lmax)lcmin=kpol0-lmax
                  if(lcon.lt.0)then
                    lcon=kpole+1
                    lcon=lcon+min(lmax,kpole)
                    if(lcmin.gt.0)lcon=lcon-lcmin
                  endif
                else
                  if(lcmin.lt.0.and.kpol0.ge.lc)lcmin=kpol0-lc
                  if(lcon.lt.0.and.kpole.gt.0)then
                    lcon=lc+kpole+1
                    if(lcmin.gt.0)lcon=lcon-lcmin   !l=lcmin,...lcon-1
                  endif
                endif
              else
                LC=2*LC+1                   !AS QL=L HERE, NOT 2*L YET
                if(bdr)then
                  lc=min(5_SP,lc)
                  if(abs(MODD).le.1)lc=max(5_SP,lc)
                  if(lcon0.lt.0.and.lc0.lt.0)lcon0=min(lc,3_SP)  !s-hole
                endif
                if(lcon.lt.0)lcon=lc
              endif
            endif
            IF((RUN.NE.'  '.OR.MXCCF.GT.0).AND.LC.GE.0.AND.IDW.EQ.0)THEN
              IF(LCONT.LT.0)WRITE(MW6,10050)LCON
              IF(LCONT0.LT.0.AND.LC0.LT.0)WRITE(MW6,10010)LCON0
            ENDIF
            LCONT=LCON
          else                 !still need to flag core re-arrangement
            do i=i0,mxorb
              if(qn(i).ge.80.and.qn(i).lt.90.and..not.bdr)ival0(i)=1
            enddo
          endif
          ival0(0)=sum(ival0)
        ENDIF
!
! EXTEND USER SPECIFIED ORBITAL SET
!   needs standard ordering, wrt to mxorbr.
!   ignores any external orbital flag.
!   all extended are flagged as internal.
!
        MXORBR=MXORB
        IF(NXTRA.GT.0.AND.ICFG.NE.0)THEN                        !FILL-IN
!
          QNX=QN(MXORBR)
          qnx=mod(qnx,q70)                    !for external orbital flag
          QLX=QL(MXORBR)
!
          IF(LXTRA.LT.0)LXTRA=QLX
!
          do i=i0,mxorbr                           !i=1 -> i=i0
            qni=qn(i)
            qni=mod(qni,q70)
            if(qni.gt.qnx)then                     !nxtra will duplicate
              write(mw6,10130)i,qni,qnx,i,mxorbr
              go to 300
            elseif(qni.eq.qnx)then
              if(ql(i).gt.qlx)then                 !lxtra will duplicate
                write(mw6,10140)i,ql(i),qlx,i,mxorbr
                go to 300
              endif
            endif
          enddo
!
   20     K=MXORB
          MNT=IAXGR
          IMX=MIN(LXTRA,INT(QNX-1,SP))
          DO I=QLX+1,IMX                     !COMPLETE SUBSHELL
            K=K+1
            IF(K.LE.MNT)THEN
              QN(K)=QNX
              QL(K)=INT(I,QP)
            ENDIF
          ENDDO
!
          DO N=QNX+1,NXTRA
            LMX=MIN(LXTRA,N-1)
            DO L=0,LMX
              K=K+1
              IF(K.LE.MNT)THEN
                QN(K)=INT(N,QP)
                QL(K)=INT(L,QP)
              ENDIF
            ENDDO
          ENDDO
!
          IF(K.GT.IAXGR)THEN
!
            WRITE(MW6,*)'*** CONFG0: increasing MAXGR from ',IAXGR,     &
     &                  ' to: ',K
            WRITE(MW0,*)'*** CONFG0: increasing MAXGR from ',IAXGR,     &
     &                  ' to: ',K
!
            IAXGR=K
!
            DEALLOCATE(NEL)
            ALLOCATE(NEL(IAXGR,IAXCF),STAT=IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'SR.CONFG0: ALLOCATION FAILS FOR NEL'
              NF=0
              GO TO 200
            ENDIF
!
            DEALLOCATE(IEQ,IGRCF)
            ALLOCATE(IEQ(0:IAXGR),IGRCF(IAXGR),STAT=IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'SR.CONFG0: ALLOCATION FAILS FOR IEQ,IGRCF'
              NF=0
              GO TO 200
            ENDIF
!
            CALL RE_ALLOC(QL,IONE,MXORB,IAXGR,IERR)
            CALL RE_ALLOC(QN,IONE,MXORB,IAXGR,IERR)
            CALL RE_ALLOC(DEY,IONE,MXORB,IAXGR,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'SR.CONFG0: RE-ALLOCATION FAILS FOR QL,QN,DEY'
              NF=0
              GO TO 200
            ENDIF
!
            GO TO 20
!
          ENDIF
!
          MXORB=K
!
        ENDIF
!
      ELSEif(icfg.ge.0)then
        WRITE(MW0,*)                                                    &
     &           'INPUT MXVORB IN NAMELIST SALGEB MUST BE SET .NE. ZERO'
        GO TO 300
      ENDIF
!
! READ CONFIGURATION INPUT.
!
      IF(MXCONF.GT.0.OR.ICFG.LT.0)THEN
!
        iflagcf=0
! user flags split target for cont/ryd
! (need to sync with run_PP if increase 1000 to 10000, say)
        if(run.ne.'  '.and.mxconf.ge.1000)then
          mc1=mxconf/1000                     !cont on these only
          mc2=mxconf-1000*mc1                 !addtional Ryd only
          mxconf=mc1+mc2                      !tot target cfs to read
          if(icfg.gt.0)then
            iflagcf=mxconf                    !cannot promote
          endif
        else
          mc1=999999999                       !all
          mc2=0
        endif
!
        CALL CONFG(ICFG,MB,MXORBR,MXORB,MXCONF,MXCCF,IFILL,ival0)
!
        IF(NF.LE.0)GO TO 200                                   !RETURN
!
        btest1=iflagcf*(mxconf-mxccf).gt.iflagcf*iflagcf
        btest2=iflagcf*(mxconf-mxccf).lt.iflagcf*iflagcf
        if(btest1.or.btest2.and.ival0(0).eq.0)then
          write(mw6,*)                                                  &
     &             'sr.confg0: cannot mix ICFG gt 0 with MXCONF ge 1000'
          write(mw0,*)                                                  &
     &             'sr.confg0: cannot mix ICFG gt 0 with MXCONF ge 1000'
          go to 300
        endif
!
        IF(MXCONF.GT.MAXCF)THEN
          IF(MAXCF.GT.0)WRITE(MW6,10030)MAXCF,MXCONF
        ENDIF
!
        IF(MXCONF.GT.IAXCF)THEN          !TOO LATE TO SALVAGE BUFFER ETC
          WRITE(MW6,10040)MXCONF           !SHOULD NOT HAPPEN NOW
          WRITE(MW0,*)'*** INCREASE BUFFER IAXCF IN SR.ALGEB0'
          GO TO 300
        ENDIF
!
        IF(IDW.NE.0)THEN
          MXCONF=MXCONF-MXCCF
          MXCCF=0
        ENDIF
!
! SEE IF WE CAN REDUCE MXORB, CASE USER DEFINES MORE ORBITALS THAN USED.
! N.B.WE DO NOT ATTEMPT TO REMOVE UNUSED ORBITALS WHICH LIE AMIDST USED.
!
        MXORB0=MXORB
        MXORB=0
        I0=ABS(MB)+1           !SO ALL CLOSED MUST BE BEFORE ALL OPEN
        MMAX=MXCONF-MXCCF
        DO M=1,MMAX
          DO I=MXORB0,I0,-1
            IF(NEL(I,M).GT.0)THEN
              MXORB=MAX(MXORB,I)
              GO TO 50
            ENDIF
          ENDDO
   50   ENDDO
! AS NOT YET MOVED BACK N+1...
        IF(MXCCF.GT.0)THEN
          M0=IAXCF+1
          DO K=MXCCF,1,-1
            M=M0-K
            DO I=MXORB0,I0,-1
              IF(NEL(I,M).GT.0)THEN
                MXORB=MAX(MXORB,I)
                GO TO 60
              ENDIF
            ENDDO
   60     ENDDO
        ENDIF
!
        MXORB=MAX(MXORB,ISCALR)      !FOR SLATER SCALING DUMMY ORB
!
        IF(MXORB.LT.MXORB0)THEN
          WRITE(MW6,*)'SR.CONFG0: REDUCING NUMBER OF USER ORBITALS FROM'&
     &                ,MXORB0,' TO',MXORB
          WRITE(MW0,*)'SR.CONFG0: REDUCING NUMBER OF USER ORBITALS FROM'&
     &                ,MXORB0,' TO',MXORB
        ENDIF
!
! SET-UP N+1 PROBLEM, FOR TARGET SEPCIFIED
!
        IF(RUN.NE.'  '.OR.MXCCF.GT.0)THEN
          IVAL=0                     !ASSUME SINGLE RYD ORBITAL
          ISUM=0
          DO I=I0,MXORB              !I=1 -> I=I0
            IF(QN(I).GE.90)THEN      !CONT ORB ALREADY SET, ASSUME N+1
              IF(MXCCF.GT.0)THEN     !MOVE N+1 CFGS BACK
                M0=IAXCF+1
                KMAX=MXCONF-MXCCF
                DO K=MXCCF,1,-1
                  KMAX=KMAX+1
                  M=M0-K
                  ICFGP(KMAX)=ICFGP(M)
!          write(mw0,*)kmax,m,'*',(NEL(i,m),i=i0,mxorb)
                  DO II=I0,MXORB
                    NEL(II,KMAX)=NEL(II,M)
                    IF(NEL(II,M).GT.0.AND.QN(II).GE.80)THEN
                      WRITE(MW6,*)                                      &
     &               '***CONFG0 ERROR: RYD/CONT ORB FOUND IN MXCCF CFGS'
                      WRITE(MW0,*)                                      &
     &               '***CONFG0 ERROR: RYD/CONT ORB FOUND IN MXCCF CFGS'
                      GO TO 300
                    ENDIF
                  ENDDO
                ENDDO
              ENDIF
              GO TO 100
            ENDIF
            IF(QN(I).GE.80.AND.LCON0.NE.0)THEN      !CORE RE-ARRANGEMENT
              IVAL=I
              ISUM=ISUM+1
            ENDIF
          ENDDO
!
          IF(LCON.EQ.0.AND.LCON0.EQ.0)GO TO 100       !NO IMPLICIT CONT
!
          KT=MXCONF-MXCCF           !NO OF TARGET CFGS
          JVAL=0
          IF(IVAL.GT.0)THEN !SPECIFY RYD IN TARGET FOR CORE RE-ARRANGE
!
            IF(.NOT.BDR)THEN  !PRESENT IN ORB LIST BUT NOT CFGS NOW
              WRITE(MW6,*)'***CONFG0 NOTE: RUN NOT SET FOR RYD ORBS'
              IF(MOD(ICFG,ITEN).EQ.0)THEN
                WRITE(MW0,*)'***CONFG0 NOTE: RUN NOT SET FOR RYD ORBS'
                WRITE(MW6,*)'***USE MOD(ICFG,10).GT.0 TO DROP'
                WRITE(MW0,*)'***USE MOD(ICFG,10).GT.0 TO DROP'
                GO TO 300
              ENDIF
            ENDIF
            IF(ISUM.GT.1)THEN
              WRITE(MW6,*)                                              &
     &                   '***CONFG0 ERROR: CAN ONLY SET ONE RYDBERG ORB'
              WRITE(MW0,*)                                              &
     &                   '***CONFG0 ERROR: CAN ONLY SET ONE RYDBERG ORB'
              GO TO 300
            ENDIF
            IF(IVAL.NE.MXORB)THEN
              WRITE(MW6,*)                                              &
     &                   '***CONFG0 ERROR: RYDBERG ORB MUST BE LAST SET'
              WRITE(MW0,*)                                              &
     &                   '***CONFG0 ERROR: RYDBERG ORB MUST BE LAST SET'
              GO TO 300
            ENDIF
            IF(BDR)THEN
              IVAL=1
            ELSE
              IVAL=0
            ENDIF
!
            K0=KT
            DO K=KT,1,-1     !SEE WHICH TARGET CONFIGS TO SKIP RYD
              IF(NEL(MXORB,K).NE.0)THEN
                JVAL=JVAL+1
                K0=K-1
              ENDIF
            ENDDO
!
            IF(JVAL.EQ.0)THEN   !GET USER TO RESET INCASE IN N+1
              WRITE(MW6,*)                                              &
     &                  '***CONFG0 NOTE: RYD ORB NOT USED, COULD REMOVE'
!           WRITE(MW0,*)'***CONFG0 NOTE: RYD ORB NOT USED, COULD REMOVE'
!              GO TO 999        !NOW CHECKED CFGS EXPLICITLY ABOVE
            ENDIF
            IF(KT-JVAL.NE.K0)THEN
              WRITE(MW6,*)                                              &
     &                   '***CONFG0 ERROR: MUST LIST RYD TARG CFGS LAST'
              WRITE(MW0,*)                                              &
     &                   '***CONFG0 ERROR: MUST LIST RYD TARG CFGS LAST'
              GO TO 300
            ENDIF
!
          ENDIF
!
          IRYD=0
          IF(BDR)IRYD=1     !FLAG SPACE FOR RYDBERG CFGS (NON-CORE)
          IF(LCON.LT.0)THEN
            LCON=3
            WRITE(MW6,10050)LCON
          ENDIF
          IF(JVAL.GT.0)THEN
            IF(LCON0.LT.0)THEN
              LCON0=3
              WRITE(MW6,10010)LCON0
            ENDIF
          ELSE
            LCON0=0
          ENDIF
!
! NEW MXCONF
          if(mc2.eq.0)then
            IYYY=(KT-JVAL)*(LCON+IRYD)+JVAL*LCON0+MXCCF
          else
            IYYY=mc1*LCON+(KT-JVAL)*IRYD+JVAL*LCON0+MXCCF
          endif
!
          IF(IYYY.GT.MAXCF)THEN
            IF(MAXCF.GT.0)WRITE(MW6,10030)MAXCF,IYYY
          ENDIF
!
! NEW MXORB
          I8TY=IRYD-IVAL
          IXXX=MXORB+LCON+LCON0+I8TY
!
! MAY INCREASE ALLOC
          IF(IXXX.GT.IAXGR.OR.IYYY.GT.IAXCF)THEN
!
            IXX1=MAX(IXXX,IAXGR)              !BUT DO NOT REDUCE "OTHER"
            IYY1=MAX(IYYY,IAXCF)              !BUT DO NOT REDUCE "OTHER"
!
            CALL RE_ALLOC2(NEL,IONE,MXORB,IONE,IAXCF,IXX1,IYY1,IERR)
!                                               N+1
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'SR.CONFG0: RE-ALLOCATION FAILS FOR NEL'
              NF=0
              GO TO 300
            ENDIF
!
            IF(IYYY.GT.IAXCF)THEN             !REPOSITION N+1
!
              WRITE(MW6,*)'*** CONFG0: increasing MAXCF from ',IAXCF,   &
     &                    ' to: ',IYYY
              WRITE(MW0,*)'*** CONFG0: increasing MAXCF from ',IAXCF,   &
     &                    ' to: ',IYYY
!
              CALL RE_ALLOC(ICFGP,IONE,IAXCF,IYYY,IERR)
!                                       N+1
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)'SR.CONFG0: RE-ALLOCATION FAILS FOR ICFGP'
                NF=0
                GO TO 300
              ENDIF
!
              M=IYYY+1
              N=IAXCF+1
              DO J=1,MXCCF
                M=M-1
                N=N-1
                ICFGP(M)=ICFGP(N)
                DO I=I0,MXORB
                  NEL(I,M)=NEL(I,N)
                ENDDO
              ENDDO
!
              IAXCF=IYYY
!
            ENDIF
!
            IF(IXXX.GT.IAXGR)THEN
!
              WRITE(MW6,*)'*** CONFG0: increasing MAXGR from ',IAXGR,   &
     &                    ' to: ',IXXX
              WRITE(MW0,*)'*** CONFG0: increasing MAXGR from ',IAXGR,   &
     &                    ' to: ',IXXX
!
              CALL RE_ALLOC(IEQ,IZERO,MXORB,IXXX,IERR)
              CALL RE_ALLOC(IGRCF,IONE,MXORB,IXXX,IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)                                            &
     &                    'SR.CONFG0: RE-ALLOCATION FAILS FOR IEQ,IGRCF'
                NF=0
                GO TO 300
              ENDIF
!
              CALL RE_ALLOC(QL,IONE,MXORB,IXXX,IERR)
              CALL RE_ALLOC(QN,IONE,MXORB,IXXX,IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)'SR.CONFG0: RE-ALLOCATION FAILS FOR QN, QL'
                NF=0
                GO TO 300
              ENDIF
!
              IAXGR=IXXX
!
            ENDIF
!
          ENDIF
!
          MXCONF=IYYY                         !.LE. IAXCF
!
          IF(I8TY.GT.0)THEN
            MXORB=MXORB+I8TY
            QN(MXORB)=Q80
            QL(MXORB)=INT(LCON/2,QP)
          ENDIF
!
          KMAX=MXCONF-MXCCF                   !NO OF CONT + RYD CFGS
          KK=KMAX
          LLL=LCON+LCON0
          DO K=KT,1,-1
            IF(IVAL.GT.0.AND.NEL(MXORB,K).NE.0)THEN
              KK=KK-LCON0
              DO L=1,LCON0
                KK=KK+1
                ICFGP(KK)=ICFGP(K)
                DO I=I0,MXORB
                  NEL(I,KK)=NEL(I,K)
                ENDDO
                DO LL=1,LLL
                  NEL(MXORB+LL,KK)=0
                ENDDO
                NEL(MXORB+LCON+L,KK)=1
              ENDDO
              KK=KK-LCON0
            ELSE
              IF(I8TY.GT.0)NEL(MXORB,K)=0
!              KK=(K-1)*LCON+IRYD*KT
              if(k.le.mc1)then
                KK=KK-LCON
                DO L=1,LCON
                  KK=KK+1
                  ICFGP(KK)=ICFGP(K)
                  DO I=I0,MXORB
                    NEL(I,KK)=NEL(I,K)
                  ENDDO
                  DO LL=1,LLL
                    NEL(MXORB+LL,KK)=0
                  ENDDO
                  NEL(MXORB+L,KK)=1
                ENDDO
                KK=KK-LCON
              endif
              IF(IRYD.GT.0)THEN
                NEL(MXORB,K)=NEL(MXORB,K)+IRYD
                DO LL=1,LLL
                  NEL(MXORB+LL,K)=0
                ENDDO
              ENDIF
            ENDIF
          ENDDO
!
! PROCESS ANY N+1 CFGS
!
          IF((RUN.EQ.'PI'.OR.RUN.EQ.'DR'.OR.RUN.EQ.'YLD').AND.          &
     &       MXCCF.EQ.0)THEN
            WRITE(MW6,10060)RUN
            IF(RUN.EQ.'PI'.OR.RUN.EQ.'YLD')THEN
              IF(MXCCF0.EQ.-999)THEN                   !USER DID NOT SET
                WRITE(MW0,*)                                            &
     &              'PI/YLD ERROR: NO INITIAL N+1 BOUND CFGS SPECIFIED!'
                GO TO 300
              ELSE                !ALLOW "DEBUG" OF TARGET+CONT ENERGIES
                WRITE(MW0,*)                                            &
     &            'PI/YLD WARNING: NO INITIAL N+1 BOUND CFGS SPECIFIED!'
              ENDIF
            ELSE
              WRITE(MW0,*)'DR/PE WARNING: NO N+1 BOUND CFGS SPECIFIED!'
            ENDIF
          ENDIF
!
          IF(MXCCF.GT.0)THEN             !MOVE N+1 CFGS BACK
            M0=IAXCF+1
            I2=MXORB-I8TY
            I1=LCON+LCON0+I8TY
            DO K=MXCCF,1,-1
              KMAX=KMAX+1
              M=M0-K
              ICFGP(KMAX)=ICFGP(M)
!          write(mw0,*)kmax,m,'*',(NEL(i,m),i=i0,mxorb)
              DO I=I0,I2
                NEL(I,KMAX)=NEL(I,M)
              ENDDO
              DO I=1,I1
                NEL(I2+I,KMAX)=0
              ENDDO
            ENDDO
          ENDIF
!
! INITIALIZE ORBITALS (DUMMY IF BDR)
!
          LM=-1
          IF(LCMIN.GT.0)LM=LM+LCMIN
          DO L=1,LCON
            QN(MXORB+L)=Q90
            QL(MXORB+L)=INT(L+LM,QP)
          ENDDO
          MXORB=MXORB+LCON
          DO L=1,LCON0
            QN(MXORB+L)=Q99
            QL(MXORB+L)=INT(L-1,QP)
          ENDDO
          MXORB=MXORB+LCON0
          MXVORB=MXORB-I0+1
          LCONT=LCON
!
!
! NOW BUBBLE SORT TO SEPARATE SPECTROSCOPIC AND CORRELATION.
! IN THIS INSTANCE USER INPUT KCUT/P REFER TO KT TARGET CFS AS
! USER DOES NOT KNOW NO. OF N+1 CFS RESULTANT, SO KCUT AND
! KCUTP SHOULD BE THE SAME, IF NOT TAKE KCUTP.
! USE KCUTCC TO SPECIFY SUBSET OF THE MXCCF N+1 BOUND CFGS
! THIS IS RELATIVE TO MXCFF ONLY AND IS INDEPENDENT OF KCUT/P.
!
          IF(KCUT+KCUTP+KCUTCC.GT.0)THEN
!
            IF(KCUTP.GT.0.AND.KCUTP.NE.KCUT)THEN
              IF(KCUT.GT.0)THEN
                WRITE(MW0,*)'***ATTENTION, USING KCUTP TO DEFINE TARGET'
                WRITE(MW6,*)'***ATTENTION, USING KCUTP TO DEFINE TARGET'
              ENDIF
              KCUT=KCUTP
            ENDIF
!
            IF(KCUTCC.EQ.0)KCUTCC=MXCCF
!                   KCUTI=KCUT0
            IF(KCUT+KCUT0.EQ.0)THEN      !NO RE-ORDER, JUST RESET KCUT
              KCUTP=MXCONF-MXCCF+KCUTCC
            ELSE                           !LABEL FOR SORTING
              if(mc2.gt.0)then
                write(mw6,*)' confg0: currently, cannot set kcut when ',&
     &                      'using different target cfs for cont & Ryd'
                write(mw0,*)' confg0: currently, cannot set kcut when ',&
     &                      'using different target cfs for cont & Ryd'
                go to 300
              endif
!
              ALLOCATE(KORDER(MXCONF))
!
              IF(KCUT.GT.0)KCUT=MIN(KCUT,KT)
              IF(KCUT0.EQ.0)KCUT0=JVAL     !KCUTI=KCUT0
              KMAX=(KT-JVAL)*(LCON+IRYD)
              KCUTP=0
              IF(BDR)THEN
                KA=1
                KB=KCUT
                DO K=KA,KB
                  KORDER(K)=1              !RYD SPECTROSCOPIC
                ENDDO
                KCUTP=KCUTP+KB-KA+1
                KA=KB+1
                KB=KT-JVAL
                DO K=KA,KB
                  KORDER(K)=5              !RYD CORRELATION
                ENDDO
              ELSE
                KB=0
              ENDIF
              KA=KB+1
              KB=KB+KCUT*LCON
              DO K=KA,KB
                KORDER(K)=2                !CONT SPECTROSCOPIC
              ENDDO
              KCUTP=KCUTP+KB-KA+1
              KA=KB+1
              KB=KMAX
              DO K=KA,KB
                KORDER(K)=6                !CONT CORRELATION
              ENDDO
              KA=KB+1
              KB=KB+KCUT0*LCON0            !KCUTI=KCUT0
              DO K=KA,KB
                KORDER(K)=3                !CORE CONT SPECTROSCOPIC
              ENDDO
              KCUTP=KCUTP+KB-KA+1
              KA=KB+1
              KB=KMAX+JVAL*LCON0
              DO K=KA,KB
                KORDER(K)=7                !CORE CONT CORRELATION
              ENDDO
              KA=KB+1
              KB=KB+KCUTCC
              DO K=KA,KB
                KORDER(K)=4                !N+1 SPECTROSCOPIC
              ENDDO
              KCUTP=KCUTP+KB-KA+1
              KA=KB+1
              KB=MXCONF
              DO K=KA,KB
                KORDER(K)=8                !N+1 CORRELATION
              ENDDO
!
!              do i=1,mxconf
!                write(mw6,*)i,korder(i)
!              enddo
! BEGIN SORT
              DO I=1,MXCONF
                K=I
                IP=KORDER(K)
                DO J=I+1,MXCONF
                  IF(KORDER(J).LT.IP)THEN
                    K=J
                    IP=KORDER(J)
                  ENDIF
                ENDDO
                IF(K.NE.I)THEN
                  KORDER(K)=KORDER(I)
                  KORDER(I)=IP
                  II=ICFGP(I)
                  ICFGP(I)=ICFGP(K)
                  ICFGP(K)=II
                  DO J=I0,MXORB
                    IP=NEL(J,I)
                    NEL(J,I)=NEL(J,K)
                    NEL(J,K)=IP
                  ENDDO
                ENDIF
              ENDDO
!
              DEALLOCATE(KORDER)
!
            ENDIF
            KCUT=KCUTP
          ENDIF
!
! END ANY N+1 SET-UP
!
        ENDIF
!
  100   CONTINUE
!
! WRITE CF OUTPUT IN CONFIG.DAT FORMAT
!
        WRITE(MW6,10090)MXCONF,MXORB
        WRITE(MW6,10100)(QN(I),QL(I),I=I0,MXORB)
        IGROUP=0
        DO K=1,MXCONF
          IF(IGROUP.NE.ICFGP(K))THEN                   !IEQ(0).GT.0
            IGROUP=ICFGP(K)
            WRITE(MW6,10070)IGROUP
          ENDIF
          WRITE(MW6,10080)K,(NEL(I,K),I=I0,MXORB)
!          do i=i0,mxorb                   !algeb0 check, remove evently
!            if(NEL(i,k).lt.0)then                          !not defined
!              write(mw6,*)'*** Bug, orbital not defined,setting =0'
!              write(mw0,*)'*** Bug, orbital not defined,setting =0',k,i
!              NEL(i,k)=0
!            endif
!          enddo
          IF(KCUT.GT.0.AND.K.EQ.KCUT)WRITE(MW6,*)
        ENDDO
        WRITE(MW6,10120)
!
! CHECK CFS
!
        CALL DIMUSE('MAXCF',MXCONF)
        CALL DIMUSE('MAXGR',MXORB)
!
        KMAX=MXCONF                             !FINAL TOTAL CF FOR MQVC
!
        DO J=1,KMAX
!
!old          READ(MR5,*)(NEL(I,J),I=I0,MXORB)
!
          DO L=1,J-1
            DO I=I0,MXORB
              IF(NEL(I,L).NE.NEL(I,J))GO TO 120
            ENDDO
!
            WRITE(MW6,*)
            WRITE(MW6,*)'***SR.CONFG0: CONFIGURATIONS',L,' AND',J,      &
     &                  ' ARE IDENTICAL!'
            WRITE(MW0,*)'SR.CONFG0: DUPLICATE CONFIGURATIONS PRESENT!'
            GO TO 300                             !RETURN
  120     ENDDO
!
        ENDDO
!
      ELSE
        WRITE(MW0,*)                                                    &
     &   'SR.CONFG: INPUT MXCONF IN NAMELIST SALGEB MUST BE SET GT ZERO'
        GO TO 300                                 !RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
  200 CONTINUE
!
      if(allocated(ival0))deallocate(ival0)
!
      RETURN
!
!-----------------------------------------------------------------------
!
  300 NF=-1
      GO TO 200
!
!-----------------------------------------------------------------------
!
10010 FORMAT('***ATTENTION: LCON0 RE-SET TO',I5)
10020 FORMAT(' A.S. CODE REQUIRES KCOR1=1 (OR 0), REDEFINE ORBITALS SO',&
     &       ' THAT CLOSED SHELLS ARE 1,2,3 ETC. CURRENTLY KCOR1=',I2)
10030 FORMAT(' SR.CONFG0: ALLOCATION INCREASES STORAGE FROM MAXCF=',I7, &
     &       ' TO IAXCF=',I7,' CONFIGURATIONS')
10040 FORMAT(' INCREASE BUFFER IAXCF IN SR.ALGEB0 TO AT LEAST',I6)
10050 FORMAT('***ATTENTION: LCON  RE-SET TO',I5)
10060 FORMAT('*** ATTENTION: RUN=',A4,                                  &
     &       ' BUT NO N+1 BOUND CFGS SPECIFIED'/                        &
     & ' SET MXCCF.GT.0 TO SPECIFY AS FOR N CFGS, OR .LT.0 FOR INTERNAL'&
     & ,' GENERATION - REQUIRES ICFG.NE.0'/)
10070 FORMAT(I2,'::')
10080 FORMAT(I4,':',(60I2))
10090 FORMAT(/2I5)
10100 FORMAT(30(I3,I2))
10110 FORMAT(/'*** ILLEGAL NL COMBINATION FOR ORBITAL',I3,' N L =',2I4)
10120 FORMAT(//1X,138('-')//)
10130 FORMAT(/'*** ERROR: ORBITAL',I3,' HAS AN N-VALUE',I3,', LARGER',  &
     &       ' THAN THE LAST USER-SPECIFIED ONE',I3/4X,                 &
     &       'NXTRA WILL DUPLICATE',', SO RE-ORDER TO MAKE ORBITAL',I3, &
     &       ' ORBITAL',I3)
10140 FORMAT(/'*** ERROR: ORBITAL',I3,' HAS AN L-VALUE',I3,', LARGER',  &
     &       ' THAN THE LAST USER-SPECIFIED ONE',I3/4X,                 &
     &       'LXTRA WILL DUPLICATE',', SO RE-ORDER TO MAKE ORBITAL',I3, &
     &       ' ORBITAL',I3)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE CONFG0
!
!                             *******************
!
      SUBROUTINE CONFG1
!
!-----------------------------------------------------------------------
!
!  SR.CONFG1:
!    FOR 'S.S.' INPUT, DECODES THE KMAX INPUT CONFIGURATIONS FROM THE
!    INPUT IN IWRK1+IWRK2, PREVIOUSLY LOADED IN ALGEB0.
!    FOR 'A.S.' INPUT, MAINLY CHECK AND INITIALIZE.
!    OPTIONALLY, SET-UP FOR RELAXED ORBITALS (BOTH)
!
!  IT IS CALLED BY:
!    SR.ALGEB0
!
!  IT CALLS:
!    SR.DIMUSE
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      USE COMMON_ALGEB,  ONLY: IWRK1,IWRK2
      USE COMMON_ALGEB,  ONLY: BFOT
!!      COMMON /BASIC/NF,KY,KG,JA,JB,MGAP(7)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,IBSK2=>IBSK2,KG=>IBSK3,IBSK4=>IBSK4,IBSK5=>IBSK5   &
     &              ,IBSK6=>IBSK6,IBSK7=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9&
     &              ,IBSK10=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_DBD2,   ONLY: QL,QN,DEY
      USE COMMON_MQVC,   ONLY: MODD,KCUT,KMAX,NEL
!
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL1, ONLY: ISCALR
      USE COMMON_NRBAL2, ONLY: MDEL,MXORBR,MPOL00,MPOL0,MPOLE,MPOLX,CODE
      USE COMMON_NRBAL3, ONLY: MCFSS,KCFSS,KUTSS,KUTSO,QQCUT
      USE COMMON_NRBAL4, ONLY: MBP1MX,MBP2MX,MEKVMX,KUTM1,MPOLM,QCUT
      USE COMMON_NRBDR,  ONLY: IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR
      USE COMMON_NRBDR,  ONLY: LNEW,LCON,LSUM,LMAX,lcmin,BLOOP
      USE COMMON_NRBDW,  ONLY: IDW,btop
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX                     &
     &                        ,MXBORB,MXVORB,MXFORB,NGRP
      USE COMMON_NRBRN2, ONLY: BINDB,MENGB
      USE COMMON_NRBVAL, ONLY: BRAD,BAUGER
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,QBUFF2
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (MXRED=90)                 !S.S. REDEFINED ORBITALS
      PARAMETER (MXLIT=60)                 !S.S. NO. ORBS CHAR DEFINED
      PARAMETER (MXLIT0=30)                !S.S. NO. ORB OCCUP. NOS
!
      CHARACTER(LEN=1) LIT0,LIT
!
      ALLOCATABLE :: ICHK(:)
!
      DIMENSION LIT(MXLIT),LIT0(MXLIT0)
!
      NAMELIST/SRADWIN/KEY
!
      DATA LIT0(1),LIT0(2),LIT0(3),LIT0(4),LIT0(5) /'0','1','2','3','4'/&
     &    ,LIT0(6),LIT0(7),LIT0(8),LIT0(9),LIT0(10)/'5','6','7','8','9'/&
     &,LIT0(11),LIT0(12),LIT0(13),LIT0(14),LIT0(15)/'A','B','C','D','E'/&
     &,LIT0(16),LIT0(17),LIT0(18),LIT0(19),LIT0(20)/'F','G','H','I','J'/&
     &,LIT0(21),LIT0(22),LIT0(23),LIT0(24),LIT0(25)/'K','L','M','N','O'/&
     &,LIT0(26),LIT0(27),LIT0(28),LIT0(29),LIT0(30)/'P','Q','R','S','T'/
!
      DATA LIT( 1),LIT( 2),LIT( 3),LIT( 4)  /'1','2','3','4'/,          &
     &     LIT( 5),LIT( 6),LIT( 7),LIT( 8)  /'5','6','7','8'/,          &
     &     LIT( 9),LIT(10),LIT(11),LIT(12)  /'9','A','B','C'/,          &
     &     LIT(13),LIT(14),LIT(15),LIT(16)  /'D','E','F','G'/,          &
     &     LIT(17),LIT(18),LIT(19),LIT(20)  /'H','I','J','K'/,          &
     &     LIT(21),LIT(22),LIT(23),LIT(24)  /'L','M','N','O'/,          &
     &     LIT(25),LIT(26),LIT(27),LIT(28)  /'P','Q','R','S'/,          &
     &     LIT(29),LIT(30),LIT(31),LIT(32)  /'T','U','V','W'/,          &
     &     LIT(33),LIT(34),LIT(35),LIT(36)  /'X','Y','Z','a'/,          &
     &     LIT(37),LIT(38),LIT(39),LIT(40)  /'b','c','d','e'/,          &
     &     LIT(41),LIT(42),LIT(43),LIT(44)  /'f','g','h','i'/,          &
     &     LIT(45),LIT(46),LIT(47),LIT(48)  /'j','k','l','m'/,          &
     &     LIT(49),LIT(50),LIT(51),LIT(52)  /'n','o','p','q'/,          &
     &     LIT(53),LIT(54),LIT(55),LIT(56)  /'r','s','t','u'/,          &
     &     LIT(57),LIT(58),LIT(59),LIT(60)  /'v','w','x','y'/
!
!-----------------------------------------------------------------------
!
!      IF(MA.NE.JA.OR.MB.NE.JB)STOP 'SR.CONFG1: CLOSED-SHELLS MIX-UP'
!
      LBLNK=ICHAR(' ')
!
      BDR=IDR.NE.0
      BCONTSS=CODE.EQ.'S.S.'.OR.lcmin.EQ.-999      !ASSIGN L_C BY PARITY
!
      BLF=.FALSE.
!
      ALLOCATE(ICHK(IAXCF))                        !CF OCC. CHECK
!
      IF(QQCUT.LE.0)THEN
        IF(QCUT.NE.LBLNK)THEN
          DO I=10,12
            IF(QCUT.EQ.ICHAR(LIT(I)))QQCUT=INT(I-8,QP)
          ENDDO
        ELSE
          QQCUT=1                    !DEFAULT ALL 2FS
        ENDIF
      ENDIF
!
! DEFINE GROUP INDICES K=1,2,..MAXGR FOR NL=1S,2S,2P...;
! K MAY HAVE BEEN REDEFINED THROUGH INPUT, SEE LOOP 31
!
! N.B. HISTORICALLY DEY HAS BEEN USED BOTH TO FLAG ORBITAL EXISTENCE
! IN BOTH THE ALGEB AND MINIM BRANCHES, AND TO HOLD THE TOTAL ONE-BODY
! ORBITAL ENERGY (DUY(K,K)+DE(K)) IN THE MINIM BRANCH. THIS IS NOT IDEAL
!
      MNT=IAXGR
      MNTL=MIN(MXLIT,MNT)
      II=INT(SQRT(DTWO*MNTL),SP)+1
      K=0
      DO I=1,II
        DO L=1,I
          K=K+1
          IF(K.GT.MNT)GO TO 100
!
          IF(CODE.EQ.'S.S.'.OR.K.LE.ABS(MB))THEN
            DEY(K)=DZERO
            IF(MB.GE.0)THEN
              QN(K)=INT(I,QP)
              QL(K)=INT(L-1,QP)
            ENDIF
            QL(K)=QL(K)*QTWO
          ENDIF
!
        ENDDO
      ENDDO
!
  100 MB=ABS(MB)                      !KCOR2 PASSED FROM ALGEB0
      MB1=MB+1
!
      IF(CODE.EQ.'S.S.')THEN
        BLT=.FALSE.
        NT=MIN(MXRED,IAXGR)
        MNT=NT
        M15=15
        K21=KG+18
  150   IF(IWRK1(K21).NE.LBLNK)THEN
          K21=K21+21
          M15=M15+15
          GO TO 150
        ENDIF
        MNT=MIN(MNT,M15)
      ELSE                             !CODE.EQ.'A.S.'
        BLT=.TRUE.
        MNT=MXORB
        DO K=MB1,MXORB
          DEY(K)=DZERO
          QL(K)=QL(K)*QTWO
        ENDDO
      ENDIF
!
      do i=1,mb
        if(qn(i).eq.qn(mb1).and.ql(i).eq.ql(mb1))then
          write(mw0,*)'SR.ALGEB:CLOSED SHELLS OVERLAP VALENCE!'
          go to 1000
        endif
      enddo
!
      IVAL=0
      L=999
!
      IF(BDR)THEN
!o        LCO=-1
        if(lcmin.ge.0)then                     !absolute
          ic=-lnew+lcmin-1
        else                                   !relative
          IC=(LCON-1)/2
          IF(IC.GT.LNEW.AND..NOT.BCONTSS)IC=LNEW         !new initialize
          IC=-IC-1
        endif
      ENDIF
!
      DO K=1,MNT
!
        IF(CODE.EQ.'S.S.')THEN                 !ORBITAL REDEF. LINE
          I=KG+K+2
          KX=(K-1)/15
          I=I+6*KX
          IF(IWRK2(I).EQ.0)GO TO 400
          QN(K)=INT(IWRK2(I),QP)
          DO M=1,30
            IF(IWRK1(I).EQ.ICHAR(LIT0(M)))THEN
              L=M-1
              GO TO 200
            ENDIF
          ENDDO
          GO TO 350
        ENDIF
!
  200   IF(.NOT.BDR)GO TO 250
        IF(.NOT.BLOOP)GO TO 250
        IF(QN(K).LT.80)GO TO 250
        IF(QN(K).EQ.99)GO TO 250
        IF(QN(K).LT.90)THEN              !RYDBERG
          IVAL=IVAL+1
          IF(IVAL.GT.1)WRITE(MW6,10150)
!
          L=LNEW
!          IF(NMIN.LT.L+1)NMIN=L+1        !BYPASSED BY RESTART, SO MINIM
          GO TO 300
        ENDIF
!                                        !CONTINUUM
!       if(l.eq.lco.and.bcontss)then      !cannot see use for lco
!         write(mw0,*)'confg1: l=lco...',l
!         go to 999
!       endif
!o   IF(L.NE.LCO.or..not.bcontss)    !FOR S.S. - why? lcon=2 still wrong
        IC=IC+1
!o        LCO=L
        L=LNEW+IC
        IF(L.LT.0)THEN                   !not poss with new initialize
          IP=LCON/2
          IP=IP+L
          IP=1-2*mod(abs(IP),ITWO)         !(-1)**IP
          IP=IP*(1-2*mod(abs(LNEW),ITWO))  !(-1)**LNEW
          IM=1-(1-2*mod(abs(LCON),ITWO))   !(-1)**LCON
          IM=IM/2
          IP=IP*IM
          L=L+LCON+IP
        ENDIF
        GO TO 300
!
  250   IF(CODE.EQ.'A.S.')GO TO 400      !BOUND ALREADY DEFINED
!
  300   QL(K)=INT(2*L,QP)
        BLT=.TRUE.
        IF(QN(K).GT.L)GO TO 400
!
  350   WRITE(MW6,10100)K,QN(K),IWRK1(I)
        BLF=.TRUE.
!
  400 ENDDO
!
! DECODE INPUT ARRAYS IWRK1 AND IWRK2 (ACCORDING TO GROUP DEFINITION)
! OF KMAX CONFIGURATIONS, EACH CONFIGURATION KF DEFINED BY THE NUMBER
! NEL(K,KF) OF EQUIVALENT ELECTRONS N,L=QN(K),QL(K)/2;
! DECODE CLOSED SHELL CONFIGURATION C0 (OF NW ELECTRONS) COMMON TO
! ALL KMAX CONFIGURATIONS (THIS FACILITY REDUCES STORAGE REQUIREMENTS)
!
!
      BLG=.FALSE.
!
      IF(CODE.EQ.'S.S.')THEN
!
        MXORB=0
        KMAX=0
        DO I=1,KG
          IF(IWRK1(I).EQ.LBLNK)GO TO 450
          M=IWRK2(I)
!
          DO K=1,MNTL
            IF(IWRK1(I).NE.ICHAR(LIT(K)))GO TO 420
            DEY(K)=DONE                         !FLAGS EXISTENCE
            MXORB=MAX(K,MXORB)
!
            IF(M.GT.50)THEN
              M=M-50
              IF(KMAX.GT.0)GO TO 410
            ENDIF
!
            KMAX=KMAX+1
!
            IF(KMAX.GT.IAXCF)THEN               !UNLIKELY FOR USER TYPED
! LEGACY CODE, JUST INCREASE IAXCF.
              WRITE(MW6,10090)IAXCF
              GO TO 1000
            ENDIF
!
            J1=MNTL
            IF(IEQ(0).NE.0)J1=IAXGR                    !RELAXED: ZEROIZE
            DO J=1,J1
              NEL(J,KMAX)=0
            ENDDO
            ICHK(KMAX)=0
!
  410       IF(K.LT.MA.OR.K.GT.MB)THEN
              L=NEL(K,KMAX)+M
              NEL(K,KMAX)=L
              ICHK(KMAX)=ICHK(KMAX)+M
              IF(L.GT.(QL(K)+1)*2)THEN
                WRITE(MW6,10130)L,QN(K),QL(K)/2,KMAX
                BLF=.TRUE.
              ENDIF
            ENDIF
            GO TO 450
!
  420     ENDDO
!
          J=(I-1)/21+1
          L=(I-(J-1)*21)*3+9
          IF(IAXGR.LE.MXLIT)THEN
            WRITE(MW6,10040)IWRK1(I),I,J,L,IAXGR
          ELSE
            WRITE(MW6,10050)IWRK1(I),I,J,L,MXLIT
          ENDIF
          BLF=.TRUE.
  450   ENDDO
!
        IF(KMAX.GT.MAXCF)THEN
          IF(MAXCF.GT.0)WRITE(MW6,10080)MAXCF,IAXCF
        ENDIF
!
        CALL DIMUSE('MAXCF',KMAX)
!
! DUPLICATE CONFGS WILL BE DROPPED QUIETLY OR FLAGGED, SEE IF(BLG) BELOW
!
        KMAX0=KMAX
        DO K0=2,KMAX0
          K=K0-KMAX0+KMAX
          DO L=1,K-1
            DO J=1,MNTL
              IF(NEL(J,L).NE.NEL(J,K))GO TO 460
            ENDDO
            BLG=.TRUE.
            WRITE(MW6,*)'*** DUPLICATE CONFIGURATIONS',L,' AND',K0
            DO I=K+1,KMAX                          !DROP, MAY STOP LATER
              DO J=1,MNTL
                NEL(J,I-1)=NEL(J,I)
              ENDDO
            ENDDO
            IF(K.LE.KCUT)KCUT=KCUT-1
            KMAX=KMAX-1
            GO TO 500
  460     ENDDO
  500   ENDDO
!
        IF(BLF)GO TO 1000
!
      ELSE                          !'A.S.'
!
        DO K=1,KMAX                 !SET IN CONFG0
!
          IRYD=0
          ICON=0
          ICHK(K)=0
          DO J=MB1,MXORB            !SET IN CONFG0
            IF(NEL(J,K).NE.0)THEN
              ICHK(K)=ICHK(K)+NEL(J,K)
              DEY(J)=DONE
              IF(QN(J).GE.80)THEN
                IF(QN(J).LE.89)THEN
                  IRYD=IRYD+NEL(J,K)
                ELSE
                  ICON=ICON+NEL(J,K)
                ENDIF
              ENDIF
            ENDIF
            IF(IRYD.GT.1.OR.ICON.GT.1)THEN
              IF(IEQ(0).NE.0)THEN
                WRITE(MW0,*)'*** ERROR SR.CONFG1: RELAXED ORBITALS'     &
     &    ,' CONFIG',K,' CAN HAVE AT MOST 1 RYDBERG AND/OR 1 CONTINUUM'
                WRITE(MW6,*)'*** ERROR S. CONFG1: RELAXED ORBITALS'     &
     &    ,' CONFIG',K,' CAN HAVE AT MOST 1 RYDBERG AND/OR 1 CONTINUUM'
                GO TO 1000
              ELSE
                IF(ICON.GT.1)THEN
                  WRITE(MW0,*)'*** ATTENTION SR,CONFG1: CONFIG',K,' HAS'&
     &      ,ICON,' CONTINUUM ORBITALS, DO YOU KNOW WHAT YOU ARE DOING?'
                  WRITE(MW6,*)'*** ATTENTION SR,CONFG1: CONFIG',K,' HAS'&
     &      ,ICON,' CONTINUUM ORBITALS, DO YOU KNOW WHAT YOU ARE DOING?'
                  ICON=0
                ENDIF
                IF(IRYD.GT.1)THEN
                  WRITE(MW0,*)'*** ATTENTION SR,CONFG1: CONFIG',K,' HAS'&
     &      ,IRYD,' RYDBERG ORBITALS, DO YOU KNOW WHAT YOU ARE DOING?'
                  WRITE(MW6,*)'*** ATTENTION SR,CONFG1: CONFIG',K,' HAS'&
     &      ,IRYD,' RYDBERG ORBITALS, DO YOU KNOW WHAT YOU ARE DOING?'
                  IRYD=0
                ENDIF
              ENDIF
            ENDIF
          ENDDO
!
          IF(IEQ(0).NE.0)THEN                   !RELAXED: ZEROIZE
            DO J=MXORB+1,IAXGR
              NEL(J,K)=0
            ENDDO
          ENDIF
!
        ENDDO
!
      ENDIF
!
      MXBORB=0
      MXVORB=0
!
      DO J=MB1,MXORB
        IF(QN(J).LT.80)MXBORB=MAX(J,MXBORB)
        IF(QN(J).LT.90)MXVORB=MAX(J,MXVORB)
      ENDDO
!
      IF(MXVORB.EQ.MXORB)BAUGER=.FALSE.                         !TIDY-UP
!
      IF(BFOT)THEN                !FOR PLANTING E_K POINTERS
        MXORBR=MXORB
      ELSE
        MXORBR=MXVORB
      ENDIF
!
      MXORBR=MXORBR-MB                                            !FLAGX
!
      MXORB=MAX(MXORB,ISCALR)     !FOR SLATER SCALING DUMMY ORB
!
      CALL DIMUSE('MAXGR',MXORB)
!
      IF(MENGB.GE.0)THEN          !I.E. BBORN
        IXGRB=MXORB-MB
!        IF(MA.GT.0)IXGRB=IXGRB+MA-1       !MA=1 FIXED
        IF(IXGRB.GT.MXGRB)THEN    !TOO MANY ORBS FOR BORN
          IF(MXGRB.GT.0)WRITE(MW6,*)                                    &
     &                   '***SR.CONFG1: ALLOCATION INCTREASES MXGRB TO '&
     &                   ,K
        ENDIF
        CALL DIMUSE('MXGRB',IXGRB)
      ENDIF
!
      DO K=1,MXORB        !INITIALIZE MAP
        IEQ(K)=K
      ENDDO
!
! SET-UP COMMON CORE OF CONFIGS
!
      IF(MB.GT.0)THEN
        IAXCL=0
        DO J=1,MB
          IAXCL=IAXCL+2*(QL(J)+1)
        ENDDO
      ELSE
        IAXCL=1                                       !FOR RESTART WRITE
      ENDIF
!
      ALLOCATE(NNL(IAXCL,3))
!
      NW=0
      MB=MB                                                         !MB0
      IF(MB.GT.0)THEN
        IF(MA.EQ.0)MA=1
        MA=MA                                                       !MA0
        DO J=MA,MB
          DEY(J)=DONE
          L=QL(J)
!
  520     I=NW+1
          NW=I+1
          IF(NW.GT.IAXCL)THEN            !DIMENSION EXCEEDED - SHOULDN'T
            WRITE(MW6,10120)IAXCL
            GO TO 1000
          ENDIF
          DO K=I,NW
            NNL(K,1)=J
            NNL(K,2)=L
            NNL(K,3)=(NW-K)*2-1
          ENDDO
          L=L-2
          IF(L.GE.-QL(J))GO TO 520
!
          DO I=1,KMAX
            NEL(J,I)=-2*(QL(J)+1)
          ENDDO
        ENDDO
!
        CALL DIMUSE('MAXCL',NW)
!
        WRITE(MW6,10010)NW,NF,KMAX,(QN(J),QL(J)/2,J=MA,MB)
      ELSE
        WRITE(MW6,10140)NF,KMAX
      ENDIF
!
      DO K=1,KMAX                         !CHECK CONFIGS CONSISTENT
        IF(ICHK(K).NE.NF)THEN           !DIFF NO. ELECTRONS...
          WRITE(MW6,10110)K,ICHK(K)
          WRITE(MW0,*)                                                  &
     &              '***SR.CONFG1: INCONSISTENT INPUT FOR CONFIGURATION'&
     &              ,K
          BLF=.TRUE.
        ENDIF
      ENDDO
!
! WRITE ORBITAL RE-DEFINITION INFO
!
      IF(BLT)THEN
!
        KPP=MNT
        K1=1
        K2=15
        IF(KPP.GT.K2)KPP=K2
        WRITE(MW6,10020)(K,K=K1,K2),(QN(K),QL(K)/2,K=K1,KPP)
!
  550   K1=K1+15
        IF(K1.LE.MNT)THEN
          K2=K2+15
          KPP=MNT
          IF(KPP.GT.K2)KPP=K2
          WRITE(MW6,10030)(K,K=K1,K2),(QN(K),QL(K)/2,K=K1,KPP)
          GO TO 550
        ENDIF
!
! CHECK ORBITALS, REMAP FOR NON-UNIQUE ORBITAL BASIS
!
        DO K=1,MXORB
          IF(DEY(K).NE.DZERO)THEN
            DO I=1,K-1
              IF(QN(K).EQ.QN(I).AND.QL(K).EQ.QL(I))THEN
!                IF(IEQ(0).EQ.0)IEQ(0)=1        !COMMENT-OUT FOR INEQUIV
                IF(IEQ(0).EQ.0)THEN
                  WRITE(MW6,10060)I,K,QN(I),QL(I)/2
                  WRITE(MW0,10060)I,K,QN(I),QL(I)/2
                ELSE
                  WRITE(MW6,10070)I,K,QN(I),QL(I)/2
!                  IEQ(K)=IEQ(I)     !REMAP EQUIVALENT ORBITALS (UNSAFE)
                ENDIF
!OLD                TEST BLF=.TRUE.
              ENDIF
            ENDDO
          ENDIF
        ENDDO
!
! CHECK FOR CLEMENTI "EXTERNAL" ORBITALS AND FLAG,
! THEN WE CANNOT EXTEND USAGE OF 60-69.
!
        IF(IUNIT(MR12).EQ.0)THEN
          DO K=1,MXORB
            IF(QN(K).GE.70.AND.QN(K).LE.79)THEN   !WE HAVE "EXTERNAL"
              KEY=0
              READ(MR5,SRADWIN,END=555)
  555         IF(KEY.EQ.-10)THEN                  !WE HAVE CLEMENTI
                IUNIT(MR12)=-1                    !FLAG
              ENDIF
              REWIND(MR5)                         !REPOSITION FOR SMINIM
              GO TO 600
            ENDIF
          ENDDO
        ENDIF
!
      ENDIF
!
  600 IF(BLF)GO TO 1000
!
! UN/COMMENT-OUT FOR QUIETLY DROPPING DUPLICATE CONFIGS
!
      IF(BLG)THEN
        WRITE(MW6,*)'***CHECK CONFIG INPUT,  DUPLICATE CONFIGS EXIST'
        WRITE(MW0,*)'***CHECK CONFIG INPUT,  DUPLICATE CONFIGS EXIST'
        GO TO 1000
      ENDIF
!      IF(BLG)WRITE(MW0,*) 'NOTE: DUPLICATE CONFIGS EXIST...'
!
! CHECK COLLISION CASE FOR MISTAKEN USER SETTING OF RYDBERG/CONTINUUM
!
      IF(IDW.NE.0)THEN
        DO I=1,MXORB
          IF(QN(I).GE.90)THEN
            WRITE(MW6,*)"***CONFG1 ERROR: USER MUST NOT SET CONTINUUM", &
     &                 " ORBITALS FOR RUN='DE','DI', LET THE CODE DO IT"
            WRITE(MW0,*)"***CONFG1 ERROR: USER MUST NOT SET CONTINUUM", &
     &                 " ORBITALS FOR RUN='DE','DI', LET THE CODE DO IT"
            GO TO 1000
          ENDIF
          IF(QN(I).GE.80)THEN
            WRITE(MW6,*)"***CONFG1 ERROR: CANNOT USE RYDBERG",          &
     &                  " ORBITALS FOR RUN='DE','DI' - WHY WOULD YOU!"
            WRITE(MW0,*)"***CONFG1 ERROR: CANNOT USE RYDBERG",          &
     &                  " ORBITALS FOR RUN='DE','DI' - WHY WOULD YOU!"
            GO TO 1000
          ENDIF
        ENDDO
      ENDIF
!
      IF(IEQ(0).EQ.0)THEN
        DO I=1,MXORB          !AS ANY PASSING FILE DOES NOT CHECK IEQ(0)
          IGRCF(I)=0
        ENDDO
        NGRP=0
        GO TO 900                                                !RETURN
      ENDIF
!
! SET-UP DISTINCT ORBITAL BASES FOR EACH CONFIG IF BASIS='RLX', OR
! GROUP OF CONFIGS, IF BASIS='SRLX', IF USER-SPECIFIED BACK IN SALGEB.
! BASIS='RLX' MUST USE COMMON ORBITALS FOR CLOSED-SHELLS SPECIFIED
! VIA MA,MB, IF REQUIRE DISTINCT THEN SPECIFY AS VALENCE.
! BASIS='SRLX' DEFAULTS TO DISTINCT CORE ORBITAL BASES (IRLX=0).
!
      IF(MA.GT.1)THEN           !USER MUST RE-ORDER SO START WITH CLOSED
        WRITE(MW6,*)
        WRITE(MW6,*)'***SR.CONFG1: MUST START CLOSED SHELL ORBITALS',   &
     &              ' AT KCOR1=1'
        WRITE(MW6,*)'***USE ORBITAL RE-DEFINITION LINE'
        WRITE(MW0,*)'***SR.CONFG1: MUST START CLOSED SHELL ORBITALS',   &
     &              ' AT KCOR1=1'
        GO TO 1000
      ENDIF
!
      MB0=MB
      IF(IEQ(0).GT.0.AND.IRLX.LT.0)MB0=0        !FOR BASIS='SRLX'
!
!      write(mw6,*)mxorb,(qn(i),ql(i)/2,i=1,mxorb)
!      do k=1,kmax
!       write(mw6,*)k,(nel(i,k),i=1,mxorb)
!      enddo
!
      MXORB0=MXORB
      MXFORB=MXORB-MXVORB
      MXVORB=MXVORB-MXBORB
      MXBORB=MXBORB-MB0
!
      IF(MXBORB.LE.0)THEN
        WRITE(MW6,*)'***SR.CONFG1: RELAXED ORBITAL OPTION REQUIRES AT ',&
     &        'LEAST ONE NON-CLOSED-SHELL NON-VALENCE/CONTINUUM ORBITAL'
        WRITE(MW0,*)                                                    &
     &             '***NEED AN OPEN-SHELL NON-VALENCE/CONTINUUM ORBITAL'
        GO TO 1000
      ENDIF
!
      IF(IEQ(0).LT.0)THEN
        NGRP=1
!p        IEQ(0)=-MXBORB
        MXORB=KMAX*MXBORB+MB                    !=MB0 HERE
        IF(MXVORB.GT.0)MXORB=MXORB+KMAX
        IF(.NOT.BFOT)MXORBR=MXORB
        IF(MXFORB.GT.0)MXORB=MXORB+KMAX
        IF(BFOT)MXORBR=MXORB
      ELSE                                      !IEQ(0).GT.0 HERE
!p        NGRP=IEQ(0)
        MXORB=NGRP*(MXORB-MB0)+MB0
        IF(BFOT)THEN
          MXORBR=MXORB
        ELSE
          MXORBR=NGRP*(MXVORB+MXBORB)+MB0
        ENDIF
        IEQ(0)=MXORB+1                  !SO IEQ(0).NE.QCG(I,KF)
!p        IEQ(0)=MXORB+MXBORB           !PACK, EVENTUALLY, PUT IN MODULE
!p        if(ieq(0).ge.1000.or.mxvorb.ge.10.or.mxforb.ge.10)then
!p          stop 'sr.confg1 pack failure'
!p        endif
!p        IEQ(0)=IEQ(0)+1000*MXVORB+10000*MXFORB+100000*NGRP
!p        IF(IRLX.LT.0)IRLX=-MXBORB-100000*NGRP               !FOR FLGL2
      ENDIF
!
      MXORBR=MXORBR-MB0                                           !FLAGX
!
      MXORB=MAX(MXORB,ISCALR)     !FOR SLATER SCALING DUMMY ORB
!
      IF(QP.EQ.2.AND.MXORB.GT.QBUFF2)THEN                     !NEED QP=4
        WRITE(MW0,*)'SR.CONFG1: TOO MANY ORBITALS FOR I*2/QP'
        WRITE(MW0,*)'SR.CONFG1: CHANGE QP TO I*4/SP IN MODULE PRECSN'
        WRITE(MW6,*)'SR.CONFG1: TOO MANY ORBITALS FOR I*2/QP'
        WRITE(MW6,*)'SR.CONFG1: CHANGE QP TO I*4/SP IN MODULE PRECSN'
        NF=0
        GO TO 900
      ENDIF
!
      IF(SP.EQ.4.AND.MXORB.GT.65535)THEN   !MXORB*(MXORB+1)/2.GT.2**31-1
        WRITE(MW0,*)'CONFG1: I*4/SP TOO SHORT IF E_K RAD REQUESTED'
        WRITE(MW0,*)'CONFG1: CHANGE SP TO I*8/EP IN MODULE PRECSN'
        WRITE(MW6,*)'CONFG1: I*4/SP TOO SHORT IF E_K RAD REQUESTED'
        WRITE(MW6,*)'CONFG1: CHANGE SP TO I*8/EP IN MODULE PRECSN'
!        NF=0
!        GO TO 900
      ENDIF
!
      IF(MXORB.GT.IAXGR)THEN
!
        WRITE(MW6,*)'*** CONFG1: increasing MAXGR from ',IAXGR,' to: ', &
     &              MXORB
        WRITE(MW0,*)'*** CONFG1: increasing MAXGR from ',IAXGR,' to: ', &
     &              MXORB
!
        CALL RE_ALLOC2(NEL,IONE,MXORB0,IONE,KMAX,MXORB,KMAX,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'SR.CONFG1: RE-ALLOCATION FAILS FOR NEL'
          NF=0
          GO TO 900
        ENDIF
!
        CALL RE_ALLOC(IEQ,IZERO,MXORB0,MXORB,IERR)
        CALL RE_ALLOC(IGRCF,IONE,MXORB0,MXORB,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'SR.CONFG1: RE-ALLOCATION FAILS FOR IEQ,IGRCF'
          NF=0
          GO TO 900
        ENDIF
!
        CALL RE_ALLOC(QL,IONE,MXORB0,MXORB,IERR)
        CALL RE_ALLOC(QN,IONE,MXORB0,MXORB,IERR)
        CALL RE_ALLOC(DEY,IONE,MXORB0,MXORB,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'SR.CONFG1: RE_ALLOCATION FAILS FOR QL,QN,DEY'
          NF=0
          GO TO 900
        ENDIF
!
        DO K=1,KMAX
          DO J=MXORB0+1,MXORB            !AS ONLY COPIED MXORB0 <- IAXGR
            NEL(J,K)=0
          ENDDO
        ENDDO
!
        IAXGR=MXORB
!
      ENDIF
!
      CALL DIMUSE('MAXGR',MXORB)
!
      IF(MXVORB.GT.0.AND..NOT.BDR)THEN
        WRITE(MW6,*)
        WRITE(MW6,*)"***SR.CONFG1: YOU HAVE SPECIFIED VALENCE ORBITALS",&
     &   " FOR DR BUT RUN='  ', SET RUN='DR' OR SWITCH-OFF VALENCE ORBS"
        WRITE(MW0,*)'***SR.CONFG1: VALENCE ORBITALS SET FOR NON-DR RUN!'
        GO TO 1000
      ENDIF
!
      IF(MENGB.GE.0)THEN          !I.E. BBORN
        MXCORB=MB0+NGRP*(MB-MB0)
        IXGRB=MXORB-MXCORB            !COULD PACK MORE IF IRLX.LT.0...
!        IF(MA.GT.0)IXGRB=IXGRB+MA-1          !MA=1 FIXED
        IF(IXGRB.GT.MXGRB)THEN        !TOO MANY ORBS FOR BORN
          IF(MXGRB.GT.0)WRITE(MW6,*)                                    &
     &                   '***SR.CONFG1: ALLOCATION INCTREASES MXGRB TO '&
     &                   ,IXGRB
        ENDIF
        CALL DIMUSE('MXGRB',IXGRB)
      ENDIF
!
! DUPLICATE ORBITAL LIST FOR EACH CF/GROUP,
!   PUT ALL VALENCE AFTER ALL BOUND
!   PUT ALL CONT AFTER ALL BOUND & VALENCE
! AND REDEFINE CONFIG NEL.
!
      IF(IEQ(0).GT.0)GO TO 800
!
! FULL RELAXED ORBITAL BASIS, ONE PER CONFIG (SO MB=MB0 HERE)
!
      IF(MXFORB.GT.0)THEN
        K0=KMAX*MXBORB
        MBB=MB+MXBORB
        IF(MXVORB.GT.0)THEN
          K0=K0+KMAX
          MBB=MBB+MXVORB
        ENDIF
!
        DO K=1,KMAX                 !CONTINUUM
          II=K0+K+MB
          DEY(II)=DZERO
          IEQ(II)=II
          IGRCF(II)=0
          QN(II)=0
          DO I0=1,MXFORB
            I=I0+MBB
            IT=NEL(I,K)
            IF(IT.GT.0)THEN
              NEL(I,K)=0
              NEL(II,K)=IT
              QN(II)=QN(I)
              QL(II)=QL(I)
              DEY(II)=DONE
              IGRCF(II)=K
              DO J=1,K-1
                JJ=K0+J+MB
                IF(DEY(JJ).NE.DZERO)THEN
                  IF(QN(II).EQ.QN(JJ).AND.QL(II).EQ.QL(JJ))THEN
                    IEQ(II)=IEQ(JJ)
                    GO TO 650
                  ENDIF
                ENDIF
              ENDDO
              GO TO 650
            ENDIF
          ENDDO
  650   ENDDO
      ENDIF
!
      IF(MXVORB.GT.0)THEN
        K0=KMAX*MXBORB
        MBB=MB+MXBORB
!
        DO K=1,KMAX                 !VALENCE
          II=K0+K+MB
          DEY(II)=DZERO
          IEQ(II)=II
          IGRCF(II)=0
          QN(II)=0
          DO I0=1,MXVORB
            I=I0+MBB
            IT=NEL(I,K)
            IF(IT.GT.0)THEN
              NEL(I,K)=0
              NEL(II,K)=IT
              QN(II)=QN(I)
              QL(II)=QL(I)
              DEY(II)=DONE
              IGRCF(II)=K
              DO J=1,K-1
                JJ=K0+J+MB
                IF(DEY(JJ).NE.DZERO)THEN
                  IF(QN(II).EQ.QN(JJ).AND.QL(II).EQ.QL(JJ))THEN
                    IEQ(II)=IEQ(JJ)
                    GO TO 700
                  ENDIF
                ENDIF
              ENDDO
              GO TO 700
            ENDIF
          ENDDO
  700   ENDDO
      ENDIF
!
      DO K=1,KMAX                 !BOUND
        ICFGP(K)=K
        K0=MXBORB*(K-1)
        DO I0=1,MXBORB
          I=I0+MB
          II=I+K0
          IT=NEL(I,K)
          NEL(I,K)=0
          NEL(II,K)=IT
          QN(II)=QN(I)
          QL(II)=QL(I)
          IEQ(II)=IEQ(I)
          IGRCF(II)=K
          IF(NEL(II,K).EQ.0)THEN
            DEY(II)=DZERO
          ELSE
            DEY(II)=DONE
          ENDIF
        ENDDO
      ENDDO
!
      IF(MB.GT.0)THEN             !CORE
        DO J=MA,MB
          IGRCF(J)=0
        ENDDO
      ENDIF
!
      GO TO 900
!
! SIMPLIFIED RELAXED ORBITAL BASIS (FOR GROUPS OF CONFIGS)
!
  800 CONTINUE
!
! while this may seem the natural way to pack, since orbitals only
! reference within the group, historically AS expects all (globally)
! rydbergs to follow all bound and all continuum to follow all rydbergs.
! mods to sr.algeb2, sr.diagon etc are needed to obtain bound-cont data.
!      mxborb=mxborb+mxvorb+mxforb
!      ieq(0)=mxorb+mxborb
!      mxvorb=0
!      mxforb=0
! need to sync. packing with radial/radcon group orthog flag
!
      IF(MXFORB.GT.0)THEN
        K0=MXBORB*(NGRP-1)
        MBB=MB0+MXBORB
        IF(MXVORB.GT.0)THEN
          K0=K0+MXVORB*(NGRP-1)
          MBB=MBB+MXVORB
        ENDIF
        DO N=NGRP,1,-1                 !CONTINUUM
          KK=K0+MXFORB*(N-1)
          DO I0=MXFORB,1,-1
            I=I0+MBB
            II=I+KK
            QN(II)=QN(I)
            QL(II)=QL(I)
            IEQ(II)=I+K0                      !SO ANY USER REMAP IGNORED
            IGRCF(II)=N
            DEY(II)=DZERO
          ENDDO
        ENDDO
!
        DO K=1,KMAX
          N=ICFGP(K)
          KK=K0+MXFORB*(N-1)
          DO I0=MXFORB,1,-1
            I=I0+MBB
            II=I+KK
            IT=NEL(I,K)
            NEL(I,K)=0
            NEL(II,K)=IT
            IF(NEL(II,K).NE.0)DEY(II)=DONE
          ENDDO
        ENDDO
      ENDIF
!
      IF(MXVORB.GT.0)THEN
        K0=MXBORB*(NGRP-1)
        MBB=MB0+MXBORB
        DO N=NGRP,1,-1                  !VALENCE
          KK=K0+MXVORB*(N-1)
          DO I0=MXVORB,1,-1
            I=I0+MBB
            II=I+KK
            QN(II)=QN(I)
            QL(II)=QL(I)
            IEQ(II)=I+K0                      !SO ANY USER REMAP IGNORED
            IGRCF(II)=N
            DEY(II)=DZERO
          ENDDO
        ENDDO
!
        DO K=1,KMAX
          N=ICFGP(K)
          KK=K0+MXVORB*(N-1)
          DO I0=MXVORB,1,-1
            I=I0+MBB
            II=I+KK
            IT=NEL(I,K)
            NEL(I,K)=0
            NEL(II,K)=IT
            IF(NEL(II,K).NE.0)DEY(II)=DONE
          ENDDO
        ENDDO
      ENDIF
!
      DO N=1,NGRP                   !BOUND
        KK=MXBORB*(N-1)
        DO I0=1,MXBORB
          I=I0+MB0
          II=I+KK
          QN(II)=QN(I)
          QL(II)=QL(I)
          IEQ(II)=IEQ(I)                           !ALLOW ANY USER REMAP
          IGRCF(II)=N
          DEY(II)=DZERO
        ENDDO
      ENDDO
!
      DO K=1,KMAX
        N=ICFGP(K)
        KK=MXBORB*(N-1)
        DO I0=1,MXBORB
          I=I0+MB0
          II=I+KK
          IT=NEL(I,K)
          NEL(I,K)=0
          NEL(II,K)=IT
          IF(NEL(II,K).NE.0)DEY(II)=DONE
        ENDDO
      ENDDO
!
!      write(mw6,*)mxorb,(qn(i),ql(i)/2,i=1,mxorb)
!      write(mw6,*)(ieq(i),i=1,mxorb)
!      do k=1,kmax
!       write(mw6,*)k,(nel(i,k),i=1,mxorb)
!      enddo
!
!-----------------------------------------------------------------------
!
  900 DEALLOCATE(ICHK)
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
! FLAG ABORT
!
 1000 NF=-1
      GO TO 900
!
!-----------------------------------------------------------------------
!
10010 FORMAT(///' ATOM WITH',I4,'+',I3,' ELECTRONS IN',I5,              &
     &       ' CONFIGURATIONS',', CLOSED (N L)-SHELLS: '/(7X,20(I4,I3)))
10020 FORMAT(//' ATTENTION: SOME OF THE INTERNAL ORBITALS MAY HAVE ',   &
     &'BEEN REDEFINED, AND MAY NOT BE THE STANDARD CODE (K=1,2,3... FOR'&
     &,'  1S,2S,2P...)'/'    K ',15I7/'   N L ',15(I4,I3))
10030 FORMAT(//'    K ',15I7/'   N L ',15(I4,I3))
10040 FORMAT(" SR.CONFG1: ORBITAL '",A1,"' IN POSITION",I4,             &
     &       " OF C-INPUT (CARD",I3," COLUMN",I3,                       &
     &       ") IS OUTSIDE RANGE, IAXGR=",I3)
10050 FORMAT(" SR.CONFG1: ORBITAL '",A1,"' IN POSITION",I4,             &
     &       " OF C-INPUT (CARD",I3," COLUMN",I3,                       &
     &       ") IS OUTSIDE RANGE, MXLIT=",I3)
10060 FORMAT(' SR.CONFG1: *WARNING* ON REDEFINING ORBITAL INDICES K,',  &
     &       I4,' AND',I4,' BOTH REPRESENT ELECTRONS NL=',I5,I3)
!   91 FORMAT( ' SR.CONFG1: NOTE ON REDEFINING ORBITAL INDICES K,',I4,
!     &' AND',I4, ' BOTH REPRESENT ELECTRONS NL=',2I5,', TREATING AS'
!     &,' EQUIVALENT')
10070 FORMAT(' SR.CONFG1: NOTE ON REDEFINING ORBITAL INDICES K,',I4,    &
     &       ' AND',I4,' BOTH REPRESENT ELECTRONS NL=',2I2,             &
     &       ', TREATING AS',' INEQUIVALENT'/                           &
     &       ' IF YOU MEAN THEM TO BE EQUIVALENT THEN USE A',           &
     &  ' UNIQUE ORBITAL INDEX AND DEFINE SEPARATE CONFIGURATION GROUPS'&
     &  )
10080 FORMAT(' SR.CONFG1: ALLOCATION INCREASES STORAGE FROM MAXCF=',I5, &
     &       ' TO IAXCF=',I5,' CONFIGURATIONS')
10090 FORMAT(' SR.CONFG1: C-INPUT REQUIRES STORAGE FOR MORE THAN MAXCF='&
     &       ,I4,' CONFIGURATIONS - INCREASE IAXCF BUFFER IN SR.ALGEB0')
10100 FORMAT(" SR.CONFG1: YOU'VE REDEFINED K=",I4," AS NL=",I2,1X,A1)
10110 FORMAT(" SR.CONFG1: CONFIGURATION INPUT INCONSISTENT-YOUR",I4,    &
     &       "'TH CONFIGURATION CONTAINS",I3," VALENCE ELECTRONS")
10120 FORMAT(' SR.CONFG1: SPACE FOR ONLY MAXCL=',I3,' CORE ELECTRONS')
10130 FORMAT(' SR.CONFG1:',I3,' ELECTRONS NL=',2I2,' IN CF=',I4)
10140 FORMAT(///' ATOM WITH',I4,' ELECTRONS IN',I4,' CONFIGURATIONS')
10150 FORMAT(//' ***WARNING IN SR.CONFG1, YOU HAVE SPECIFIED MORE THAN',&
     &       ' ONE VALENCE ORBITAL FOR THE DR L-LOOP...')
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE CONFG1
!
!                   *********************
!
      SUBROUTINE CORTFD(X,POT,IEND,ADJUS2,ADJUS3,CRRCT1,CRRCT2)
!
!-----------------------------------------------------------------------
!
!  SR.CORTFD COMPUTES DIPOLE AND QUADRUPOLE PERTURBATIONS TO THE STATIC
!  THOMAS-FERMI POTENTIAL - AS DESCRIBED BY:
!  M. A. BAUTISTA J.PHYS.B 41, 065701 (8pp) (2008).
!
!  IT IS CALLED BY:
!    SR.TFDAPO
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (D15O16=D5TEEN/D6TEEN)
!
      PARAMETER (TOLC=D0PT1)
!
      ALLOCATABLE :: CORRCT(:)
!
      DIMENSION POT(*),X(*)
!
!-----------------------------------------------------------------------
!
      IF(IEND.LE.0)THEN                                        !BAIL-OUT
        WRITE(MW0,*)'***SR.CORTFD: POTENTIAL UNCHANGED AS IEND.LE.0'
        WRITE(MW6,*)'***SR.CORTFD: POTENTIAL UNCHANGED AS IEND.LE.0'
        RETURN
      ENDIF
!
      ALLOCATE(CORRCT(IEND))
!
      SQ2=SQRT(DTWO)
      PI=ACOS(-DONE)
!
      PIP=DONE/(PI*SQ2)
      PIP2=PIP*PIP
      COEFFA=DFOUR*SQ2/(DTHREE*PI)
      COEFFB=COEFFA*(ADJUS3-DONE)
      COEFFA=COEFFA*(ADJUS2-DONE)
!
      V0=PIP2-POT(IEND)-D15O16*PIP2
!
      DO J=1,IEND
!
        X1=X(1)
        V2=V0+POT(1)
        R2=((PIP+SQRT(V2))*X1)**3
        DELP1=R2*X1
        DELP3=DELP1*X1
!
        DO I=2,J
          X0=X1
          X1=X(I)
          DX=X1-X0
!          V1=V2
          V2=V0+POT(I)
          R1=R2
          R2=((PIP+SQRT(V2))*X1)**3
          DELP1=DELP1+(R1+R2)*DX
          DELP3=DELP3+(R1*X0+R2*X1)*DX
!          write(90,702)j,i,delp1,delp3
        ENDDO
!
!
        X1=X(J)
        V2=V0+POT(J)
        R2=(PIP+SQRT(V2))**3
        DELP2=DZERO
        DELP4=DZERO
!
        DO K=J+1,IEND
          X0=X1
          X1=X(K)
          DX=X1-X0
!          V1=V2
          V2=V0+POT(K)
          R1=R2
          R2=(PIP+SQRT(V2))**3
          DELP2=DELP2+(R1+R2)*DX
          DELP4=DELP4+(R1/X0+R2/X1)*DX
!          write(90,702)j,k,delp2,delp4
        ENDDO
!
!
        X1=X(J)
        T=X1*X1
        DELPA=DELP1/T+DELP2*X1
        DELPB=DELP3/(T*X1)+DELP4*T
        CORRCT(J)=DELPA*COEFFA+DELPB*COEFFB
!
!      write(90,*)x(i),pot(i),delpa,delpb,(delpa+delpb)/pot(i)
!      write(90,700)x(j),pot(j),delpa*COEFFA,delpb*COEFFB
!
      ENDDO
!
      T=CORRCT(IEND)/POT(IEND)
      IF(ABS(T).GT.TOLC)WRITE(MW6,10010)T*100
      CRRCT1=DELPA*COEFFA/POT(IEND)
      CRRCT2=DELPB*COEFFB/POT(IEND)
!
!      write(92,*)'****** ',iend
      DO I=1,IEND-1
!        write(92,700)x(i), pot(i),corrct(i)
        POT(I)=POT(I)+CORRCT(I)
      ENDDO
!      write(mw0,*)iend,x(iend),pot(iend),x(iend)*pot(iend) !i=1,iend
!
      DEALLOCATE(CORRCT)
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
! 700   format(4(2x,1pe10.3))
! 702   format(2i5,4(2x,1pe10.3))
10010 FORMAT(//'***WARNING SR.CORTFD: PERTURBATION CORRECTION ',        &
     &       'POTENTIAL EXCEEDS COULOMB AT X(IEND) BY',F5.1,'%'//)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE CORTFD
!
!                             *******************
!
      SUBROUTINE DEIE(TIME,TTIME)
!
!-----------------------------------------------------------------------
!
!  SR.DEIE IS THE CONTROLING ROUTINE FOR:
!  DIRECT ELECTRON-IMPACT EXCITATION COLLISION STRENGTH DETERMINATION.
!
!  IT IS CALLED BY:
!    PR.MAIN
!
!  IT CALLS:
!    SR.ALGX:
!      SR.ALGXLS
!      SR.ALGXFS
!    SR.DWX
!      SR.DWXLS
!      SR.DWXBP
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
! SR.ALGX CALCULATES COLLISION ALGEBRA
!
      CALL ALGX
!
!-----------------------------------------------------------------------
!
      CALL NRB_TIME(TIME0)
!
      TIME0=TIME0/D60
      TIME=TIME0-TIME
      TTIME=TTIME+TIME
!
      WRITE(MW6,10010)TIME,TTIME
!
      TIME=TIME0
!
!-----------------------------------------------------------------------
!
! SR.DWX CALCULATES COLLISION STRENGTHS
!
      if(nf.gt.0)CALL DWX
!
!-----------------------------------------------------------------------
!
      CALL NRB_TIME(TIME0)
!
      TIME0=TIME0/D60
      TIME=TIME0-TIME
      TTIME=TTIME+TIME
!
      WRITE(MW6,10010)TIME,TTIME
!
      TIME=TIME0
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(//1X,'CPU TIME=',F9.3,' MIN',5X,'TOTAL CPU TIME=',F9.3,    &
     &       ' MIN')
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE DEIE
!
!                             *******************
!
      SUBROUTINE DIAG(CEV,NN,NE,IUP,Z,D,E,IRMX,IORD,MXMAT)
!
!-----------------------------------------------------------------------
!
!  BADNELL & BURGESS  D.A.M.T.P. CAMBRIDGE
!
!  SR.DIAG DIAGONALIZES A REAL SYMMETRIC N-BY-N MATRIX Z.
!
!  METHOD: HOUSEHOLDER REDUCTION TO TRI-DIAGONAL FORM AND IMPLICIT
!          SHIFTED QL ALGORITHM TO DETERMINE ALL E-VALUES AND E-VECTORS.
!
!  BASED ON MARTIN, REINSCH & WILKINSON: NUM. MATH. 11, 181-95(1968).
!
!  INPUT REQUIRED:
!
!       NN, (NE), IUP AND Z, WHERE N=ABS(NN).
!
!       MXMAT, IS THE ROW DIMENSION OF Z IN THE CALLING ROUTINE.
!       ONLY THE LOWER TRIANGLE OF Z NEED BE SUPPLIED.
!       ON OUTPUT, THE MATRIX Z IS OVERWRITTEN BY EIGENVECTORS OF Z.
!
!       IUP=1/-1 ASC/DESCENDING E-VALUE SORT.
!          =0 RE-ORDERS ACCORDING TO DOMINANT E-VECTOR COMPONENT.
!
!       IF NN.LT.0 THEN JUST RE-ORDER THE *INPUT* E-VECTORS IN Z,
!          E.G. FROM LAPACK.
!          IN THIS CASE ONLY, NE MAY FLAG THE ACTUAL NUMBER OF E-VECTORS
!          PRESENT, IN COLUMNS 1,2,...NE, WHICH CAN BE LESS THAN N.
!       ***THE COLUMN DIMENSION OF Z IS AT LEAST N STILL, IF IUP=0.
!
!  OUTPUT:
!
!        Z AND D, WHERE Z CONSISTS OF COLUMN EIGENVECTORS
!                 AND D CONSISTS OF CORRESPONDING EIGENVALUES.
!
!  NOTE: E IS A WORKING ARRAY, OF LENGTH N.
!       IRMX, IORD ARE WORKING ARRAYS OF LENGTH N, ONLY USED WHEN IUP=0.
!
!  IT IS CALLED BY:
!    SR.HDIAG
!    SR.VCE
!
!  IT CALLS:
!    SR.HPSRTI
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TOL=D1M40)
      PARAMETER (EPS=D1M12)
      PARAMETER (JMAX=30)
!
      CHARACTER(LEN=1) CEV
!
      DIMENSION D(*),E(*),Z(MXMAT,*),IRMX(*),IORD(*)
!
      DATA IFLAGE/0/,IFLAGV/1/
!
!-----------------------------------------------------------------------
!
! DEAL WITH ANY TRIVIAL CASES
!
      IF(NN.EQ.0)RETURN
!
      IF(NN.EQ.-1)THEN
        IF(IUP.EQ.0)IORD(1)=1
        RETURN
      ENDIF
!
      IF(NN.EQ.1)THEN
        D(1)=Z(1,1)
        Z(1,1)=DONE
        IF(IUP.EQ.0)IORD(1)=1
        RETURN
      ENDIF
!
! NON-TRIVIAL
!
      BEIVEC=CEV.EQ.'V'.OR.CEV.EQ.'v'
!
      N=ABS(NN)
      MM=N
!
! JUST RE-ORDER
!
      IF(NN.LT.0)THEN
        IF(NE.GT.0)MM=MIN(NE,N)
        GO TO 300
      ENDIF
!
!-----------------------------------------------------------------------
!
! HOUSEHOLDER REDUCTION TO TRI-DIAGONAL FORM
!
      DO I=1,N
        D(I)=Z(N,I)
      ENDDO
!
      DO I=N,2,-1
!
        L=I-1
        F=D(I-1)
        G=DZERO
        DO K=1,I-2
          G=G+D(K)*D(K)
        ENDDO
        H=G+F*F
        IF(G.LE.TOL)THEN
          E(I)=F
          H=DZERO
          DO J=1,L
            D(J)=Z(L,J)
            Z(I,J)=DZERO
            Z(J,I)=DZERO
          ENDDO
          GO TO 50
        ENDIF
!
        G=SQRT(H)
        IF(F.GE.DZERO)G=-G
        E(I)=G
        H=H-F*G
        D(L)=F-G
        DO J=1,L
          E(J)=DZERO
        ENDDO
        DO J=1,L
          Z(J,I)=D(J)
          G=E(J)+Z(J,J)*D(J)
          DO K=J+1,L
            G=G+Z(K,J)*D(K)
            E(K)=E(K)+Z(K,J)*D(J)
          ENDDO
          E(J)=G
        ENDDO
!
        F=DZERO
        DO J=1,L
          E(J)=E(J)/H
          F=F+E(J)*D(J)
        ENDDO
        HH=F/(H+H)
        DO J=1,L
          E(J)=E(J)-HH*D(J)
        ENDDO
        DO J=1,L
          F=D(J)
          G=E(J)
          DO K=J,L
            Z(K,J)=Z(K,J)-F*E(K)-G*D(K)
          ENDDO
          D(J)=Z(L,J)
          Z(I,J)=DZERO
        ENDDO
!
   50   D(I)=H
!
      ENDDO
!
      IF(BEIVEC)THEN
!
! ACCUMULATE TRANSFORMATION MATRICES
!
        DO I=2,N
          L=I-1
          Z(N,L)=Z(L,L)
          Z(L,L)=DONE
          H=D(I)
          IF(H.NE.DZERO)THEN
            DO K=1,L
              D(K)=Z(K,I)/H
            ENDDO
            DO J=1,L
              G=DZERO
              DO K=1,L
                G=G+Z(K,I)*Z(K,J)
              ENDDO
              DO K=1,L
                Z(K,J)=Z(K,J)-G*D(K)
              ENDDO
            ENDDO
          ENDIF
          DO J=1,L
            Z(J,I)=DZERO
          ENDDO
        ENDDO
!
        DO I=1,N
          D(I)=Z(N,I)
          Z(N,I)=DZERO
        ENDDO
!
        Z(N,N)=DONE
!
      ELSE
!
! JUST COPY E-ENERGIES
!
        DO I=1,N
          D(I)=Z(I,I)
        ENDDO
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! IMPLICIT SHIFTED QL ALGORITHM TO DETERMINE E-VALUES & E-VECTORS
!
      DO I=2,N
        E(I-1)=E(I)
      ENDDO
!
      E(N)=DZERO
      HMIN=DZERO
      F=DZERO
!
      DO L=1,N
!
        J=0
!
        H=EPS*(ABS(D(L))+ABS(E(L)))
        IF(HMIN.LT.H)HMIN=H
        DO M=L,N
          IF(ABS(E(M)).LE.HMIN)GO TO 100
        ENDDO
  100   IF(M.EQ.L)GO TO 200
  150   IF(J.EQ.JMAX)THEN
          WRITE(MW6,10010)
          GO TO 500
        ENDIF
!
        J=J+1
!
        P=E(L)+E(L)
        G=D(L)
        H=D(L+1)-G
        IF(ABS(H).LT.ABS(E(L)))THEN
          P=H/P
          R=SQRT(P*P+DONE)
          H=P+R
          IF(P.LT.DZERO)H=P-R
          D(L)=E(L)/H
        ELSE
          P=P/H
          R=SQRT(P*P+DONE)
          D(L)=E(L)*P/(R+DONE)
        ENDIF
!
        H=G-D(L)
        DO I=L+1,N
          D(I)=D(I)-H
        ENDDO
        F=F+H
        P=D(M)
        C=DONE
        S=DZERO
        DO I=M-1,L,-1
          G=C*E(I)
          H=C*P
          IF(ABS(P).GE.ABS(E(I)))THEN
            C=E(I)/P
            R=SQRT(C*C+DONE)
            E(I+1)=S*P*R
            S=C/R
            C=DONE/R
          ELSE
            C=P/E(I)
            R=SQRT(C*C+DONE)
            E(I+1)=S*E(I)*R
            S=DONE/R
            C=C/R
          ENDIF
          P=C*D(I)-S*G
          D(I+1)=H+S*(C*G+S*D(I))
          IF(BEIVEC)THEN
            DO K=1,N
              H=Z(K,I+1)
              Z(K,I+1)=S*Z(K,I)+C*H
              Z(K,I)=C*Z(K,I)-S*H
            ENDDO
          ENDIF
        ENDDO
!
        E(L)=S*P
        D(L)=C*P
        IF(ABS(E(L)).GT.HMIN)GO TO 150
  200   D(L)=D(L)+F
!
      ENDDO
!
!-----------------------------------------------------------------------
!
! RE-ORDER E-PAIRS
!
  300 IF(IUP.EQ.0)THEN
!
! PUT BACK IN ORIGINAL ORDER
!
        IF(.NOT.BEIVEC)THEN
!
          DO I=1,MM
            IORD(I)=I
          ENDDO
!
          IF(IFLAGV.EQ.0)THEN
            IFLAGV=IFLAGV+1
            WRITE(MW0,*)                                                &
     &      '*** SR.DIAG: CANNOT RE-ORDER BY E-VECTOR AS NONE REQUESTED'
            WRITE(MW6,*)                                                &
     &      '*** SR.DIAG: CANNOT RE-ORDER BY E-VECTOR AS NONE REQUESTED'
          ENDIF
!
          RETURN
!
        ENDIF
!
!        rewind(99)                      !debug info if assignment fails
!        write(99)n
!        write(99)(d(i),i=1,n)
!        write(99)((z(j,i),j=1,n),i=1,n)
!
        IFOUND=0
!
        DO I=1,MM                   !FIND(ROW)MAX CMPNT OF EACH E-VECTOR
!
          CALL HPSRTI(N,Z(1,I),IORD)           !FIND ORDER OF COMPONENTS
!
          J=IORD(1)
          IRMX(I)=J                      !INITIAL INPUT ORDER-> CPNT MAP
          ZAM=Z(J,I)
          IF(Z(J,I).LT.DZERO)THEN              !MAKE LARGEST CPT >0
            ZAM=-ZAM
            DO J=1,N
              Z(J,I)=-Z(J,I)
            ENDDO
          ENDIF
          E(I)=ZAM
          ISAME=0
!
          DO K=2,N
            J=IORD(K)
            ZABS=ABS(Z(J,I))
            IF(ZABS.EQ.ZAM)THEN                !MAKE NON-EQUAL
              ISAME=ISAME+1
              ZABS=ZABS-ISAME*EPS*ZABS
              Z(J,I)=SIGN(ZABS,Z(J,I))
!            if(j.gt.0)then
!              stop 'degenerate case'
!            endif
            ELSE
              IF(ZABS.EQ.DZERO)GO TO 320       !WE ARE DONE FOR THIS I
              ZAM=ZABS
              ISAME=0
            ENDIF
          ENDDO
!
  320     CONTINUE
!
        ENDDO
!
        DO I=1,N                    !N NOT MM
          IORD(I)=0
        ENDDO
!
  350   P=DZERO
        DO I=1,MM                   !FIND LARGEST MAX CMPNT
          IF(E(I).GT.P)THEN
            P=E(I)
            K=I
          ENDIF
        ENDDO
        IF(IORD(IRMX(K)).EQ.0)THEN  !ASSIGN IF NOT ALREADY DONE SO
          IFOUND=IFOUND+1
          IORD(IRMX(K))=K           !MAPS COMPONENT ORDER TO ORIGINAL
          E(K)=DZERO
          IF(IFOUND.EQ.MM)GO TO 400 !WE ARE DONE
        ELSE                        !ELSE LOOK FOR NEXT LARGEST CMPNT
          P=-DONE
          IRMX(K)=0
          DO J=1,N
            ZABS=ABS(Z(J,K))
            IF(ZABS.GT.P.AND.ZABS.LT.E(K))THEN
                                              !ALL CPTS NON-EQUAL NOW
              IRMX(K)=J
              P=ZABS
            ENDIF
          ENDDO
          IF(IRMX(K).EQ.0)THEN      !JUST FILL-IN
            DO J=1,N
              IF(IORD(J).EQ.0)THEN
                IFOUND=IFOUND+1
                IRMX(K)=J
                IORD(J)=-K
                P=DZERO
              ENDIF
            ENDDO
!
!          write(mw6,*)'k=',k,zabs,e(k),n,ifound,isame
!          do j=1,n
!            write(mw6,1001)iord(irmx(j)),irmx(j),(z(j,k),k=1,n)
!          enddo
! 1001     format(2i5,1p,10e10.2/(10x,10e10.2))
!
            IF(IFLAGE.EQ.0)THEN
              WRITE(MW6,10020)
!
! alternatively, force the issue (for "safety").
!            go to 999               !bailout and use jacord
            ENDIF
            IFLAGE=IFLAGE+1
            IF(IFOUND.EQ.MM)GO TO 400
                                    !WE ARE DONE
          ENDIF
          E(K)=P                    !TRY AGAIN
        ENDIF
        GO TO 350                   !GO FOR NEXT ONE
!
  400   CONTINUE
!
! THE NEW COMPONENT ORDER (IORD) HAS BEEN DETERMINED.
!
! FOR SAFETY, SINCE NON-SEQUENTIAL, ZERO OUT REMAINDER FIRST.
!
        DO I=MM+1,N
          D(I)=DZERO
          DO J=1,N
            Z(J,I)=DZERO
          ENDDO
        ENDDO
!
! NOW SWAP THE ORIGINAL E-VECTORS AND E-VALUES TO MATCH.
!
        DO I=1,N
          IORD(I)=ABS(IORD(I))
          IRMX(I)=I                 !CURRENT POSITION OF ORIG E-VECTOR I
          E(I)=I                    !WHAT'S CURRENTLY IN POSITION I
        ENDDO
        DO I=1,N
          K=IORD(I)
          IF(K.GT.0)THEN
            K=IRMX(K)
            IF(K.NE.I)THEN
              IRMX(IORD(I))=I
              L=NINT(E(I),SP)
              IRMX(L)=K
              E(K)=L
              E(I)=IORD(I)
              P=D(K)
              D(K)=D(I)
              D(I)=P
              DO J=1,N
                P=Z(J,I)
                Z(J,I)=Z(J,K)
                Z(J,K)=P
              ENDDO
            ENDIF
          ENDIF
        ENDDO
!
      ELSE
!
! BEGIN SORTING INTO ASC/DESCENDING E-VALUES
! (SHOULD REALLY HEAPSORT)
!
        DO I=1,MM
          K=I
          P=D(I)
          DO J=I+1,N
            IF(IUP.GT.0.AND.D(J).GT.P)GO TO 420
            IF(IUP.LT.0.AND.D(J).LT.P)GO TO 420
            K=J
            P=D(J)
  420     ENDDO
          IF(K.NE.I)THEN
            D(K)=D(I)
            D(I)=P
            IF(BEIVEC)THEN
              DO J=1,N
                P=Z(J,I)
                Z(J,I)=Z(J,K)
                Z(J,K)=P
              ENDDO
            ENDIF
          ENDIF
        ENDDO
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
  500 NN=0
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(' FAILED IN DIAG, TOO MANY ITERATIONS')
10020 FORMAT('*** UNABLE TO ASSIGN ALL E-VECTORS BY COMPONENT'/         &
     &       '    YOU MIGHT WANT TO RUN-CHECK BY SETTING ',             &
     &       'IDIAG=1 IN SMINIM... (NO MORE WARNINGS)')
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE DIAG
!
!                             *******************
!
      SUBROUTINE DIAGFS(DECORE,DFFS)
!
!-----------------------------------------------------------------------
!
!                 N.R. BADNELL  D.A.M.T.P.  CAMBRIDGE
!
!  SR.DIAGFS CALCULATES LEVEL ENERGIES INCLUDING RELATIVISTIC
!  CORRECTIONS, AND PERMITTED AND FORBIDDEN RADIATIVE DATA.
!  IT ALSO CALCULATES INTERMEDIATE COUPLING AUTOIONIZATION RATES
!  AND PHOTOIONIZATION CROSS SECTIONS
!
!  IT IS CALLED BY:
!    SR.CALCFX
!    SR.MINIM
!
!  IT CALLS:
!    SR.BRNINT
!    FN.CELMNT
!    SR.DATE_AND_TIME (SYSTEM)
!    SR.DIMUSE
!    SR.DISKTF
!    SR.FSINT
!    SR.HDIAG
!    SR.HPSRTI
!    SR.LAGINT
!    SR.NRB_TIME
!    SR.RADBP2
!    SR.RE_ALLOC
!
!  IT CONTAINS:
!    FN.ICOL
!    FN.IROW
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam                            !par
!
      USE COMMON_ALGEB,  ONLY: BFANO
      USE COMMON_ALGEB,  ONLY: BFOT
      USE COMMON_ALGEB,  ONLY: KUTDSK
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_CMESH,  ONLY: MHF,MRAD,MSTEP,IXTRA,xmax
      USE COMMON_COEFF,  ONLY: DRKP,QRLP,IRLP,NRKP,NADP,N81,IPLANT_SOI
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DMQSS3, ONLY: DSS,MSS,NADR,N82,IPLANT_MI               &
     &                        ,NL000=>NL,NL=>NL000
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL,NAD,n8
      USE COMMON_DXRL,   ONLY: IRK,IRK0,IOS,IOS0
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCL0=>INCLUD,JPRINT,JEND
      USE COMMON_INTS,   ONLY: DRL,DOSC,IGAUGE,IXD09,IXD28,IXD29
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR,NTJ,NFJ,JAXLV
      USE COMMON_MINIM,  ONLY: MPNCH,KUTCAS,BPRINT
      USE COMMON_MINIM,  ONLY: ECOR1,ECOR2,ECORR,ECORRJ,ESKPL,ESKPH     &
     &                        ,BECOR
      USE COMMON_MINIM,  ONLY: CMXLSA,CMXLSR,CMXICA,CMXICR,STOLB,XMIX   &
     &                        ,bnobv
      USE COMMON_MINIM,  ONLY: TOLTCC,KTCC,MTCC,NTCC,NNRGLS=>NENERG
      USE COMMON_MINIM,  ONLY: EIONPOT,EIMXLS,EIMXIC                    &
     &                        ,WLG1,WLG2,IWGHT,IWGHT0,IOPTIM            &
     &                        ,JUPMX,JUPMN,JLOWMX,JLOWMN                &
     &                        ,LUPMX,LUPMN,LLOWMX,LLOWMN                &
     &                        ,NMETAR,NMETARJ,NMETAP,NMETAPJ,NRSLMX
      USE COMMON_MISC,   ONLY: BEIVEC,IDIAG
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
      USE COMMON_QTG,    ONLY: MTGD,NXLL,NTT,NTG,JTGD,QTGS,QTGL,QTGD    &
     &                        ,NFI,NFK,NFQ
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
      USE COMMON_REL,    ONLY: DMASS,DCD,D2LL
      USE COMMON_RELINT, ONLY: DRLP1,DNL
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
      USE COMMON_TFU,    ONLY: TFU
      USE COMMON_TRANLS, ONLY: NADRU,NAI,IEORD
      USE COMMON_WEIGHT, ONLY: WGHT,INDEXW
!
      use common_misc,   only: ione1,ione0
      use common_misc,   only: iw,iwp,btime,btimex
      use common_misc,   only: badas
!
      USE COMMON_NRBCAS, ONLY: BCASC,AP,MADD
      USE COMMON_NRBCAS, ONLY: NENERG,JORIG
      USE COMMON_NRBCAV, ONLY: ECAVX,ECAV,AJUSTX,ICAV
      USE COMMON_NRBDEL, ONLY: ISHFTLS,ISHFTIC,NOBS,NOBSJ,MDELE,MULTS   &
     &                        ,DELELS,DELEIC,DELECF,EFLG0,EFLGJ0        &
     &                        ,TOLB,TOLE
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL2, ONLY: MDEL,MXORBR,MPOL00,MPOL0,MPOLE,MPOLX,CODE
      USE COMMON_NRBAL2, ONLY: MAXLAM0,MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBAL3, ONLY: MCFSS,KCFSS,KUTSS,KUTSO,QQCUT
      USE COMMON_NRBAL4, ONLY: MBP1MX,MBP2MX,MEKVMX,KUTM1,MPOLM,QCUT
      USE COMMON_NRBDR,  ONLY: IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR
      USE COMMON_NRBDW,  ONLY: IDW,btop
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBEKP, ONLY: NED
      USE COMMON_NRBFSI, ONLY: DNLI,NLI
      USE COMMON_NRBGRJ, ONLY: NSLJ,NGSLJ
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBIAD, ONLY: IADJ8,NP8
      USE COMMON_NRBINT, ONLY: DRLI,DYY,IYY,NRLI,MENG,NREL,NLAG,NLAGP   &
     &                        ,BLAG,BBC2
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,NASTJ                           &
     &                        ,MINJT,MAXJT,NEIGENJ
      USE COMMON_NRBMKP, ONLY: NMD1,NMD2
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBNF2, ONLY: DETA,DXSI,DZL,DXTWO
      USE COMMON_NRBNFI, ONLY: DZLI,DXTWOI,DETAI,FRI,GRI
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX                     &
     &                        ,MXBORB,MXVORB,MXFORB,NGRP
      USE COMMON_NRBORN, ONLY: BL,OBO,TM2                  !,IXBLM
      USE COMMON_NRBQED, ONLY: VPINT,SLFINT,QED
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBRN1, ONLY: SBL,DBL                                  &
     &                        ,MB3,MB4,INDX,INDL,INDK,IXD33
      USE COMMON_NRBRN2, ONLY: BINDB,MENGB
      USE COMMON_NRBRN3, ONLY: V0,V1,XB,XS,DB0,DB1,OMEGAB               &
     &                        ,MV0,MV1,MINFB,MXNXB,MXNXB1,NLAGB         &
     &                        ,IEXP,XMANT
      USE COMMON_NRBSHF, ONLY: DSHIFT,MSHIFT,KSHIFT,MKMAX,MXEP
      USE COMMON_NRBTAR, ONLY: IGAPE
      USE COMMON_NRBTS1, ONLY: DFOT,DFOTm,DFOSS,PMIN,NFOSS,IPIG,IGAG
      USE COMMON_NRBVAL, ONLY: FACT,IVAL,NNEW,NNOLD,BJUMP,BJUMP2,BRAD   &
     &                        ,BAUGER
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (MXLIT=62)
      PARAMETER (MXSTRG=32)           !MAX STRING WRITE, MOD(MXSTRG,4)=0
      PARAMETER (MSTRGH=16)         !SHORT STRING WRITE, MOD(MSTRGH,4)=0
      PARAMETER (MXLAB1=29)                                    !0:MXLAB1
      PARAMETER (MXLAB2=29)                                    !0:MXLAB2
      PARAMETER (MXLEN=200)                                 !CARD LENGTH
      parameter (mxlenx=2000)                               !card length
!
      PARAMETER (DKON=1.653656E+17_WP)   !DEIGHT/HBAR
      PARAMETER (C1=DFSC**3/HBAR)
      PARAMETER (C2=2.567895E-18_WP)     !DFOUR*XPI*A0_BOHR**2*DFSC
!      PARAMETER (C3=C2/DTHREE)
!
      PARAMETER (EINF=D1P6)
      PARAMETER (DEPS=D1M15)
!
      INTEGER QLB,LIT     !HISTORIC DEFAULT KIND TO SYNC WITH POST PROCS
!
      REAL(WP) TFUJ
!
      REAL(RP) OMEGA
!
      INTEGER(EP) NHOLD8,nctot
!
      CHARACTER(LEN=1) BIGL,NUMB,STRING,CLIT,CMBLK1,CEV,CUL
!OLD  X,SMAL
!HAR  X,LIT,MBLK1  !USE OF CHAR REQUIRES CHANGES TO PP'S FOR UNFORM I/O
      CHARACTER(LEN=2) CELMNT,ELEM,LABW
      CHARACTER(LEN=4) MBCOR,MCOR,MSCOR,MBLK,MYRGE,LAB4,CARD4,MBP
      CHARACTER(LEN=8) DATE
      CHARACTER(LEN=8) MOBS
      character(len=9) orbfmt,LAB9
      CHARACTER(LEN=10) MTEC,NTEC
      character(len=32) ceiss,cstan
      CHARACTER(LEN=17) F762
      CHARACTER(LEN=29) F713,F761
      character(len=51) f542,f543
      character(len=mxlenx) cardx
      CHARACTER(LEN=MXLEN) CARD
!
!      ALLOCATABLE :: DU(:,:)
!
      ALLOCATABLE :: NPOS(:,:),DUI(:,:),DVI(:,:),DDY(:)                 &
     &              ,DVP(:),OMR(:),OMC(:),OMEGA(:,:),TFUJ(:)            &
     &              ,DE(:),IDY(:),DVU(:),NVEC(:)                        &
     &              ,DVECF(:,:),DVECM(:,:)                              &
     &              ,ITMP(:)                                            &
     &              ,iwrkj(:),nadlu(:)                                  &
     &              ,ncf(:),jwrkb(:,:,:),kmap(:),iwrkn(:),jwrkg0(:)     &
     &              ,isorb(:),iwrk1(:),nslb(:),luj(:),decorn(:),NGRPJ(:)
!
      ALLOCATABLE :: IHARRY(:),E1BCF(:),SUMA(:)                         &
     &              ,JCP(:),JTP(:),JRP(:),JWRN(:),JWRD(:),ERN(:),ERD(:) &
     &              ,SUMRN(:),SUMRD(:)                                  &
     &              ,SUMPN(:,:),SUMPD(:,:)                              &
     &              ,DT(:),MMIKE(:),NMIKE(:)
!
      ALLOCATABLE :: LMX(:),QSB(:,:),QLB(:,:),ICF(:),DG(:)
!
      ALLOCATABLE :: DENERG(:),IWRK2(:),ID(:),NADRUJ(:),NAJ(:)          &
     &              ,DVECL(:),DVECV(:),DVECA(:)                         &
     &              ,DWRK(:),IWRK3(:),IWRK4(:),IWRK6(:)
!
      ALLOCATABLE :: ETM(:),WGT(:)
!
      allocatable :: nal(:),iwrks(:),iwrk5(:)                !iwrk5=test
      allocatable :: ncc0(:),iorb(:),jwrkg(:,:),isxdk(:)
!
      DIMENSION BIGL(0:MXLAB1),NUMB(0:MXLAB2)                           &
     &         ,STRING(MXSTRG),CLIT(MXLIT),LIT(MXLIT)
!
      DATA CMBLK1/' '/,MBLK/'    '/,MCOR/' COR'/,MSCOR/'*COR'/          &
     &    ,BSCRO/.FALSE./
!
      DATA CLIT( 1),CLIT( 2),CLIT( 3),CLIT( 4)  /'1','2','3','4'/,      &
     &     CLIT( 5),CLIT( 6),CLIT( 7),CLIT( 8)  /'5','6','7','8'/,      &
     &     CLIT( 9),CLIT(10),CLIT(11),CLIT(12)  /'9','A','B','C'/,      &
     &     CLIT(13),CLIT(14),CLIT(15),CLIT(16)  /'D','E','F','G'/,      &
     &     CLIT(17),CLIT(18),CLIT(19),CLIT(20)  /'H','I','J','K'/,      &
     &     CLIT(21),CLIT(22),CLIT(23),CLIT(24)  /'L','M','N','O'/,      &
     &     CLIT(25),CLIT(26),CLIT(27),CLIT(28)  /'P','Q','R','S'/,      &
     &     CLIT(29),CLIT(30),CLIT(31),CLIT(32)  /'T','U','V','W'/,      &
     &     CLIT(33),CLIT(34),CLIT(35),CLIT(36)  /'X','Y','Z','a'/,      &
     &     CLIT(37),CLIT(38),CLIT(39),CLIT(40)  /'b','c','d','e'/,      &
     &     CLIT(41),CLIT(42),CLIT(43),CLIT(44)  /'f','g','h','i'/,      &
     &     CLIT(45),CLIT(46),CLIT(47),CLIT(48)  /'j','k','l','m'/,      &
     &     CLIT(49),CLIT(50),CLIT(51),CLIT(52)  /'n','o','p','q'/,      &
     &     CLIT(53),CLIT(54),CLIT(55),CLIT(56)  /'r','s','t','u'/,      &
     &     CLIT(57),CLIT(58),CLIT(59),CLIT(60)  /'v','w','x','y'/,      &
     &     CLIT(61),CLIT(62)  /'z','*'/
      DATA (BIGL(I),I=0,MXLAB1)/'S','P','D','F','G','H','I','K','L','M' &
     &                         ,'N','O','P','Q','R','S','T','U','V','W' &
     &                         ,'X','Y','Z','a','b','c','d','e','f','*'/
      DATA (NUMB(I),I=0,MXLAB2)/'0','1','2','3','4','5','6','7','8','9' &
     &                         ,'A','B','C','D','E','F','G','H','I','J' &
     &                         ,'K','L','M','N','O','P','Q','R','S','*'/
!
!-----------------------------------------------------------------------
!      ICOL(ILI,ILF,IONE1)=((ILF-1)*(ILF-2*IONE1))/2+ILI
!      IROW(ILI,ILF,IONE1,NENG)=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE1))/2
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!
      BKUTLS=KUTLS.LT.0                           !.T. FOR SINGLE CF MIX
      BKUTDSK=KUTDSK.NE.0                         !.T. FOR E-VEC TO DISK
!
!-----------------------------------------------------------------------
!
! LOCAL
!
      IF(IEQ(0).NE.0)THEN
        ALLOCATE(ITMP(2*MXORB),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGFS: ALLOCATION FAILS FOR ITMP'
          NF=0
          GO TO 1900
        ENDIF
      ENDIF
!
! local
      if(bkutls)then
        allocate(iwrkn(kmax),stat=ierr)
        if(ierr.ne.0)then
          write(mw0,*)'diagfs: allocation fails for iwrkn'
          nf=0
          go to 1900
        endif
!      endif
      else
        if(bkutdsk.and.bfot)then
          allocate(jwrkg(mxorb,njo),stat=ierr)
          if(ierr.ne.0)then
            write(mw0,*)'diagfs: allocation fails for jwrkg'
            nf=0
            go to 1900
          endif
        endif
      endif
!
! local, as recalculating from sr.algeb3 (ex-common/nrbtmp/)
! for some non-bkutls usage (as per algebs)
      allocate(ncc0(mxorb),iorb(0:mxorb),isxdk(0:njo),stat=ierr)
      if(ierr.ne.0)then
        write(mw0,*)'diagfs: allocation fails for ncc0,iorb,isxdk'
        nf=0
        go to 1900
      endif
!
!-----------------------------------------------------------------------
!
      BVEL=IXD29.EQ.IXD28*2
      BMVDR=ALLOCATED(DCD)
      B2LL=ALLOCATED(D2LL)
!
!-----------------------------------------------------------------------
!
! FIX FOR FORTRAN 90 COMPILERS THAT DON'T ALLOW ASSIGNMENT OF CHARACTERS
! TO INTEGER VARIABLES, REQUIRED FOR HISTORIC BACKWARDS COMPATIBILITY
!
      OPEN(80,STATUS='SCRATCH',FORM='FORMATTED')
      WRITE(80,10980)CMBLK1,(CLIT(I),I=1,MXLIT)
      BACKSPACE(80)
      READ(80,10980)MBLK1,(LIT(I),I=1,MXLIT)
      CLOSE(80)
!
!-----------------------------------------------------------------------
!
! INITIALIZE LOGICALS  ETC
!
      if(btime)then
        btimet=.true.                            !.t. gives more details
        timefh=dzero
        timeh=dzero
        timea=dzero
        timea1=dzero
        timea2=dzero
        timer1=dzero
        timer2=dzero
      else
        btimet=.false.
      endif
!
      BCONT=MODE.EQ.2.OR.MODE.EQ.3                  !FOR BOUND-CONTINUUM
!
      IF(BCONT.AND.ISHFTLS.GT.1)THEN
        WRITE(MW6,*)'**** SR.DIAGFS: TECs CURRENTLY NOT INDEXED',       &
     &           ' FOR USE IN PRESENCE OF CONTINUUM - SETTING ISHFTLS=0'
        WRITE(MW0,*)                                                    &
     &    '*** TECs NOT INDEXED FOR CONTINUUM USAGE - SETTING ISHFTLS=0'
        IF(ISHFTIC.NE.0)THEN
          WRITE(MW6,*)'*** LECs in SHFTIC SHOULD TAKE ACCOUNT OF THIS!'
          WRITE(MW0,*)'*** LECs in SHFTIC SHOULD TAKE ACCOUNT OF THIS!'
        ENDIF
        ISHFTLS=0
        IF(ALLOCATED(TFU))DEALLOCATE(TFU)
        IF(KTCC.EQ.0.AND.ALLOCATED(NADRU))DEALLOCATE(NADRU,NAI,IEORD)
!         NF=-1
!         GO TO 7500
      ENDIF
!
      BMODE=MODE.LT.1.OR.ABS(MORT).GT.20
!
      bposu=.false.             !.T. uses new e-evec dui pos, old is sym
      if(bkutls)bposu=.false.           !force, for now (.T. not coded!)
!
      bmyrge=.false.       !do not try and merge degenerate bound LEVELS
!
      b2fs=nl000.gt.0.or.kutss.ne.-1                        !2-fs exists
!      brtard=irtard.ne.0                          !only for brel=.true.
      BREL2=ABS(IREL).EQ.2                           !SMALL CPT PRESENT
      BDR=IDR.NE.0                                         !RYDBERG LOOP
      BBORN=MENGB.GE.0                                         !PWB DATA
!
      BKUTOO=KUTOO.NE.0
!
      BFOTJ=.NOT.BLAG.OR..NOT.BFOT
      BELONG=IGAUGE.EQ.0                           !AEK/SEK LENGTH GAUGE
!
!                               !RESTRICT CAPTURES AND BUNDLE AUGER LOSS
      BUNA=EIMXIC.ne.DZERO.OR.NMETAPJ.GT.0
!
      IF(NMETARJ.LT.0)THEN                            !RESOLVE BY CONFIG
        MMM=KMAX
      ELSE                                                   !UNRESOLVED
        MMM=0
      ENDIF
!
      BUNR=NRSLMX.LT.0.OR.NRSLMX.GE.0.AND.NNEW.GT.NRSLMX
                                                  !BUNDLE LOWER RAD RATE
!
      BUNPA=.NOT.BFOTJ.AND.BUNA                   !BUNDLE PI ELECTN CONT
      BUNPR=.NOT.BFOTJ.AND.(BUNR.OR.NMETAPJ.GT.0) !BUNDLE PI PHOTON CONT
!
      BDOWN=NMETAPJ.LE.0                 !SO BUNDLED PI IS WEIGTHED DOWN
!
      BJSEL=MULTS.EQ.0
      IF(IDIAG.LT.0)BJSEL=.TRUE.
!
      NPRNT5=MOD(NPRINT,IFIVE)
      BPRNT0=BPRINT
      IF(BPRINT)BPRNT0=JPRINT.NE.-3                    !.AND.JPRINT.NE.3
!      BPRNT5=BPRNT0.AND..NOT.BREL                         !NPRINT.GT.-5
!
      BRADAT=BPRINT.OR.JPRINT.EQ.3.AND.INCLUD.EQ.0
!      IF(.NOT.BPRINT)BRADAT=JPRINT.LT.0.AND.NPRNT5.GT.-2 !EVAL G FUNCTL
      BRADAT=BRADAT.AND.NPRNT5.NE.-2                   !AND HAVE ALGEBRA
!
      BRESAT=MODE.GT.1             !.OR.BREL               !NPRINT.LE.-5
      BCPRNT=MOD(MPNCH,ITWO).NE.0
      BTCC=.NOT.BRESAT.AND.BCPRNT
                                 !PRINT TCC'S-COULD USE KTCC AS FLAG NOW
      BLMOD=MODD.EQ.0.OR.MODD.EQ.-1    !IF FALSE, PHASES MAY BE AN ISSUE
!      BTCC=BTCC.AND.BLMOD
!
      BORT=MORT.LT.0                              !FOR EXPECTATION PRINT
      TOLB2=TOLB/DTWO                                         !RYD->A.U.
!
      nmetj0=nmetaj
      NL0=NL                           !HOLD
!
      MBP='+BP2'
      IF(MBP2MX.LT.0)MBP='+BP1'
!
! RESET INCLUD
!
      INCLUD=MOD(INCL0,I1000000)
      BINCF=IWGHT.LT.0                    !.T. INCLUD BY CF, .F. BY TERM
!
!-----------------------------------------------------------------------
!
! FLAG LAPACK IN USE (COULD SELECTIVELY MIX LAPACK AND NON-LAPACK...)
!
      LAPAK=1                                                    !LAPACK
!
      IF(BEIVEC.AND.(IDW.NE.0.OR.BRADAT.OR.BAUGER.OR.INCLUD.NE.0.OR.    &
     &   BPRNT0.OR.IUNIT(MRW15).GT.0))THEN
        CEV='V'                           !WE NEED E-VECTORS
      ELSE
        CEV='N'                           !WE DON'T
      ENDIF
!
      CUL='U'                             !H TRIANGLE STORED IS UPPER
!
!-----------------------------------------------------------------------
!
! DETERMINE DIMENSIONS REQUIRED TO ALLOCATE
! (SEE ALGEB3 SET-UP, NOTE IAXJU IS REDUCED IF NO RAD OR DW)
!
!-----------------------------------------------------------------------
!
      ISXDK(0)=0
      IAXDK=0
      IXAAK=0
      IAXJU=0
      NCI=0
      NCTOT=0
!
      IF(IDW.NE.0.OR.BRADAT.and..not.bkutdsk)THEN
        IFLAG=1                 !STORE E-VECTORS FOR ALL SYMMETRIES
      ELSE                      !IF(BAUGER.OR.BPRNT0)  !TFU IN USE STILL
        IFLAG=-1                !STORE E-VECTORS ON A PER SYMMETRY BASIS
      ENDIF
!
      DO KGROUP=1,NJO
!
        NCJ=NT(KGROUP)
        IAXDK=MAX(IAXDK,NCJ)
!
        isxdk0=0
!
        N0=0
        NCC=0
        NCI0=0
!
        if(bkutls)then
!
          do k=1,kmax
            iwrkn(k)=0
          enddo
          lu=0
!
          DO NGJ=1,NGSLJ(KGROUP)
            IS=NSLJ(NGJ,KGROUP)
            NP=NSL(IS)
!
            nc0=ncc
            N00=0
            DO NJ=1,NP
              J=NJ+NCI0
              I=NRR(J+NCI)
              K=ABS(NFK(I))
              II=QCG(NF,K)
              ii=ieq(ii)
              IF(IYY(II).GT.0)then
                NCC=NCC+1
              else
                N00=N00+1
              endif
              iwrkn(k)=iwrkn(k)+1
            ENDDO
            N0=N0+N00
            lu=lu+n00*(ncc-nc0)                 !if no 2-fs
            NCI0=NCI0+NP
          ENDDO
!
          ncft0=0
          ncft=0
          do k=1,kmax
            ncf0=iwrkn(k)
            isxdk0=max(isxdk0,ncf0)
            ncft=ncft+ncf0*ncf0
            if(.not.bfot)then
              II=QCG(NF,K)
              ii=ieq(ii)
              if(iyy(ii).lt.0)ncft0=ncft0+ncf0*ncf0
            endif
          enddo
!
          if(mode.eq.2)then
            if(.not.bkutdsk)then
              if(bfot)then                      !need c-c e-vectors
                nctot=nctot+ncft
              else                              !only b-b
                n8=nctot+ncft
                iaxju=max(iaxju,int(n8,ep))     !but need buffer
                nctot=nctot+ncft0               !so can overwite c-c
              endif
            else
              iaxju=max(iaxju,int(ncft,ep))
            endif
          else                                  !need full block
            if(mode.eq.4)then                   !bound only
              ncc=0
              lu=0
            endif
            nctot=nctot+ncft
          endif
!
        else
!
          do i=1,mxorb
            ncc0(i)=0
          enddo
          mx0=mxorb+1
          lu=0
!
          DO NGJ=1,NGSLJ(KGROUP)
            IS=NSLJ(NGJ,KGROUP)
            NP=NSL(IS)
!
            nc0=ncc
            N00=0
            DO NJ=1,NP
              J=NJ+NCI0
              I=NRR(J+NCI)
              K=ABS(NFK(I))
              II=QCG(NF,K)
              ii=ieq(ii)
              IF(IYY(II).GT.0)then
                NCC=NCC+1
                ncc0(ii)=ncc0(ii)+1
                mx0=min(mx0,ii)
              else
                N00=N00+1
              endif
            ENDDO
            N0=N0+N00
            lu=lu+n00*(ncc-nc0)                 !if no 2-fs
            NCI0=NCI0+NP
          ENDDO
!
          if(mode.eq.2)then
            isxdk0=max(isxdk0,n0)
            iorb(mx0-1)=n0*n0                   !I*4 overflow anyway...
            do i=mx0,mxorb
              n=ncc0(i)
              iorb(i)=iorb(i-1)+n*n
              isxdk0=max(isxdk0,n)
            enddo
!
            if(.not.bkutdsk)then
              if(bfot)then                      !need c-c e-vectors
                nctot=nctot+iorb(mxorb)
              else                              !only need b-b
                n8=nctot+iorb(mxorb)
                iaxju=max(iaxju,int(n8,ep))     !but need c-c buffer
                nctot=nctot+iorb(mx0-1)         !so can overwite c-c
              endif
            else
              iaxju=max(iaxju,int(iorb(mxorb),ep))
            endif
          else                                  !need full block
            if(mode.eq.4)then                   !bound only
              ncc=0
              lu=0
            endif
            isxdk0=iaxdk
            NCTOT=NCTOT+NCJ*NCJ
          endif
!
        endif
!
        isxdk(kgroup)=isxdk0
        isxdk(0)=max(isxdk(0),isxdk0)            !global
!
        if(b2fs)LU=NCC*(NCJ-NCC)    !WE HAVE 2-FS, NEED ND.NE.NC
        IXAAK=MAX(IXAAK,LU)
!
        NCI=NCI+NCJ
!
      ENDDO
!
      ISXDK0=ISXDK(0)
!
      IF(.NOT.BAUGER)IXAAK=0
!
!      write(mw0,*)ixaak,iaxju
!      write(mw0,*)isxdk0,iaxdk
!
      IF(IFLAG.LT.0)THEN
        if(mode.ne.2)IAXJU=IAXDK*IAXDK
      ELSE
        if(mode.ne.2.or.bfot)IAXJU=NCTOT
      ENDIF
!      write(mw0,*)nctot,iaxju
!
      IAXJU4=INT(IAXJU,SP)                      !CASE I*8
      CALL DIMUSE('MAXJU',IAXJU4)
      CALL DIMUSE('MAXDK',IAXDK)
      CALL DIMUSE('MXAAK',IXAAK)
!
! LOCAL
!     NVEC ONLY IF BCONT OR BKUTLS, IWRK6 ONLY IF BUNA...
      IDMVEC=1
      IF(BCONT.OR.BKUTLS)IDMVEC=IAXDK
      IDIM6=1
      IF(BUNA)IDIM6=IAXDK
!
      BALLH=.FALSE.
      BALLA=.FALSE.
      ALLOCATE(DVU(IAXDK),DE(IAXDK),IDY(IAXDK),NVEC(IDMVEC),IWRK6(IDIM6)&
     &         ,STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DIAGFS: ALLOCATION FAILS FOR DVU,DE,IDY,NVEC'
        NF=0
        GO TO 1900
      ENDIF
      BALLH=.TRUE.
!
!      ALLOCATE(DU(ISXDK0,ISXDK0),STAT=IERR)         !NEED NOT BE GLOBAL
!      IF(IERR.NE.0)THEN
!        WRITE(MW0,*)'DIAGFS: ALLOCATION FAILS FOR DU'
!        NF=0
!        GO TO ibid
!      ENDIF
!
      IF(BPRNT0)THEN
        IM=(IAXDK*(IAXDK+1))/2
        ALLOCATE(DVP(IM),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGFS: ALLOCATION FAILS FOR DVP'
          NF=0
          GO TO 1100
        ENDIF
      ENDIF
!
      ALLOCATE(TFUJ(IAXJU),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DIAGFS: ALLOCATION FAILS FOR TFUJ'
        NF=0
        GO TO 1100
      ENDIF
      IAXJU=IFLAG*IAXJU
!
      IF(MENG*IXAAK.GT.0)THEN
!        ALLOCATE(DUI(MENG,IXAAK),DVI(MENG,IAXDK),STAT=IERR)
        ALLOCATE(DUI(IXAAK,MENG),DVI(IAXDK,MENG),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGFS: ALLOCATION FAILS FOR DUI,DVI'
          NF=0
          GO TO 1100
        ENDIF
        BALLA=.TRUE.
        IF(BLAG)THEN
          ALLOCATE(DDY(MENG))
        ELSE
          ALLOCATE(DDY(1))
          DDY(1)=DONE
          NP1=1
          NP2=1
        ENDIF
      ENDIF
!
! LOCAL (SMALL)
!
      MXVORB0=10                                  !FOR HISTORIC PP READS
      DO K=1,KMAX
        LM=0
        DO J=1,MXORB
          IF(NEL(J,K).GT.0)LM=LM+1
        ENDDO
        MXVORB0=MAX(MXVORB0,LM)
      ENDDO
!
      ALLOCATE(LMX(KMAX),QSB(MXVORB0,KMAX),QLB(MXVORB0,KMAX),ICF(0:KMAX)&
     &         ,STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DIAGFS: ALLOCATION FAILS FOR LMX,QSB,QLB,ICF'
        NF=0
        GO TO 1100                                               !RETURN
      ENDIF
!
      ALLOCATE(IHARRY(KMAX),E1BCF(KMAX),SUMA(0:MMM),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DIAGFS: ALLOCATION FAILS FOR IHARRY,E1BC,SUMA'
        NF=0
        GO TO 1100                                               !RETURN
      ENDIF
!
      NC1=NCI+1
      ALLOCATE(DENERG(NC1),IWRK2(NC1),ID(0:NCI),NADRUJ(NCI),NAJ(NCI),   &
     &         DVECL(NCI),DVECV(NCI),DVECA(NCI),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DIAGFS: ALLOCATION FAILS FOR DENERG ETC'
        NF=0
        GO TO 1100
      ENDIF
!
      ALLOCATE(DWRK(NCI),IWRK3(NCI),IWRK4(NCI),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DIAGFS: ALLOCATION FAILS FOR DWRK,IWRK'
        NF=0
        GO TO 1100
      ENDIF
!
      ALLOCATE(ETM(NTT),WGT(NTT),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DIAGFS: ALLOCATION FAILS FOR ETM,WGT'
        NF=0
        GO TO 1100
      ENDIF
!
      IF(BTCC)THEN
        IF(MAXTR.GT.1)THEN                      !ALLOW USER TO REDUCE...
          IAXTR=MAXTR
        ELSE
          IF(KTCC.GT.0)THEN
            IAXTR=2*INT(IADJ8,SP)
          ELSE
            IAXTR=IAXDK*IAXDK
          ENDIF
        ENDIF
        ALLOCATE(DT(IAXTR),MMIKE(IAXTR),NMIKE(IAXTR),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGFS: ALLOCATION FAILS FOR DT,MMIKE,NMIKE'
          NF=0
          GO TO 1100
        ENDIF
      ENDIF
!
      allocate(nal(nci))
      allocate(jwrkg0(0:njo),NGRPJ(NJO))
!
      if(.not.bjsel)allocate(iwrkj(nci))
      if(bauger)allocate(nadlu(iaxdk))                       !bcont
!
      if(bkutls)then
        if(.not.b2fs)allocate(iwrk5(nci))                    !iwrk5=test
        allocate(ncf(kmax),kmap(kmax),iwrk1(kmax),luj(0:nsl0))
        if(bradat)allocate(jwrkb(2,kmax,njo))  !not used if no radiation
      elseif(bcont)then                                  !not yet bauger
        allocate(iwrkn(mxorb))
      endif
!
      if(.not.b2fs)allocate(iwrks(nsl0),nslb(nsl0))
!pc
!p      ngrp=1
!p      mxborb=0
!p      if(irlx.lt.0)then
!p        ngrp=-irlx/100000             !until /nrborb/ in a module
!p        mxborb=-irlx-100000*ngrp
!p      endif
!
      ngrp1=1
      if(irlx.lt.0)ngrp1=ngrp
!
      allocate(decorn(ngrp1))
!
! SET-UP TECS BASED-ON CONFIGURATION AVERAGE CORRECTIONS
!
      IF(ISHFTLS.EQ.1.AND.ICAV.NE.0)THEN
        NCT=0
        DO K=1,NSL0
          NC=NSL(K)
          DO ND1=1,NC
            ND=ND1+NCT
            KF=NFK(ND)
            DELELS(ND,1)=ECAVX(KF)-ECAV(KF)
          ENDDO
          NCT=NCT+NC                       !TOT NO. TERMS
        ENDDO
      ENDIF
!
! TEC/LEC SET-UP
!
      MOBS='        '
      MTEC='          '
      NTEC='          '
      LABW='  '
      IF(ISHFTLS.GT.1)THEN                 !SET NUMBER OF TEC ITERATIONS
        ITEC=ISHFTLS
        MTEC='  OBS-CALC'
      ELSE
        ITEC=0
        IF(IOPTIM.LT.0)THEN
          MTEC='DIFFERENCE'
          MOBS='OBSERVED'
        ENDIF
      ENDIF
!
      IF(ISHFTIC.GT.1)THEN                 !SET NUMBER OF LEC ITERATIONS
        JTEC=ISHFTIC
        NTEC='  OBS-CALC'
      ELSE
        JTEC=0
        IF(IOPTIM.GT.0)THEN
          NTEC='DIFFERENCE'
          MOBS='OBSERVED'
          LABW='WT'
        ENDIF
      ENDIF
!
! SET CHARGES ETC.
!
      NZA=NZION-MION+1
      DZA2=NZA*NZA
      DZ2=NZION-MION
      IF(NZION.EQ.MION)DZ2=DONE
      DZ2=DZ2*DZ2
      TSHFT=MSHIFT+MSHIFT
!
!  DETAIL ONE-BODY MAGNETIC INTEGRALS
!
      IF(BJUMP2)THEN                            !JUST RE-SCALE
        IF(BPRNT0)WRITE(MW6,10030)
        DO L=1,IRLP
          DD=DONE
!          K=(QRLP(2,L)-1)/IAXGR
          DO I=1,2
            N=QRLP(I,L)
!            IF(K.NE.0)N=N-K*IAXGR
            DD=DD*FACT(N)
          ENDDO
          DRLP1(L)=DRLP1(L)*DD
          IF(BPRNT0)WRITE(MW6,10040)L,QRLP(1,L),QRLP(2,L),DRLP1(L)
        ENDDO
      ENDIF
!
!  DETAILED PRINTOUT OF MASS-VELOCITY PLUS DARWIN INTEGRALS
!
      IF(BPRNT0)WRITE(MW6,10780)JPRINT
!
      DD1=DZERO
      DD2=DZERO
      DD3=DZERO
      DSHFT0=DZERO
!
      DO K=1,MXORB
        IF(DEY(K).EQ.DZERO)GO TO 100
        IF(NNEW.GE.NSW.AND.IVAL(K).NE.0)DSHFT0=MAX(DSHFT0,DSHIFT(K))
        K17=K
        IF(BJUMP2.AND..NOT.BMVD)THEN !JUST RE-SCALE (NOT DONE IN DIAGON)
          DO J=1,K
            IF(DEY(J).NE.DZERO.AND.QL(J).EQ.QL(K))THEN
              IN=ICOL(J,K,IZERO)
              DD=FACT(J)*FACT(K)
              IF(BMVDR)DMASS(IN)=DMASS(IN)*DD
              IF(BMVDR)DCD(IN)=DCD(IN)*DD
              IF(B2LL)D2LL(IN)=D2LL(IN)*DD
              IF(KUTOO.EQ.98)DXSI(IN)=DXSI(IN)*DD
            ENDIF
          ENDDO
        ENDIF
        IF(BPRNT0)THEN
          IN=ICOL(K,K,IZERO)
          IF(BMVDR)DD1=DMASS(IN)
          IF(BMVDR)DD2=DCD(IN)
          DD=DD1+DD2
          L=QL(K)/2
          IF(B2LL)DD3=D2LL(IN)
          WRITE(MW6,10770)K,QN(K),L,DEY(K),DD1,DD2,DD,DD3
        ENDIF
  100 ENDDO
!
      IF(BPRNT0)THEN
!
        WRITE(MW6,10090)
        DO L=1,IRL
          IF(QRL(5,L).EQ.-1)THEN
            L1=QRL(1,L)
            L2=QRL(3,L)
            IN=ICOL(L2,L1,IZERO)
            IF(BMVDR)DD1=DMASS(IN)
            IF(BMVDR)DD2=DCD(IN)
            IF(B2LL)DD3=D2LL(IN)
            WRITE(MW6,10100)L,L1,L2,DD1,DD2,DD3
          ENDIF
        ENDDO
!
!  DETAILED PRINTOUT OF ONE-BODY RELATIVISTIC CORRECTIONS
!
        IF(NL.LT.-1)THEN                                   !SUPPRESS
          DO L=1,3
            IF(L.EQ.1)THEN
              WRITE(MW6,10700)
            ELSEIF(L.EQ.2)THEN
              WRITE(MW6,10710)
            ELSEIF(L.EQ.3)THEN
              WRITE(MW6,10720)
            ENDIF
!
            K0=0
            DO K=1,K17
              I=K
              IF(DEY(K).EQ.DZERO.OR.QL(J).NE.QL(K))I=10000
              IF(L.EQ.1)THEN
                IF(BMVDR)THEN
                  WRITE(MW6,10730)I,(DMASS(K0+J),J=1,K)
                ELSE
                  WRITE(MW6,10730)I,(DD1,J=1,K)
                ENDIF
              ELSEIF(L.EQ.2)THEN
                IF(BMVDR)THEN
                  WRITE(MW6,10730)I,(DCD(K0+J),J=1,K)
                ELSE
                  WRITE(MW6,10730)I,(DD2,J=1,K)
                ENDIF
              ELSEIF(L.EQ.3)THEN
                IF(B2LL)THEN
                  WRITE(MW6,10730)I,(D2LL(K0+J),J=1,K)
                ELSE
                  WRITE(MW6,10730)I,(DD3,J=1,K)
                ENDIF
              ENDIF
              K0=K0+K
            ENDDO
          ENDDO
        ENDIF
!
      ENDIF
!
! DETAILED PRINTOUT OF ANY QED CONTRIBUTIONS
!
      IF(QED.NE.QZERO)THEN
        IF(BPRNT0)WRITE(MW6,11010)
        DO K=1,MXORB
          IF(DEY(K).NE.DZERO)THEN
            IF(IYY(K).GT.0)GO TO 200                !WE ARE DONE
            IF(BJUMP2.AND.QED.GT.QZERO)THEN         !JUST RE-SCALE
              DD=FACT(K)*FACT(K)
              VPINT(K)=DD*VPINT(K)
              SLFINT(K)=DD*SLFINT(K)
            ENDIF
            DD=VPINT(K)+SLFINT(K)
            IF(BPRNT0)WRITE(MW6,11020)K,QN(K),QL(K)/2,VPINT(K),SLFINT(K)&
     &                                ,DD
          ENDIF
        ENDDO
      ENDIF
!
  200 CONTINUE
!-----------------------------------------------------
!  *** CALCULATE TWO-BODY FINE-STRUCTURE INTEGRALS
!-----------------------------------------------------
!
      if(btimet)call nrb_time(timei)
!
!  HAMILTONIAN
!
      IF(NL000.GT.0)THEN
!
        CALL FSINT(BPRNT0)
!
        IF(NF.LE.0)GO TO 2000
      ENDIF
!
!  M1+BP INTEGRALS
!
      IF(NL.GT.NL000)THEN
!
        CALL RADBP2(BPRNT0)
!
        IF(NF.LE.0)GO TO 2000
      ENDIF
!
      if(btimet)then
        call nrb_time(timef)
        times=timef-timei
        if(nint(times).ne.0)then
!par        if(iam.ge.0)then                                        !par
!par          write(iwp,*)'proc',iam,' for diagfs:'                 !par
!par          write(iwp,*)'    integral time=',nint(times),'sec'    !par
!par          call flush(iwp)                                       !par
!par        else                                                    !par
          write(iw,*)'integral time=',nint(times),'sec'
!par        endif                                                   !par
        endif
      endif
!
      IF(BPRNT0.AND.MAXLAM.NE.MAXLAM0)WRITE(MW6,10110)2*MAXLAM
!
!
!***********************************************************************
!
!  CONSTRUCT AND DIAGONALIZE ENERGY (SUB-)MATRICES.
!
!***********************************************************************
!
!
!  CALCULATE ENERGY CONTRIBUTION DECORE OF THE NW CORE ELECTRONS
!  (MAYBE GROUP DEPENDENT)
!
      do n=1,ngrp1
!
        n1=n-1
        decor0=dzero
!
! 1-BODY
!
        DC1=DZERO                            !NON-REL CONTRIB
        DR1=DZERO                                !REL CONTRIB
        DO L=1,NW
          KX=NNL(L,1)+mxborb*n1
          DC1=DC1+DEY(KX)
          IN=ICOL(KX,KX,IZERO)
          IF(BMVDR)DR1=DR1+DCD(IN)+DMASS(IN)
          IF(QED.NE.QZERO)THEN          !SPLIT FOR CASE NOT-ALLOC
            DR1=DR1+VPINT(KX)+SLFINT(KX)
          ENDIF
          IF(KUTOO.EQ.98)DR1=DR1+DXSI(IN)
        ENDDO
        DCR1=DC1+DR1                    !NON-REL + REL 1-BODY
!
! 2-BODY
!
        DC2=DZERO                            !NON-REL CONTRIB
        DR2=DZERO                                !REL CONTRIB
        DO I=1,NAD(0)
          M=INT(NRK(I),SP)+n1
          DC2=DC2+DRL(M)*DRK(I)
          IF(BKUTOO)THEN
            IF(BFALL(I))THEN
              DR2=DR2-DRK(I)*DZL(M)
            ELSE
              DR2=DR2+DRK(I)*DZL(M)
            ENDIF
            DR2=DR2+DRK(I)*DXTWO(M)+DEK(I)*DETA(M)
!                                -              (MINUS) JONES
          ENDIF
        ENDDO
        DCR2=DC2+DR2                    !NON-REL + REL 2-BODY
        DR12=DR1+DR2                            !REL 1+2 BODY
!
        DECORE=DCR1+DCR2                    ! 1-BODY + 2-BODY
!
        IF(BPRNT0)THEN
          WRITE(MW6,10130)DCR2,DCR1
          IF(BCONT)THEN
            WRITE(MW6,10170)
            IF(ISHFTLS.NE.0.OR.ISHFTIC.NE.0)WRITE(MW6,10220)
          ENDIF
        ENDIF
!
        decorn(n)=decore
        decor0=min(decor0,decore)
!
      enddo
!
      decore=decor0
!
      do n=1,ngrp1
        decorn(n)=decorn(n)-decore
      enddo
!
!  CALCULATE 1-BODY CF ENERGY CONTRIBUTION OF THE NF VALENCE ELECTRONS
!
      DD=DZERO
      M2=0
      DO M1=1,KMAX
        E1BCF(M1)=DZERO
        DO L=1,NF
          IF(QCG(L,M1).NE.M2)THEN                   !.NE. NOT .LT.!
            M2=QCG(L,M1)
            DD=DEY(M2)
            IF(BMVDR)THEN
              IN=ICOL(M2,M2,IZERO)
              DD=DD+DCD(IN)+DMASS(IN)
            ENDIF
            IF(QED.NE.QZERO.and.QED.NE.Q99)THEN     !SPLIT FOR NOT-ALLOC
              IF(QN(M2).GT.QZERO)DD=DD+VPINT(M2)+SLFINT(M2)
            ENDIF
          ENDIF
          E1BCF(M1)=E1BCF(M1)+DD
        ENDDO
        IF(ICAV.NE.0.AND.ISHFTLS.NE.1)E1BCF(M1)=E1BCF(M1)+ECAVX(M1)     &
     &     -ECAV(M1)                                        !CA CORRECTN
      ENDDO
!
!  COLLAPSE BACK RELAXED ORBITAL LIST
!
      IF(IEQ(0).LT.0)THEN
!p        MXBORB=-IEQ(0)
        KF=MB+MXBORB
        DO K=1,KF
          K2=2*K
          ITMP(K2-1)=QN(K)
          ITMP(K2)=QL(K)/2
          IORB(K)=K2
        ENDDO
        KP=2*KF
        KF=MB+MXBORB*KMAX
        IF(BDR)THEN
          DO K=1,KMAX
            KF=KF+1
            IF(IGRCF(KF).GT.0.AND.KF.EQ.IEQ(KF))THEN         !FIRST OCC.
              KP=KP+1
              ITMP(KP)=QN(KF)
              KP=KP+1
              ITMP(KP)=QL(KF)/2
              IORB(KF)=KP
            ENDIF
          ENDDO
        ENDIF
        IF(BCONT)THEN
          DO K=1,KMAX
            KF=KF+1
            IF(IGRCF(KF).GT.0.AND.KF.EQ.IEQ(KF))THEN         !FIRST OCC.
              KP=KP+1
              ITMP(KP)=QN(KF)
              KP=KP+1
              ITMP(KP)=QL(KF)/2
              IORB(KF)=KP
            ENDIF
          ENDDO
        ENDIF
      ELSEIF(IEQ(0).GT.0)THEN
        KP=0
        DO K=1,MXORB
          IF(K.EQ.IEQ(K))THEN                                !FIRST OCC.
            KP=KP+1
            ITMP(KP)=QN(K)
            KP=KP+1
            ITMP(KP)=QL(K)/2
            IORB(K)=KP
          ENDIF
        ENDDO
      ENDIF
!
      IF(.NOT.BMODE)THEN
        EIONMN=DZERO
        IF(IEQ(0).EQ.0)THEN
          KF=MIN(MXLIT,MXORB)
          IF(BPRNT0)WRITE(MW8,10200)KMAX,NZION,MION,                    &
     &                              (ABS(QN(K)),QL(K)/2,K=1,KF)
          IF(.NOT.BPRNT0)WRITE(MW28)int(KMAX),int(NZION),int(MION),     &
     &                              (int(ABS(QN(K))),int(QL(K)/2),K=1,  &
     &                              KF)
        ELSE
          KF=MIN(KP,ITWO*MXLIT)
          IF(BPRNT0)WRITE(MW8,10200)KMAX,NZION,MION,                    &
     &                              (ABS(ITMP(K)),ITMP(K+1),K=1,KF,2)
          IF(.NOT.BPRNT0)WRITE(MW28)int(KMAX),int(NZION),int(MION),     &
     &                              (int(ABS(ITMP(K))),int(ITMP(K+1)),  &
     &                              K=1,KF,2)
        ENDIF
      ENDIF
!
      DO K=1,KMAX
        LM=0
!
        DO J=1,MXORB
          IF(NEL(J,K).GT.0)THEN
            LM=LM+1
            QSB(LM,K)=INT(NEL(J,K),QP)
            IF(LM.GT.1)QSB(LM,K)=QSB(LM,K)+Q50
            IF(IEQ(0).NE.0)THEN
              JQ=IEQ(J)
              JM=MIN(IORB(JQ)/2,MXLIT)
            ELSE
              JQ=J
              JM=MIN(J,MXLIT)
            ENDIF
            QLB(LM,K)=LIT(JM)
!HAR        QLB(LM,K)=ICHAR(CLIT(JM))
            NCC0(LM)=JQ
          ENDIF
        ENDDO
        LMX(K)=LM
!
        IF(LM.LT.MXVORB0)THEN
          LP=LM+1
          DO J=LP,MXVORB0
            QSB(J,K)=0
            QLB(J,K)=MBLK1
!HAR        QLB(J,K)=ICHAR(CMBLK1)
          ENDDO
        ENDIF
        M2=QCG(NF,K)
        KW=K
        MST=MSTAT(K)
        IF(IYY(M2).GT.0)THEN
          M1=QL(M2)+1
          KW=-K
          MST=MSTAT(K)/(M1+M1)
        ENDIF
        IF(.NOT.BMODE)THEN
          IF(BPRNT0)WRITE(MW8,10300)KW,MST,MA,MB,                       &
     &                              (QSB(L,K),QLB(L,K),L=1,LM)
!HAR  X            ,CHAR(QLB(L,K)),L=1,LM)
          IF(.NOT.BPRNT0)WRITE(MW28)int(KW),int(MST),int(MA),int(MB),   &
     &                              (int(QSB(L,K)),int(QLB(L,K)),L=1,   &
     &                              MXVORB0)
        ENDIF
        DO L=1,LM
          QLB(L,K)=NCC0(L)
        ENDDO
      ENDDO
!
      IF(NMETARJ.LT.0)THEN                       !MAP SUM OVER CHANNEL L
        ICF(0)=0
        DO K=1,KMAX
          I=QCG(NF,K)
          IF(IYY(I).GT.0)THEN
            ICF(K)=K
            K1=K-1
            IF(ICF(K1).NE.0)THEN                 !CHECK LAST FOR A MATCH
              IF(LMX(K).NE.LMX(K1))GO TO 250
              DO L=LMX(K)-1,1,-1
                IF(QLB(L,K).NE.QLB(L,K1))GO TO 250
                IF(QSB(L,K).NE.QSB(L,K1))GO TO 250
              ENDDO
              ICF(K)=ICF(K1)
            ENDIF
          ELSE
            ICF(K)=0
          ENDIF
  250   ENDDO
      ENDIF
!
      IF(.NOT.BMODE)THEN
        IF(BPRNT0)WRITE(MW8,10180)NZION,MION
        IF(.NOT.BPRNT0)WRITE(MW28)int(NZION),int(MION)
      ENDIF
!
      IF(BCPRNT)THEN                               !FLAG MIXED SPEC/CORR
        IF(NTCC.NE.MTCC)WRITE(MW6,10580)MTCC,NTCC-MTCC
        IF(KTCC.GT.0)MTCC=NNRGLS                              !FOR TCCDW
        IF(BTCC.AND.KTCC.GT.0.AND.BPRNT0)WRITE(MW6,10520)
      ENDIF
!
!
!*********************************************************************
!
!  THE FOLLOWING KGROUP LOOP RUNS THROUGH ALL THE NJO (J,P) GROUPS
!  C.F. THE CORRESPONDING LOOP IN SR.ALGEB3.
!
!*********************************************************************
!
      NCUT=KCUT
      IF(KCUT.LE.0)NCUT=10000
      BMULT=MULTS.GT.0
      MULTSM=MULTS-1
      BAUXE=.FALSE.
      BAUX=JPRINT.EQ.1.OR.JPRINT.GT.4      !.NOT.BAUX IGNORE CORRELATION
!
! - no longer in use (unless uncommented for testing)
      TOLA=CMXICA*D1M4                           !MAX B-F MATRIX ELEMENT
      IF(NNEW.GT.1)THEN
        T=NNEW
        T=T/DTWO
        TOLA=TOLA/(T*SQRT(T))
      ENDIF
      tola1=tola
      tola2=tola1/100
!
      IF(WLG1.LT.DZERO)THEN                      !MAX AUGER RATE
        WLG=D1M2
      ELSE
        WLG=DZERO
      ENDIF
      WLG=MAX(WLG,WLG1)
!
! repeat of diagon...
      if(bkutls)then                   !map configs: all bound then cont
        kb=0
        do k=1,kmax
          if(iyy(qcg(nf,k)).lt.0)then
            kb=kb+1
            kmap(kb)=k
          endif
        enddo
        kc=kb
        do k=1,kmax
          if(iyy(qcg(nf,k)).gt.0)then
            kc=kc+1
            kmap(kc)=k
          endif
        enddo
        kmax0=kb
        if(kc.gt.kb)then
          kmax1=kmap(kmax0+1)
        else
          kmax1=-1                        !should not be used as no cont
        endif
      endif
!
!
  300 BTEC=ITEC.GT.1.OR.JTEC.GT.1                 !SKIP L/TEC ITERATIONS
!
      NCI=0
      NP8=0
!      MC=0
      NTRAN=0
      ID(0)=0
      MJX=0
      LUMAX=0
      NCTOT=0
      BINT=IAXJU.GT.0
      DMIN=D1P20
      DMAX=-D1P20
      JTMIN=0
      NSKP=0
      NEIG=NEIGENJ                               !USER SETS NO. E-STATES
      IF(ECORRJ.LT.DZERO)THEN
        EEIG=ECORRJ/DTWO-DECORE                   !AS ECORR ABSOLUTE RYD
        if(eeig.ge.dzero)stop 'diagfs, eigg reset .ge. zero...'
      ELSE
        EEIG=DZERO
      ENDIF
!
      dionmn=dzero                   !should really be local, not global
      etest=eimxic
!
      jwrkg0(0)=0
      ib0=0
!
! START JP LOOP
!
      DO KGROUP=1,NJO
!
        NCJ=NT(KGROUP)
!
        IF(BKUTDSK)THEN
          ILEN=ISXDK(KGROUP)
          CALL DISKTF(KGROUP,IVEC,ILEN,TFUJ,IZERO)
          IF(ILEN.LT.0)THEN
            NF=0
            GO TO 1100
          ENDIF
        ENDIF
!
        IF(.NOT.BINT)NCTOT=0
!
        NGRPJ(KGROUP)=NCI
!
        IF(NASTJ.GT.0)THEN                        !MAY RESTRICT E-STATES
          I1=NCI+1
          IP=NSLJ(1,KGROUP)
          JP=10*JN(I1)+QPI(IP)/2
          DO N=1,NASTJ
            IF(JPI(N).EQ.JP)THEN                  !WE HAVE A WINNER
              IF(NJPI(N).GT.0)NEIG=NJPI(N)        !THEN USER SET
              GO TO 320
            ENDIF
          ENDDO
          NEIG=NEIGENJ                            !SHOULDN'T GET HERE
  320     CONTINUE
        ENDIF
!
! INDEX E-VECTORS AND, MAYBE, BOUND-CONT INTERACTIONS
!                                     !don't use parallel flag "par"!!
        if(bkutls)then                !Partition by config (scf)
!
          do k=1,kmax
            ncf(k)=0
          enddo
!
          n0=0
          NCI0=0
          DO NGJ=1,NGSLJ(KGROUP)
            IS=NSLJ(NGJ,KGROUP)
            NP=NSL(IS)
            n00=0                    !no bound levels within a given slp
            DO NJ=1,NP
              I=NJ+NCI0
              II=I+NCI
              IT=NRR(II)
              M1=NFK(IT)
              M1=ABS(M1)
              M2=QCG(NF,M1)
              M2=IEQ(M2)
              IDY(I)=M2
              IF(IYY(M2).LT.0)then
                IDY(I)=-IDY(I)
                n0=n0+1
                if(.not.bjsel)then   !reverse index for jwrkg0 store
                  ib0=ib0+1
                  iwrkj(ib0)=ii
                endif
                n00=n00+1
                nal(ii)=n00
              ELSE
                NFK(IT)=-M1
              ENDIF
              ncf(m1)=ncf(m1)+1
              NAJ(II)=ncf(m1)        !REL POS OF ABS LEVEL IN JP GROUP
            ENDDO
            IF(.NOT.b2fs)nslb(is)=n00
                                     !only needed for .not.b2fs
            NCI0=NCI0+NP
          ENDDO
!
          jwrkg0(kgroup)=jwrkg0(kgroup-1)+n0
!
          k1=kmap(1)
          iwrk1(k1)=0
          iwrkn(k1)=0
          k0=k1
!
          if(bradat)then
            jwrkb(1,k1,kgroup)=0
            jwrkb(2,k1,kgroup)=ncf(k1)
!      write(mw6,*)'kgroup=',kgroup
!      write(mw6,*)'1',k1,ncf(k1),jwrkb(2,k1,kgroup)
          endif
!
          do k=2,kmax
            k1=kmap(k)
            nn=ncf(k0)
            iwrk1(k1)=iwrk1(k0)+nn*nn
            iwrkn(k1)=iwrkn(k0)+nn
            if(bradat)then
              jwrkb(1,k1,kgroup)=jwrkb(1,k0,kgroup)+nn
              jwrkb(2,k1,kgroup)=ncf(k1)
!      write(mw6,*)k,k1,ncf(k1),jwrkb(2,k1,kgroup)
            endif
            k0=k1
          enddo
!
          DO I=1,NCJ
            II=I+NCI
            IT=NRR(II)
            M1=NFK(IT)
            M1=ABS(M1)
            nadruj(ii)=int(nctot,sp)+iwrk1(m1)+ncf(m1)*(naj(ii)-1)
          ENDDO
!
          if(bfot)then                       !need c-c e-vectors
            k=kmap(kmax)
          elseif(kmax0.gt.0)then             !only b-b, so overwrite c-c
            k=kmap(kmax0)
          else
            k=0
          endif
          if(k.gt.0)nctot=nctot+iwrk1(k)+ncf(k)*ncf(k)
!
        elseif(mode.eq.2)then           !need b-c partitioning
!
          n0=0                          !total number of bound levels
          do i=1,mxorb
            ncc0(i)=0                   !no of cont for each orb ang mom
          enddo
          mx0=mxorb  !+1
!
          NCI0=0
          DO NGJ=1,NGSLJ(KGROUP)
            IS=NSLJ(NGJ,KGROUP)
            NP=NSL(IS)
            n00=0                    !no bound levels within a given slp
            DO NJ=1,NP
              I=NJ+NCI0
              II=I+NCI
              IT=NRR(II)
              M1=NFK(IT)
              M1=ABS(M1)
              M2=QCG(NF,M1)
              M2=IEQ(M2)
              IDY(I)=M2
              IF(IYY(M2).LT.0)then   !BOUND
                IDY(I)=-IDY(I)
                n0=n0+1
                NAJ(II)=n0           !REL POS OF ABS LEVEL IN JP GROUP
                if(.not.bjsel)then   !reverse index for jwrkg0 store
                  ib0=ib0+1
                  iwrkj(ib0)=ii
                endif
                n00=n00+1
                nal(ii)=n00
              ELSE                   !CONTINUUM
                NFK(IT)=-M1
                ncc0(m2)=ncc0(m2)+1
                NAJ(II)=ncc0(m2)     !REL POS OF ABS LEVEL IN JP GROUP
                mx0=min(mx0,m2)
              ENDIF
            ENDDO
            IF(.NOT.b2fs)nslb(is)=n00
                                     !only needed for .not.b2fs
            NCI0=NCI0+NP
          ENDDO
!
          jwrkg0(kgroup)=jwrkg0(kgroup-1)+n0
          iorb(mx0)=n0*n0
          iwrkn(mx0)=0                !only need index cont
!
          do i=mx0+1,mxorb
            nn=ncc0(i-1)              !maybe zero
            iorb(i)=iorb(i-1)+nn*nn
            iwrkn(i)=iwrkn(i-1)+nn
          enddo
!
          if(allocated(jwrkg))then
            do i=mx0,mxorb            !so only need allocate mx0:mxorb
              jwrkg(i,kgroup)=ncc0(i)
            enddo
          endif
!
          DO I=1,NCJ
            II=I+NCI
            IF(IDY(I).GT.0)THEN
              m2=idy(i)
              nadruj(ii)=int(nctot,sp)+iorb(m2)+ncc0(m2)*(naj(ii)-1)
            else
              nadruj(ii)=int(nctot,sp)+n0*(naj(ii)-1)
            ENDIF
          ENDDO
!
          if(bfot)then                          !need c-c e-vectors
            nctot=nctot+iorb(mxorb)+ncc0(mxorb)*ncc0(mxorb)
          else                                  !only b-b
            nctot=nctot+n0*n0                   !so can overwrite c-c
          endif
!
          if(bposu.and..not.b2fs)then           !new b-c pos
            lu=0
            do m2=mx0,mxorb
              nn=ncc0(m2)
              if(nn.gt.0)then
                NCI0=0
                DO NGJ=1,NGSLJ(KGROUP)
                  IS=NSLJ(NGJ,KGROUP)
                  NP=NSL(IS)
                  N00=0
                  DO NJ=1,NP
                    I=NJ+NCI0
                    IF(IDY(I).EQ.M2)THEN
                      nadlu(i)=lu               !new pos
                      lu=lu+nslb(is)
                    ENDIF
                  ENDDO
                  NCI0=NCI0+NP
                ENDDO
              endif
            enddo
          endif
!
        ELSE                              !INDEX B-B E-VECTORS
!
          N0=0
          DO I=1,NCJ
            II=I+NCI
            NAJ(II)=I
            IT=NRR(II)
            M1=NFK(IT)
            M1=ABS(M1)
            M2=QCG(NF,M1)
            M2=IEQ(M2)
            IDY(I)=M2
            IF(IYY(M2).LT.0)THEN
              IDY(I)=-IDY(I)
              n0=n0+1
            ELSE
              NFK(IT)=-M1
            ENDIF
            NADRUJ(II)=INT(NCTOT,SP)      !END POSITION OF E-VECTOR II-1
            NCTOT=NCTOT+NCJ
            if(.not.bjsel)iwrkj(ii)=ii
          ENDDO
!
          jwrkg0(kgroup)=jwrkg0(kgroup-1)+ncj     !=ngrpj(kgroup)?
!
        ENDIF
!
        IF(BPRNT0)THEN                          !INITIALIZE FOR PRINTING
          IM=(NCJ*(NCJ+1))/2
          DO IP=1,IM
            DVP(IP)=DZERO
          ENDDO
        ENDIF
!
        if(btimet)call nrb_time(timei)
!
! SET-UP BOUND-CONTINUUM (AUGER) PROBLEM
!
        IF(BAUGER)THEN
!                                                    !CHECK B-C INDEXING
          NHOLD8=NP8
!
          if(b2fs)then
!
            LU=0
            DO L=1,NCJ
              IF(IDY(L).GT.0)THEN
                nadlu(l)=lu               !old pos, not used by new
                lu=lu+n0
              ENDIF
            ENDDO
!
          elseif(.not.bposu)then          !old pos
!
            LU=0
            DO L=1,NCJ
              IF(IDY(L).GT.0)THEN
                nadlu(l)=lu
                j=l+nci
                it=nrr(j)
                ip=nfq(it)
                DO M=1,NCJ
                  IF(IDY(M).LT.0)THEN
                    k=m+nci
                    itp=nrr(k)
                    ipp=nfq(itp)
                    IF(ip.eq.ipp)LU=LU+1
                  ENDIF
                ENDDO
              ENDIF
            ENDDO
!
          endif
!
          IF(LU.GT.LUMAX)LUMAX=LU
          IF(LU.GT.IXAAK)THEN                     !SHOULD NOT HAPPEN NOW
            WRITE(MW6,10740)LU
            WRITE(MW0,*)'***INCREASE MXAAK'
            GO TO 2000
          ENDIF
          LUX=LU
!
! STORE BOUND-CONTINUUM (NON-REL, NFS & FS)
!
          NCI0=0
          DO NGJ1=1,NGSLJ(KGROUP)                         !BEGIN SL LOOP
            IS=NSLJ(NGJ1,KGROUP)
            NP=NSL(IS)
! test
            if(bkutls.and..not.b2fs)then
              n00=0
              do nj11=1,np                               !begin slj loop
                i=nj11+nci0
                if(idy(i).lt.0)then
                  n00=n00+1
                  iwrk5(i)=n00
                endif
              enddo
            endif
!
            IB=NADG(IS)                                   !FOR H(LS) POS
!
            NCIP0=0
            DO NGJP1=1,NGJ1                               !BEGIN SL LOOP
              ISP=NSLJ(NGJP1,KGROUP)
              NPP=NSL(ISP)
!
              n00=0
              DO NJ11=1,NP                               !BEGIN SLJ LOOP
!
                I=NJ11+NCI0
                if(idy(i).lt.0)n00=n00+1           !bound posn within SL
                it=nrr(i+nci)
!
                IF(IS.EQ.ISP)NPP=NJ11
!
                n00p=0
                DO NJP11=1,NPP                           !BEGIN SLJ LOOP
!
                  J=NJP11+NCIP0
                  if(idy(j).lt.0)n00p=n00p+1       !bound posn within SL
!
                  if(bkutls)then
                    jt=nrr(j+nci)
                    btest=idy(i)*idy(j).gt.0.and.nfk(it).ne.nfk(jt)
                    if(btest)go to 322
                  else
                    bt=idy(i).gt.0.and.idy(j).gt.0.and.idy(i).ne.idy(j)
                    if(bt)go to 322
                  endif
!
                  if(is.eq.isp)ib=ib+1             !increment ls counter
                  if(idy(i)*idy(j).lt.0)then                        !b-c
                    if(.not.b2fs.and.is.ne.isp)go to 322      !no 2-body
                  else                                       !b-b or c-c
                    NP8=NP8+1                          !so increment np8
                    go to 322                               !and bailout
                  endif
!
! INDEX AND INITIALIZE
!
                  if(idy(i).gt.0)then
                    lc=i
                    lb=j
                  else
                    lc=j
                    lb=i
                  endif
                  llb=nci+lb
                  llc=nci+lc
!
                  if(b2fs)then
                    if(bposu)then                 !new pos
                      m1=naj(llc)
                      if(bkutls)then
                        itc=nrr(llc)
                        m2=-nfk(itc)
                        m1=m1-iwrkn(kmax1)
                      else
                        m2=idy(lc)
                      endif
                      lu=(iwrkn(m2)+m1-1)*n0+naj(llb)
                    else                          !old pos
                      lu=nadlu(lc)+naj(llb)
                    endif
                    if(bkutls)then
                      itb=nrr(llb)
                      m2=nfk(itb)
                      lu=lu+iwrkn(m2)
                    endif
                  else
                    lu=nadlu(lc)+nal(llb)         !old/new pos
! tests
                    if(idy(i).gt.0)then
                      n5=n00p
                    else
                      n5=n00
                    endif
                    if(nal(llb).ne.n5)stop 'nal'
                    if(bkutls.and..not.b2fs)then
                      if(iwrk5(lb).ne.n5)then     !iwrk5 test
                        write(mw6,*)n5,iwrk5(lb)
                        stop 'iwrk5'
                      endif
                    endif
! end test
                  endif
! TBD remove below test
                  if(lu.gt.ixaak)then
                    write(mw0,*)kgroup,n0,(ncj-n0),ncj,n0*(ncj-n0)
                    stop 'ixaak'
                  endif
                  DO M=1,MENG
!            DUI(M,LU)=DZERO
                    DUI(LU,M)=DZERO
                  ENDDO
!
! 2-BODY FS INTERPOLATABLE
!
                  IF(B2FS)THEN
                    K1=NADR(NP8)+1
                    NP8=NP8+1
                    K2=NADR(NP8)
                    DO L=K1,K2
                      KX=INT(MSS(L),SP)
                      KK=NLI(KX)
                      IF(KK.GT.0)THEN
                        DO M=1,MENG
!                  DUI(M,LU)=DUI(M,LU)+DNLI(M,KK)*DSS(L)
                          DUI(LU,M)=DUI(LU,M)+DNLI(M,KK)*DSS(L)
                        ENDDO
                      ENDIF
                    ENDDO
                  ENDIF
!
! ADD-IN LS TERM CONTRIBUTIONS
!
                  IF(IS.EQ.ISP)THEN
!
                    M1=NAD(IB-1)+1
                    M2=NAD(IB)
!
                    DO L=M1,M2
                      KX=INT(NRK(L),SP)
                      KK=NRLI(KX)
                      IF(KK.GT.0)THEN
! SLATER
                        DO M=1,MENG
!                  DUI(M,LU)=DUI(M,LU)+DRLI(M,KK)*DRK(L)
                          DUI(LU,M)=DUI(LU,M)+DRLI(M,KK)*DRK(L)
                        ENDDO
! NFS
                        IF(BKUTOO)THEN
                          DO M=1,MENG
                            DS=DZLI(M,KK)*DRK(L)
                            IF(BFALL(L))DS=-DS
                            DS=DS+DXTWOI(M,KK)*DRK(L)+DETAI(M,KK)*DEK(L)
                                                                !- JONES
!                    DUI(M,LU)=DUI(M,LU)+DS
                            DUI(LU,M)=DUI(LU,M)+DS
                          ENDDO
                        ENDIF
!
                      ENDIF
                    ENDDO
!
                  ENDIF
!
                  IF(BPRNT0)THEN
                    IP=ICOL(J,I,IZERO)
!            DVP(IP)=DUI(NREL,LU)                  !STORE FOR PRINTING
                    DVP(IP)=DUI(LU,NREL)          !STORE FOR PRINTING
                  ENDIF
!
  322             CONTINUE
!
                ENDDO                             !END SLJ LOOP
!
              ENDDO                               !END SLJ LOOP
!
              NCIP0=NCIP0+NPP
            ENDDO                                 !END SL LOOP
!
            NCI0=NCI0+NP
          ENDDO                                   !END SL LOOP
!
          NP8=NHOLD8                              !RE-INSTATE FS COUNTER
!
        ENDIF
!
! FORM H-MATRIX FOR DIAGONALIZATION
!
        ICB=0
        ICC=0
!
        NCI0=0
        DO NGJ1=1,NGSLJ(KGROUP)                           !BEGIN SL LOOP
          IS=NSLJ(NGJ1,KGROUP)
          NP=NSL(IS)
!
          IB=NADG(IS)                                     !FOR H(LS) POS
!
          IF(ISHFTLS.GT.0)THEN                                 !TEC ONLY
!OLD (.not.bcont.and..not.bkutls only)
!b-b            IA=0                               !TFU (LS) E-VEC START
!b-b            DO L=1,IS-1
!b-b              IN=NSL(L)
!b-b              IA=IN*IN+IA
!b-b            ENDDO
!b-b            if(ia.ne.nadru(iab+1))write(mw0,*)is,ia,nadru(iab+1
!
            INN=NSL(IS)                              !NO OF TERMS IN SYM
            IAB=NGRPI(IS)                        !START OF SYM IN T LIST
!            IA=NADRU(IAB+1)                               !NOT USED NOW
!
          ENDIF
!
          NCIP0=0
          DO NGJP1=1,NGJ1                                 !BEGIN SL LOOP
            ISP=NSLJ(NGJP1,KGROUP)
            NPP=NSL(ISP)
!
            DO NJ11=1,NP                                 !BEGIN SLJ LOOP
!
              I=NJ11+NCI0
              II=I+NCI
              IT=NRR(II)
!
              NN=NADRUJ(II)
!
              IF(IS.EQ.ISP)THEN
!
                NPP=NJ11
!
                M1=NFK(IT)
                M1=ABS(M1)
!
                DE(I)=E1BCF(M1)
                IF(ISHFTIC.GE.1)DE(I)=DE(I)+DELEIC(II,1) !PRE-DIAG SHIFT
!
                if(irlx.lt.0)then
                  n=icfgp(m1)
                  de(i)=de(i)+decorn(n)
                endif
!
                M2=QCG(NF,M1)
                if(bkutls)then
                  IF(IYY(M2).GT.0)DE(I)=DE(I)+ECOR2
                else
                  IF(IYY(M2).LT.0)THEN
                    ICB=ICB+1
                  ELSE
                    DE(I)=DE(I)+ECOR2
                    M2=IEQ(M2)
                    DO M=1,ICC
                      IF(M2.EQ.IORB(M))GO TO 325
                    ENDDO
                    ICC=ICC+1
                    IORB(ICC)=M2
                  ENDIF
                endif
!
              ENDIF
!
  325         CONTINUE
!
              DO NJP11=1,NPP                             !BEGIN SLJ LOOP
!
                DD=DZERO
!
                J=NJP11+NCIP0
                JJ=J+NCI
                ITP=NRR(JJ)
!
                if(bcont)then
                  if(bkutls)then
                    btest=idy(i)*idy(j).gt.0.and.nfk(it).ne.nfk(itp)
                    if(btest)go to 330
                  else
                    bt=idy(i).gt.0.and.idy(j).gt.0.and.idy(i).ne.idy(j)
                    if(bt)go to 330
                  endif
                  if(idy(i)*idy(j).lt.0)then       !b-c, already done
                    if(bauger.and.is.eq.isp)ib=ib+1  !incrmnt ls counter
                    if(mode.eq.2)then              !else mode.eq.3
                      if(bauger.and.b2fs)NP8=NP8+1
                      go to 330
                    endif
                    if(.not.b2fs)go to 326         !no fs, no increment
                  else
                    if(is.eq.isp)ib=ib+1           !increment ls counter
                  endif
                else
                  if(bkutls.and.nfk(it).ne.nfk(itp))go to 330
                  if(is.eq.isp)ib=ib+1
                endif
!
                if(bnobv.and.idy(i).lt.0.and.idy(j).lt.0)then
                  ivi=abs(idy(i))
                  ivj=abs(idy(j))
                  if(ival(ivi).ne.ival(ivj))then   !zero ryd-N+1 int
                    NP8=NP8+1
                    go to 328
                  endif
                endif
!
                N1=NADP(NP8)+1
                NP8=NP8+1
                N2=NADP(NP8)
!
! check for bkutls (just zero-out usual multi-config interactions)
                if(.not.bkutls.and.nfk(it).ne.nfk(itp))then
                  if(abs(nfk(it)).gt.kutls)go to 328
                  if(abs(nfk(itp)).gt.kutls)go to 328
                endif
!
! 1-BODY FS
!
                DO L=N1,N2
                  KX=INT(NRKP(L),SP)
                  DD=DRLP1(KX)*DRKP(L)+DD
                ENDDO
!
! 2-BODY FS
!
                IF(B2FS)THEN
                  K1=NADR(NP8-1)+1
                  K2=NADR(NP8)
                  DO L=K1,K2
                    KX=INT(MSS(L),SP)
                    DD=DNL(KX)*DSS(L)+DD
                  ENDDO
                ENDIF
!
  326           IF(IS.NE.ISP)GO TO 328
!
! APPLY TERM ENERGY CORRECTION DELELS TO TERMS WITH INDICES T
!       IN THE TERM TABLES (NOT ENERGY ORDER)
!
                IF(ISHFTLS.GT.0)THEN
!OLD (.not.bcont.and..not.bkutls only)
!b-b                  L1=IT-IAB
!b-b                  L2=ITP-IAB
!b-b                  DD0=DZERO
!b-b                  DO L=1,INN
!b-b                    IF(ABS(TFU(IA+L1)).GT.D1M4)THEN
!b-b                      IF(ABS(TFU(IA+L2)).GT.D1M4)THEN
!b-b                       DD0=DELELS(L+IAB,1)*TFU(IA+L1)*TFU(IA+L2)+DD0
!b-b                      ENDIF
!b-b                    ENDIF
!b-b                    L1=INN+L1
!b-b                    L2=INN+L2
!b-b                  ENDDO
!b-bc                  dold=dd0
!b-bc                  write(mw6,*)it,itp,dd0
!b-b                  DD=DD+DD0
!
                  DD0=DZERO
                  if(bkutls)then
!                    if(nfk(it).eq.nfk(itp))then        !already skipped
                    L1=NAI(IT)
                    L2=NAI(ITP)
                    do L=1,INN                      !could do better...?
                      LIAB=L+IAB
                      if(nfk(liab).eq.nfk(it))then
                        L0=NADRU(LIAB)
                        DD0=DELELS(LIAB,1)*TFU(L1+L0)*TFU(L2+L0)+DD0
                      endif
                    ENDDO
!                    endif
                  else
                    if(bcont)then
                      if(nfk(it).gt.0.and.nfk(itp).gt.0)then        !b-b
                        L1=NAI(IT)
                        L2=NAI(ITP)
                        do L=1,INN                  !could do better...?
                          LIAB=L+IAB
                          if(nfk(liab).gt.0)then
                            L0=NADRU(LIAB)
                            DD0=DELELS(LIAB,1)*TFU(L1+L0)*TFU(L2+L0)+DD0
                          endif
                        ENDDO
                      endif
                    else
                      L1=NAI(IT)
                      L2=NAI(ITP)
                      DO L=1,INN
                        LIAB=L+IAB
                        L0=NADRU(LIAB)
                        DD0=DELELS(LIAB,1)*TFU(L1+L0)*TFU(L2+L0)+DD0
                      ENDDO
!                      dnew=dd0
!                      if(dold.ne.dnew)write(mw0,*)it,itp,dd0
                    endif
                  endif
!
                  DD=DD+DD0
!
                ENDIF
!
! ADD-IN LS TERM CONTRIBUTIONS
!
                M1=NAD(IB-1)+1
                M2=NAD(IB)
!
                DO L=M1,M2
                  KX=INT(NRK(L),SP)
!
! 2-BODY NON-REL (SLATER)
!
                  DD=DD+DRL(KX)*DRK(L)
!
! 1-BODY NFS
!
                  IF(QRL(5,KX).LT.0)THEN
                                      !DZL(KX)=DXTWO(KX)=DETA(KX)=0 HERE
                    DS=DZERO
                    L1=QRL(1,KX)      !FALLING ORDER L1.GE.L2
                    L2=QRL(3,KX)
                    IN=ICOL(L2,L1,IZERO)
                    IF(BMVDR)DS=DCD(IN)+DMASS(IN)
                    IF(KUTOO.EQ.98)DS=DS+DXSI(IN)
                    DS=DS*DRK(L)
                    DD=DD+DS
                  ENDIF
!
! 2-BODY NFS
!
                  IF(BKUTOO)THEN
                    DS=DZL(KX)*DRK(L)
                    IF(BFALL(L))DS=-DS
                    DS=DS+DXTWO(KX)*DRK(L)+DEK(L)*DETA(KX)
                                         !- JONES
                    DD=DD+DS
                  ENDIF
!
                ENDDO
!
! STORE H-MATRIX FOR DIAGONALIZATION
!
  328           NJ=NAJ(JJ)
!
!      write(mw6,*)ii,jj,nj,nn,dd
!                if(abs(dd).lt.d1m10)dd=dzero
!
                TFUJ(NJ+NN)=DD
!
                IF(BPRNT0)THEN
                  IP=ICOL(J,I,IZERO)
                  DVP(IP)=DD                       !STORE H FOR PRINTING
                ENDIF
!
  330           CONTINUE
!
              ENDDO                              !END SLJ LOOP
!
              IF(IS.EQ.ISP)TFUJ(NJ+NN)=TFUJ(NJ+NN)+DE(I)
                                                      !ADD DIAG E HERE
!
            ENDDO                                !END SLJ LOOP
!
            NCIP0=NCIP0+NPP
          ENDDO                                  !END SL LOOP
!
          NCI0=NCI0+NP
        ENDDO                                    !END SL LOOP
!
        LL=NCI               !HISTORIC NCI UPDATED BEFORE AUTOIONIZATION
!
        if(btimet)then
          call nrb_time(timef)
          timefh=timefh+timef-timei
        endif
!
!*****************************************************************
!
!     DIAGONALIZE HAMILTONIAN
!
!*****************************************************************
!
        if(btime)call nrb_time(timei)
!
        INFO=0
!
        IF((MODE.NE.2.OR.ICC.LE.0).and..NOT.BKUTLS)THEN
!
!***RETAIN (COMMENTED-OUT) FOR CASE OF TFUJ *4 THEN DIAG WITH *8 STILL.
!   AND COMMENT-OUT HDIAG(...,TFUJ,...) (!)
!          NN=NADRUJ(LL+1)
!          DO J=1,NCJ
!            DO I=1,J                        !NAJ(I+LL)=I HERE (ALL B-B)
!              DU(I,J)=TFUJ(NN+I)            !TFUJ IS UPPER H COLUMNWISE
!            ENDDO
!            NN=NN+NCJ
!          ENDDO
!!
!          CALL HDIAG(CEV,CUL,NCJ,NEIG,EEIG,DU,ISXDK0,DVU,DVECV,NF,INFO)
!!
!          NN=NADRUJ(LL+1)                   !RE-INITIALIZE
!          DO J=1,NCJ
!            DO I=1,NCJ
!              TFUJ(NN+I)=DU(I,J)            !NAJ(I+LL)=I HERE (ALL B-B)
!            ENDDO
!            NN=NN+NCJ
!          ENDDO
!***END RETAIN
!
          NN=NADRUJ(LL+1)
!
          CALL HDIAG(CEV,CUL,NCJ,NEIG,EEIG,TFUJ(NN+1),NCJ,DVU,DVECV,NF, &
     &               INFO)
!
          IF(NCJ*NF.LE.0.OR.INFO.GT.0)GO TO 2000
!
          IF(MODE.GE.4)THEN
            icc=0
            NN=NADRUJ(LL+1)                 !RE-INITIALIZE FOR SAFETY *4
            DO J=1,NCJ
              DO I=1,NCJ
                IF(IDY(I)*IDY(J).LT.0)TFUJ(NN+I)=DZERO
              ENDDO
              NN=NN+NCJ
            ENDDO
          ENDIF
!
          IF(BKUTDSK)THEN                         !WRITE TFU TO DISK
            NN=NADRUJ(LL+1)                    !RE-INITIALIZE FOR SAFETY
            DO J=1,NCJ
!
              CALL DISKTF(KGROUP,J,NCJ,TFUJ(NN+1),-IONE)
!
              NN=NN+NCJ
            ENDDO
          ENDIF
!
        ELSE
!
! DIAGONALIZE SEPARATELY THE ICC C-C BLOCKS PLUS THE B-B BLOCK
!
          IF(BKUTLS)THEN
            icb=0
            icc=0
            m0=1
            m1=kmax
          ELSE
            IF(ICB.GT.0)THEN
              M0=0
              IORB(0)=-1000
            ELSE
              M0=1
            ENDIF
            M1=ICC
          ENDIF
!
          NSUB0=0                                   !GLOBAL
          DO M=M0,M1
!
            iflagc=0
!
            NSUB=0
            DO M7=1,NCJ
!
              IF(BKUTLS)THEN
                if(abs(nfk(nrr(m7+ll))).eq.m)then
                  if(idy(m7).lt.0)then
                    icb=icb+1               !just flags global existence
                  else
                    icc=icc+1               !just flags global existence
                    if(.not.bfot)iflagc=1          !flag cont for kutdsk
                  endif
                else
                  go to 340
                endif
              ELSE
                IF(IORB(M).LT.0.AND.IDY(M7).LT.0)GO TO 335
                IF(IORB(M).NE.IDY(M7))GO TO 340
              ENDIF
!
  335         NSUB=NSUB+1
              NVEC(NSUB0+NSUB)=M7
!
  340       ENDDO
!
            if(bkutls)then
              if(nsub.eq.0)go to 360            !only if bkutls=.t.
            else
! could remove, but you never know...
              if(m.gt.0)then
                if(nsub.ne.ncc0(iorb(m)))then
                  write(mw0,*)'icc=',m,'iorb=',iorb(m),'ncc0=',         &
     &                        ncc0(iorb(m)),'nsub=',nsub
                  stop 'cont orb index error...'
                endif
                if(.not.bfot)iflagc=1          !flag cont for kutdsk
              else
                if(nsub.ne.n0)stop 'bound orb index error...'
              endif
            endif
! HOLD
            NSUBH=NSUB
            IDIAGH=IDIAG
!
  350       CONTINUE
 7000     CONTINUE                                               !LAPACK
!
!***RETAIN (COMMENTED-OUT) FOR CASE OF TFUJ *4 THEN DIAG WITH *8 STILL.
!   AND COMMENT-OUT HDIAG(...,TFUJ,...) (!)
!            N1=NVEC(NSUB0+1)+LL
!            NN=NADRUJ(N1)
!            DO IS=1,NSUB
!              DO JS=1,IS
!                DU(JS,IS)=TFUJ(NN+JS)
!              ENDDO
!              NN=NN+NSUB
!            ENDDO
!!
!            CALL HDIAG(CEV,CUL,NSUB,NEIG,EEIG,DU,ISXDK0,DVECL,DVECV,NF,
!     &                 INFO)
!!
!            N1=NVEC(NSUB0+1)+LL                          !RE-INITIALIZE
!            NN=NADRUJ(N1)
!            DO IS=1,NSUB
!              NI=NVEC(NSUB0+IS)
!              DVU(NI)=DVECL(IS)         !STORE E-ENERGIES IN SYMM ORDER
!              DO JS=1,NSUB
!                TFUJ(NN+JS)=DU(JS,IS)
!              ENDDO
!              NN=NN+NSUB
!            ENDDO
!***END RETAIN
!
            N1=NVEC(NSUB0+1)+LL                !RE-INITIALIZE FOR SAFETY
            NN=NADRUJ(N1)
!
            CALL HDIAG(CEV,CUL,NSUB,NEIG,EEIG,TFUJ(NN+1),NSUB,DVECL,    &
     &                 DVECV,NF,INFO)
!
            IF(NF.LE.0)GO TO 2000
!
          IF(INFO.GT.0)THEN   ! LAPACK FAILURE, SO TRY DIAG      !LAPACK
            WRITE(MW6,*)                                                &!LAPACK
     &              ' RE-RUNNING THIS MATRIX ONLY WITH SR.DIAG'  !LAPACK
            GO TO 7000                                           !LAPACK
          ENDIF                                                  !LAPACK
!
            IF(NSUB.EQ.0)THEN   ! DIAG FAILURE, SO RELOAD AND USE JACORD
              WRITE(MW6,*)' RE-RUNNING THIS MATRIX ONLY WITH SR.JACORD'
              NSUB=NSUBH
              IDIAG=1
              GO TO 350
            ENDIF
!
            IDIAG=IDIAGH
!
! STORE E-ENERGIES IN DVU IN ORIGINAL SYMMETRY ORDER (4 EASE OF WRITING)
! ELSE COULD REPLACE DVECL WITH DVU DIRECTLY, AS PER TFUJ.
!
            DO IS=1,NSUB
              NI=NVEC(NSUB0+IS)
              DVU(NI)=DVECL(IS)
            ENDDO
!
            IF(BKUTDSK.and.iflagc.eq.0)THEN
!
              N1=NVEC(NSUB0+1)+LL                         !RE-INITIALIZE
              NN=NADRUJ(N1)
              DO IS=1,NSUB
!
                IVEC=NSUB0+IS
!
                CALL DISKTF(KGROUP,IVEC,NSUB,TFUJ(NN+1),-IONE)
!
                NN=NN+NSUB
!
              ENDDO
!
              NSUB0=NSUB0+NSUB
!
            ENDIF
!
  360       continue           !re-entry point for kutls=.t. case nsub=0
!
          ENDDO                              !END LOOP OVER H SUB-BLOCKS
!
        ENDIF
!
        if(btime)then
          call nrb_time(timef)
          timeh=timeh+timef-timei
        endif
!
!*****************************************************************
!
! PRINT LEVEL ENERGIES, TRANSFORMATION MATRICES AND H-SUBMATRICES.
!
!*****************************************************************
!
        M2=0
!
        DO I=1,NCJ
!
!     J IS THE ARRAY INDEX OF THE WHOLE H-MATRIX, WHEREAS I IS THE
!     POSITION IN THE APPROPRIATE SUBMATRIX
!
          J=I+LL                               !+NCI
          IT=NRR(J)
          IWRK3(J)=0
          M=NFK(IT)
          JJ=ABS(M)
!      IF(IDY(I).GE.0)NFK(IT)=-JJ
!
          DD=DVU(I)
          IF(DD.NE.DZERO)THEN                    !E-STATE EXISTS
!
            if(qed.eq.Q99)then                   !post-process as grasp0
              nn=nadruj(j)
              coeff=dzero
              do l=1,ncj
                nj=naj(l+ll)
                coeff=coeff+tfuj(nn+nj)**2
              enddo
              mm1=abs(nfk(it))
              dq=dzero
              mm2=0
              do k=nf,1,-1
                if(qcg(k,mm1).ne.mm2)then
                  mm2=qcg(k,mm1)
                  if(qn(mm2).gt.0)dq=coeff*(vpint(mm2)+slfint(mm2))
                endif
                dvu(i)=dvu(i)+dq
              enddo
              dd=dvu(i)
            endif
!
! REMOVE ENERGY OF CONTINUUM ELECTRON FROM ENERGY LEVEL LIST
            IF(IDY(I).GT.0)THEN
              IF(MODE.LT.3)DD=DD-DYY(NREL)
              DD=MOD(DD,TSHFT)
              dionmn=min(dionmn,dd)
            ENDIF
!
! POST SHIFT FOR AUGERS
            IF(ISHFTIC.LT.0)THEN
              if(eflgj0*deleic(j,2).lt.dzero)then
                DD=deleic(j,2)+eflgj0-decore      !absolute
              else
                dd=dd+delecf(jj,1)                !correction
              endif
            ENDIF
!
            IF(DD.LT.DMIN)THEN
              DMIN=DD
              JTMIN=J
            ENDIF
            IF(DD.GT.DMAX)DMAX=DD
!
            IF(IDIAG.GE.0.AND.JJ.GT.NCUT)THEN    !CORRELATION
              IWRK4(J)=-J
            ELSE
              IWRK4(J)=J
            ENDIF
          ELSE                                   !E-STATE DOES NOT EXIST
            IWRK4(J)=0
          ENDIF
!
          DENERG(J)=DD
!
          IF(IDY(I).GT.0)THEN
            DD=DD+DECORE
            DD=DD+DD
            IF(DD.LT.EIONMN)EIONMN=DD
          ENDIF
!
          IF(BTEC)GO TO 400
!
          IF(BPRNT0)THEN
            NN=NADRUJ(J)
            IF((MODE.NE.2.OR.ICC.LE.0).AND..NOT.BKUTLS)THEN
              DO L=1,NCJ
                DVECL(L)=TFUJ(NN+L)
              ENDDO
            ELSE
              DO L=1,NCJ
                DVECL(L)=DZERO
                if(idy(i)*idy(l).gt.0)then
                  btest1=nfk(it).eq.nfk(nrr(l+ll))
                  btest2=idy(i).lt.0.or.idy(i).eq.idy(l)
                  if(bkutls.and.btest1.or..not.bkutls.and.btest2)then
                    nj=naj(l+ll)
                    dvecl(l)=tfuj(nn+nj)
                  endif
                endif
              ENDDO
            ENDIF
            M1=M2
            M2=M1+I
            M12=M1
            M1=M1+1
            L2=MIN(NCJ,10_SP)
            M12=M12+MIN(I,10-L2)
            IP=NFQ(IT)
            WRITE(MW6,10050)J,IT,JN(J),QSI(IP)+1,QLI(IP)/2,QPI(IP)/2,   &
     &                      DE(I),DVU(I),NFK(IT),I,(DVECL(L),L=1,L2),   &
     &                      (DVP(L),L=M1,M12)
            IF(M2.GT.M12)WRITE(MW6,10060)(DVECL(L),L=L2+1,NCJ),         &
     &                                   (DVP(L),L=M12+1,M2)
          ENDIF
!
!  CALCULATE 'TERM-COUPLING COEFFICIENTS' FOR TRANSFORMING
!  LS-COUPLING CONFIGURATION-MIXING K-MATRICES TO INTERMEDIATE-COUPLING
!  K-MATRICES:
!
!  BEWARE PHASE CONVENTIONS! HERE CONDON & SHORTLEY
!    (DEFAULT, ALTHOUGH THERE IS A FANO EXPERIMENT).
!
!  NOTE: IF BLMOD=.FALSE. PHASES OF TERM-COUPLING COEFFICIENTS MAY NOT
!  BE CONSISTENT WITH K-MATRIX DATA PRODUCED BY DISTORTED WAVE PROGRAM
!  OF W. EISSNER.
!
          IF(BTCC)THEN
!
            II=NADRUJ(J)
            NTRAN0=NTRAN
            M=IEORD(IT)                         !SO -> EO
            DO IB=1,NCJ
              IP=NRR(IB+NCI)
              IF(IP.NE.1.AND.NADRU(IP).EQ.0)BAUXE=.TRUE.
              IF(.NOT.BAUXE)THEN
                MP=IEORD(IP)                    !SO -> EO
                IF(MP.LE.MTCC.AND.M.LE.MTCC)THEN
                  DS=DZERO
                  if(bkutls)then
                    if(nfk(it).eq.nfk(ip))then
                      DO L=1,NCJ
                        ITP=NRR(L+NCI)
                        IF(NFQ(ITP).EQ.NFQ(IP))THEN     !SAME SYMM GROUP
                          if(nfk(itp).eq.nfk(ip))then
                            NN=NADRU(IP)+NAI(ITP)
                            nj=naj(l+ll)
                            DS=DS+TFUJ(II+nj)*TFU(NN)
                          endif
                        ENDIF
                      ENDDO
                    endif
                  else
                    DO L=1,NCJ
                      ITP=NRR(L+NCI)
                      IF(NFQ(ITP).EQ.NFQ(IP))THEN       !SAME SYMM GROUP
                        NN=NADRU(IP)+NAI(ITP)
                        DS=DS+TFUJ(II+L)*TFU(NN)
                      ENDIF
                    ENDDO
                  endif
                  IF(ABS(DS).GT.TOLTCC)THEN
                    NTRAN=NTRAN+1
                    IF(NTRAN.LE.IAXTR)THEN
                      DT(NTRAN)=DS
                      MMIKE(NTRAN)=MP
                      IF(KTCC.LT.0)NMIKE(NTRAN)=M                 !JAJOM
                    ENDIF
                  ENDIF
                ENDIF
              ENDIF
            ENDDO
            IF(KTCC.GT.0)THEN                                    !STGICF
              IF(MPNCH.LT.0)ID(J)=NTRAN
              IF(BPRNT0.AND..NOT.BAUXE)THEN
                NTRR=MIN(NTRAN,IAXTR)
                N1=NTRR-NTRAN0
                L2=MIN(N1,IFOUR)
                L2=L2+NTRAN0
                NTRAN0=NTRAN0+1
                WRITE(MW6,10470)M,N1,(MMIKE(L),DT(L),L=NTRAN0,L2)
                IF(N1.GT.4)WRITE(MW6,10480)(MMIKE(L),DT(L),L=L2+1,NTRR)
              ENDIF
            ENDIF
          ENDIF
!
  400   ENDDO
!
        NCI=NCI+NCJ
!
! RE-SET ABSOLUTE GROUND STATE BY MODIFYING CORE ENERGY (VIA SHFTIC)
!
!      IF(ISHFTIC.LT.0.AND.EFLGJ0.LT.DZERO)DECORE=EFLGJ0-DMIN
!
!       write(mw6,*)'dionmn=',2*(dionmn+decore),eimxic
!
        if(eimxic.gt.0)etest=eimxic+2*(dionmn+decore)    !rel. to ground
!
!  TCC: IN THIS SECTION (KTCC.LT.0) CARDS F1 AND F2, REQUIRED
!  AS INPUT TO SARAPH'S PROGRAM 'JAJOM', ARE PUNCHED -- SEE MPNCH
!  (REF. H.E.SARAPH, COMPUTER PHYS. COMMUN. 3(1972)256-68).
!
        IF(BTCC.AND.KTCC.LT.0)THEN                                !JAJOM
          IF(.NOT.BAUXE.AND..NOT.BTEC)THEN
            NTRR=MIN(NTRAN,IAXTR)
            IF(BPRNT0)WRITE(MW6,10490)JN(J),NTRAN,                      &
     &                                (MMIKE(L),NMIKE(L),DT(L),L=1,NTRR)
            IF(MPNCH.LT.0)THEN
              IF(BFANO)THEN
                WRITE(MW1,10500)JN(J),NTRAN,NZION,MION
              ELSE
                WRITE(MW1,10510)JN(J),NTRAN,NZION,MION
              ENDIF
              IF(MTCC.LT.100.AND.MPNCH.GT.-4)THEN
                WRITE(MW1,10560)(MMIKE(L),NMIKE(L),DT(L),L=1,NTRR)
              ELSE
                WRITE(MW1,10570)(MMIKE(L),NMIKE(L),DT(L),L=1,NTRR)
              ENDIF
            ENDIF
          ENDIF
          MJX=MAX(MJX,NTRAN)
          NTRAN=0                                                !RE-SET
        ENDIF
!
!********************************************
!
!     ***COMPUTE AUTOIONIZATION RATES***
!
!     EVALUATE <ic!tc><tc!H!tb><tb!ib>
!                              __
!          I.E. DV(I,J)*H(J,K)*DV(K,L)
!
!********************************************
!
!
        IF(ICC.EQ.0.OR.BTEC)GO TO 550        !BAIL OUT TO NEXT SYM GROUP
!
        IF(BUNA)THEN                       !INDEX CONTINUUM ENERGY ORDER
!
          I1=LL+1
          CALL HPSRTI(NCJ,DENERG(I1),IWRK2)
!
          M=0
          DECMIN=-D1P20
!
          DO J=1,NCJ
            IWRK6(J)=0
            I=IWRK2(J)
            II=I+LL
            IT=NRR(II)
            IF(IDY(I).GT.0)THEN
              DRY=DENERG(II)+DECORE
              DRY=DRY+DRY
              IF(DRY.LE.etest.and.iwrk4(ii).ne.0)THEN          !RESOLVED
                IF(DENERG(II).GT.(DECMIN+TOLB2))THEN               !A.U.
                  M=M+1
                  DE(M)=DENERG(II)
                ENDIF
                IF(IWRK6(M).GT.0)THEN
                  NSKP=NSKP+1
                  IWRK3(II)=-M
!              ELSEIF(IDIAG.GE.0.AND.-NFK(IT).GT.NCUT)THEN  !CORR FOR AA
                ELSEIF(IWRK4(II).LE.0)THEN                  !CORR FOR AA
                  NSKP=NSKP+1
                  IWRK3(II)=-M
                ELSE
                  IWRK6(M)=II
                  IWRK3(II)=M
                ENDIF
                DECMIN=DENERG(II)              !ALLOW FOR ANY DRIFT<TOLB
              ELSE
                NSKP=NSKP+1
                IWRK3(II)=-1
              ENDIF
            ELSE                                                  !BOUND
!            IF(IDIAG.GE.0.AND.NFK(IT).GT.NCUT)THEN    !ONLY CORR FOR AA
              IF(IWRK4(II).LE.0)THEN                   !ONLY CORR FOR AA
                NSKP=NSKP+1
                IWRK3(II)=-1 !will not write level info to rate file
              ELSE
                IWRK3(II)=0  !dummy
              ENDIF
            ENDIF
            IWRK2(J)=1                         !keep all for now...
          ENDDO
!
          MSUM=M
        ELSE
          MSUM=0
        ENDIF
!
        IF(ICB.EQ.0)GO TO 500                !BAIL OUT TO NEXT SYM GROUP
        IF(.NOT.BAUGER)GO TO 500
!
! LOOP OVER INITIAL AUTOIONIZING LEVELS
!
        if(btime)call nrb_time(timei)
!
        m00=0
        n00=n0
        nfkjt=0
!
        if(.not.b2fs.and..not.bkutls)then    !SLs must match
          mp0=0
          mx=0
          DO M=1,NCJ
            IF(IDY(M).LT.0)THEN
              mm=m+ll
              mt=nrr(mm)
              mp=nfq(mt)
              if(mp.ne.mp0)then
                iwrks(mp)=mx                 !mark slp boundary
                mp0=mp
              endif
              mx=mx+1
            ENDIF
          ENDDO
        endif
!
        DO J=1,NCJ
!
          IF(IDY(J).GT.0)GO TO 450
!
          JJ=J+LL
          if(denerg(jj).lt.dionmn)go to 450                  !true bound
          JT=NRR(JJ)
!        IF(IDIAG.GE.0.AND.NFK(JT).GT.NCUT)GO TO 423        !CORRELATION
          IF(.NOT.BAUX.AND.IWRK4(JJ).LE.0)GO TO 450         !CORRELATION
!
          IF(BMULT)THEN
            KK=NFQ(JT)
            MNS=QSI(KK)
            IF(MNS.NE.MULTSM)GO TO 450
          ENDIF
!
          DO M=0,MMM                            !=0 IF NMETARJ .GE. 0
            SUMA(M)=DZERO
          ENDDO
          DO M=1,MSUM                           !=0 IF .NOT. BUNA
            DVU(M)=DZERO
          ENDDO
!
          if(bkutls)then
            if(b2fs)then
              m2=nfk(jt)
              luj(0)=iwrkn(m2)
              n00=ncf(m2)
            elseif(nfk(jt).ne.nfkjt)then
              do is=1,nsl0
                nslb(is)=0
              enddo
            endif
          endif
!
! FIND MAX INTERP ENERGY NEEDED FOR THIS INITIAL STATE
!
          IF(BLAG)THEN
!
            DM0=DENERG(JJ)+DSHFT0-dionmn
            DM=-DM0                            ! - AS DON'T NEED COEFFS
!
            CALL LAGINT(DM,DDY,NP1JJ,NP2JJ)
!
          ELSE
!
            NP2JJ=MENG                         !=1 THEN
!
          ENDIF
!
!
          if(btimet)call nrb_time(timeia)
!
! APPLY INITIAL STATE MIXING FOR EACH UNMIXED FINAL STATE
!
          J0=NADRUJ(JJ)
!
          if(.not.b2fs.and.bkutls.and.nfk(jt).ne.nfkjt)then   !match SLs
            nfkjt=nfk(jt)
            mp0=0
            DO M=1,NCJ
              IF(IDY(M).LT.0)THEN
                mm=m+ll
                mt=nrr(mm)
                mp=nfq(mt)
                if(nfk(mt).eq.nfkjt)then
                  nslb(mp)=nslb(mp)+1     !no of each SL for cf=nfk(jt)
                  if(mp.ne.mp0)then
                    iwrks(mp)=naj(mm)-1   !mark slp boundary for nfk(jt)
                    luj(mp)=nal(mm)-1
                    mp0=mp
                  endif
                endif
              ENDIF
            ENDDO
          endif
!
          DO I=1,NCJ
            IF(IDY(I).GT.0)THEN
!
              ii=i+ll
              it=nrr(ii)
              m1=naj(ii)
              if(bkutls)then
                m2=-nfk(it)
                m1=m1-iwrkn(kmax1)
              else
                m2=idy(i)
              endif
              ig=iwrkn(m2)+m1                   !old ig=i
!
!!orr              bcorr=idiag.ge.0.and.-nfk(nrr(ii)).gt.ncut      !corr
!!orr              if(.not.bcorr)then                              !corr
!
              if(b2fs)then
                if(bposu)then                   !new pos
                  lu=(ig-1)*n0
                else                            !old pos
                  lu=nadlu(i)
                endif
                if(bkutls)lu=lu+luj(0)
              else
                lu=nadlu(i)                     !old/new pos
                ip=nfq(it)
                n00=nslb(ip)                    !bound LS symm
                m00=iwrks(ip)                   !start
                if(bkutls)lu=lu+luj(ip)
              endif
!
              J00=J0+M00
!
            IF(LAPAK.GT.0)THEN                                   !LAPACK
              IF(N00.GT.0)THEN                                   !LAPACK
                DO L1=1,NP2JJ                                    !LAPACK
                  DVI(IG,L1)=                                           &!LAPACK
     &             DDOT(N00,TFUJ(J00+1),IONE,DUI(LU+1,L1),IONE)  !LAPACK
                ENDDO                                            !LAPACK
              ELSE                                               !LAPACK
                DO L1=1,NP2JJ                                    !LAPACK
                  DVI(IG,L1)=DZERO                               !LAPACK
                ENDDO                                            !LAPACK
              ENDIF                                              !LAPACK
            ELSE                                                 !LAPACK
              DO L1=1,NP2JJ
                DD=DZERO
                DO M=1,N00
!                  if(abs(tfuj(j00+m)*dui(lu+m,1)).gt.tola1)then    !old
!!                  if(abs(tfuj(j00+m)).gt.cmxica)then             !orig
                  DD=DD+TFUJ(J00+M)*DUI(LU+M,L1)
!                  endif
                ENDDO
                DVI(IG,L1)=DD
              ENDDO
            ENDIF                                                !LAPACK
!!orr                endif                                         !corr
            ENDIF
          ENDDO
!
          if(btimet)then
            call nrb_time(timefa)
            timea1=timea1+timefa-timeia
            timeia=timefa
          endif
!
! LOOP OVER FINAL CONTINUUM TERMS
!
          DO I=1,NCJ
!
            IF(IDY(I).LT.0)GO TO 420
            II=I+LL
            IT=NRR(II)
!          IF(IDIAG.GE.0.AND.-NFK(IT).GT.NCUT)GO TO 425     !CORRELATION
            IF(.NOT.BAUX.AND.IWRK4(II).LE.0)GO TO 420       !CORRELATION
!
            IF(ABS(DENERG(II)+DYY(NREL)-DENERG(JJ)).GT.ACE)GO TO 420
!
            DRY=DENERG(II)
            DS=DENERG(JJ)-DRY
!
            IF(DS.LT.DZERO)GO TO 420          !NOT ENERGETICALLY ALLOWED
!                       .AND.BLAG
!
! SET-UP INTERPOLATION
!
            IF(BLAG)THEN
!
              IF(IGAPE.GT.0)THEN
                IF(DS.LT.DYY(IGAPE).AND.DS.GT.DYY(IGAPE-1))THEN
                  WRITE(MW6,*)                                          &
     &                  'SR.DIAGFS: ***EXTRAPOLATING AUGER2 IC ENERGIES'
                  WRITE(MW6,*)IGAPE,2*DYY(IGAPE-1),2*DS,2*DYY(IGAPE)
                  IF(DS.LT.D0PT9*DYY(IGAPE).AND.DS.GT.D1PT1*DYY(IGAPE-1)&
     &               )THEN
                    WRITE(MW0,*)                                        &
     &                  'SR.DIAGFS: ***EXTRAPOLATING AUGER2 IC ENERGIES'
!                  GO TO 2100
                  ENDIF
                ENDIF
              ENDIF
!
              M2=-IDY(J)
              DM=DS+DSHIFT(M2)
!
              CALL LAGINT(DM,DDY,NP1,NP2)
!
              if(np2.gt.np2jj)then
                write(mw0,*)j,np2jj,i,np2,dm0,dm
!            dm0=denerg(jj)+dshft0-dionmn
!             dm=denerg(jj)-denerg(ii)+dshift(m2)
                write(mw0,*)denerg(jj),dshft0,dionmn,denerg(ii),        &
     &                      dshift(m2)
                stop 'diagfs np2jj error'
              endif
!
            ENDIF
!
! APPLY FINAL-STATE MIXING TO INTERPOLATED MATRIX ELEMENTS
!
            IF(BKUTLS)THEN
              M2=-NFK(IT)
              NCC=NCF(M2)
              L1=IWRKN(M2)-iwrkn(kmax1)
            ELSE
              M2=IDY(I)
              NCC=NCC0(M2)
              L1=IWRKN(M2)
            ENDIF
!
            I0=NADRUJ(II)
            DSJ=DZERO
!
            DO N=NP1,NP2
            IF(LAPAK.GT.0)THEN                                   !LAPACK
              DD=DDOT(NCC,TFUJ(I0+1),IONE,DVI(L1+1,N),IONE)      !LAPACK
            ELSE                                                 !LAPACK
              DD=DZERO
              DO M=1,NCC
!                if(abs(tfuj(i0+m)*dvi(l1+m,np1)).gt.tola2)then     !old
!!                if(abs(tfuj(i0+m)).gt.cmxica)then                !orig
                DD=DD+TFUJ(I0+M)*DVI(L1+M,N)
!                endif
              ENDDO
            ENDIF                                                !LAPACK
              DSJ=DSJ+DDY(N)*DD
            ENDDO
!
! FORM AUTOIONIZATION RATE
!
            DSJ=ABS(DSJ)*DSJ*DKON
            IF(ABS(DSJ).GT.WLG)THEN
              MWJ=JN(JJ)+1
              IF(BPRNT0)WRITE(MW6,10150)MWJ,II,JJ,DSJ,DS,DRY
              DS=DS+DS
              DRY=DRY+DECORE
              DRY=DRY+DRY
!              IF(DRY.LT.EIONMN)EIONMN=DRY
!
              IF(BUNA)THEN                                 !BUNDLE CONT
                IF(DRY.LE.etest)THEN                       !RESOLVED
                  M=IWRK3(II)
                  M=ABS(M)
                  DVU(M)=DVU(M)+ABS(DSJ)
                ELSE                                       !BUNDLED
                  M=0
                  IF(NMETARJ.LT.0)M=ICF(-NFK(IT))          !BY TARGET CF
                  SUMA(M)=SUMA(M)+ABS(DSJ)
                ENDIF
              ELSE
                IF(BPRNT0)WRITE(MW8,10190)NFK(JT),JJ,MWJ,NFK(IT),II,DSJ,&
     &                                    DS,DRY
                IF(.NOT.BPRNT0)WRITE(MW28)int(NFK(JT)),int(JJ),int(MWJ),&
     &                                    int(NFK(IT)),int(II),DSJ,DS,  &
     &                                    DRY
              ENDIF
            ENDIF
!
  420     ENDDO                  !END LOOP OVER FINAL LEVELS
!
          IF(BUNA)THEN
            DO M=1,MSUM
              IF(DVU(M).GT.WLG)THEN
                IWRK2(M)=1                                  !FLAG EXISTS
                DS=DENERG(JJ)-DE(M)
                DS=DS+DS
                DRY=DE(M)+DECORE
                DRY=DRY+DRY
                II=IWRK6(M)
                IT=NRR(II)
                IF(BPRNT0)WRITE(MW8,10190)NFK(JT),JJ,MWJ,NFK(IT),II,    &
     &                                    DVU(M),DS,DRY
                IF(.NOT.BPRNT0)WRITE(MW28)int(NFK(JT)),int(JJ),int(MWJ),&
     &                                    int(NFK(IT)),int(II),DVU(M),  &
     &                                    DS,DRY
              ENDIF
            ENDDO
            IF(SUMA(0).GT.WLG)THEN
              IF(BPRNT0)WRITE(MW8,10190)NFK(JT),JJ,MWJ,IZERO,IZERO,     &
     &                                  SUMA(0),EINF,DZERO
              IF(.NOT.BPRNT0)WRITE(MW28)int(NFK(JT)),int(JJ),int(MWJ),  &
     &                                  int(IZERO),int(IZERO),SUMA(0),  &
     &                                  EINF,DZERO
            ENDIF
            DO M=1,MMM
              IF(SUMA(M).GT.WLG)THEN
                IF(BPRNT0)WRITE(MW8,10190)NFK(JT),JJ,MWJ,-M,IZERO,      &
     &                                    SUMA(M),EINF,DZERO
                IF(.NOT.BPRNT0)WRITE(MW28)int(NFK(JT)),int(JJ),int(MWJ),&
     &                                    int(-M),int(IZERO),SUMA(M),   &
     &                                    EINF,DZERO
              ENDIF
            ENDDO
          ENDIF
!
          if(btimet)then
            call nrb_time(timefa)
            timea2=timea2+timefa-timeia
          endif
!
  450   ENDDO                   !END LOOP OVER INITIAL LEVELS
!
        IF(BAUGER.AND.BPRNT0)WRITE(MW6,10750)LUX
!
        if(btime)then
          call nrb_time(timef)
          timea=timea+timef-timei
        endif
!
  500   CONTINUE
!
        IF(BUNPA)THEN           !RE-INDEX FOR PI CONT SUM
          IF(BUNPR)THEN
            DO I=1,NCJ
              IF(IDY(I).GT.0)THEN
                II=I+LL
                MM=IWRK3(II)
                M=ABS(MM)
                IF(IWRK6(M).GT.0)IWRK3(II)=SIGN(IWRK6(M),MM)
              ENDIF
            ENDDO
          ELSE                  !NO CONT SUM SO CAN NO LONGER DROP TERMS
            DO I=1,NCJ
              IF(IDY(I).GT.0)THEN
                II=I+LL
                IF(IWRK3(II).LT.0)THEN
                  IWRK3(II)=-IWRK3(II)
                  NSKP=NSKP-1
                ENDIF
              ENDIF
            ENDDO
          ENDIF
        ELSE                            !CAN DROP UNUSED LEVELS
          DO M=1,MSUM                   !MSUM=0 IF .NOT.BUNA
            IF(IWRK2(M).EQ.0)THEN
              II=IWRK6(M)
              IWRK3(II)=-IWRK3(II)
              NSKP=NSKP+1
            ENDIF
          ENDDO
        ENDIF
!
  550   IF(BKUTDSK)THEN     !NOW SAFE TO UPDATE NADRU TO DISK RECORD
!
          IF((MODE.NE.2.OR.ICC.LE.0).and..NOT.BKUTLS)THEN
!
            DO N=1,NCJ
              NADRUJ(LL+N)=N
            ENDDO
!
          ELSE
!
            DO N=1,NSUB0
!
              NN=LL+NVEC(N)
              NADRUJ(NN)=N
!
            ENDDO
!
          ENDIF
!
        ENDIF
!
      ENDDO                                                 !END JP LOOP
!
! ******* END LOOP OVER SYMMTERY BLOCKS FOR H DIAGONALIZATION AND AUGERS
!
      if(btime)then
!par        if(iam.ge.0)then                                        !par
!par          write(iwp,*)'proc',iam,' for diagfs:'                 !par
!par          write(iwp,*)'    H diag time=',nint(timeh),'sec'      !par
!par          if(mode.eq.2)write(iwp,*)                             !par&
!par     &                '    auger time=',nint(timea),'sec'       !par
!par          call flush(iwp)                                       !par
!par        else                                                    !par
        if(btimet)write(iw,*)'H form time=',nint(timefh),'sec'
        write(iw,*)'H diag time=',nint(timeh),'sec'
        if(btimet.and.mode.eq.2)then
          write(iw,*)'auger timea1=',nint(timea1),'sec'
          write(iw,*)'auger timea2=',nint(timea2),'sec'
        endif
        if(mode.eq.2)write(iw,*)'auger time=',nint(timea),'sec'
!par        endif                                                   !par
      endif
!
      IF(IADJ8.NE.NP8)THEN                   !REMOVE EVNTLY
        WRITE(MW0,*)'SR.DIAGFS GLOBAL INDEX ERROR:',IADJ8,NP8
        GO TO 2000                                !RETURN
      ENDIF
!
      NENERG=NCI
!      write(mw0,*)nctot
      jupe=nenerg
      if(idw.eq.0)jupe=min(jupe,jupmx)
!
      DD00=DMIN                              !HOLD FS VALUE
      DG00=DECORE+DD00                       !GROUND LEVEL ENERGY (A.U.)
!
      j0=0
      if(ishftic.lt.0.and.itec.le.1)j0=2
!
      IF(j0.ne.0.and.nobsj.gt.0)THEN              !DETERMINE POST LEC
        DO I=1,NENERG
          IF(DELEIC(I,2).GE.DZERO)THEN            !.NE.
            TC=DELEIC(I,2)-DENERG(I)+DMIN
            DENERG(I)=DELEIC(I,2)+DMIN
            DELEIC(I,1)=TC
          ENDIF
        ENDDO
      ENDIF
!
! SORT ENERGIES: JORIG(J) MAPS ENERGY ORDER BACK TO SYMMETRY ORDER
!                ALSO PASSED TO SR.CASC IF NEED BE.
!
      ALLOCATE(JORIG(NENERG),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DIAGFS: ALLOCATION FAILS FOR JORIG'
        NF=0
        GO TO 1100
      ENDIF
!
      IF(DMAX.GT.DZERO)THEN                       !e.g.LPS
        DO L=1,NENERG
          DENERG(L)=DENERG(L)-DMAX
        ENDDO
      ENDIF
!
!
      CALL HPSRTI(NENERG,DENERG,JORIG)
!
!
      IF(DMAX.GT.DZERO)THEN                       !e.g.LPS
        DO L=1,NENERG
          DENERG(L)=DENERG(L)+DMAX
        ENDDO
      ENDIF
!
! shift whole config based-on lowest level energy
!
!      if(ishftic.gt.1)j0=2          !currently, no iteration if nobsj<0
      IF(j0.ne.0.and.nobsj.lt.0)then            !need to convert from cf
!
        do k=1,kmax
          iharry(k)=1
        enddo
        do l=1,nenerg                           !find lowest level of cf
          i=jorig(l)
          m1=nrr(i)
          k=nfk(m1)
          k=abs(k)
          btest1=iharry(k).gt.0
          btest2=delecf(k,2).ge.dzero
          btest3=iwrk4(i).ne.0
          if(btest1.and.btest2.and.btest3)then
            t=delecf(k,2)-denerg(i)+dmin
            delecf(k,1)=t
            iharry(k)=0                         !flag cf found
          endif
        enddo
!
        do i=1,nenerg
          m1=nrr(i)
          k=nfk(m1)
          k=abs(k)
          t=delecf(k,1)
          if(t.ne.dzero.and.iwrk4(i).ne.0)then
            denerg(i)=denerg(i)+t
            deleic(i,2)=denerg(i)-dmin
            deleic(i,1)=t
          endif
        enddo
!
        if(dmax.gt.dzero)then                   !unlikely
          do l=1,nenerg
            denerg(l)=denerg(l)-dmax
          enddo
        endif
!
        call hpsrti(nenerg,denerg,jorig)        !re-sort
!
        if(dmax.gt.dzero)then                   !unlikely
          do l=1,nenerg
            denerg(l)=denerg(l)+dmax
          enddo
        endif
!
      endif
!
      IF(BTEC)GO TO 700
!
      DO K=1,KMAX
        IHARRY(K)=ABS(QN(QCG(NF,K)))
      ENDDO
!                                                  !SUMMED AND NO B-B
      IF(BUNA.AND.BUNR.AND.(JRAD.EQ.2.OR.JRAD.EQ.3.OR.JRAD.EQ.5))THEN
        ITESTN=ABS(NRSLMX)
        DO J=1,NENERG
          I=JORIG(J)
          IF(IWRK4(I).NE.0)THEN
            DRY=DENERG(I)+DECORE
            DRY=DRY+DRY
            IF(DRY.LT.EIONMN)THEN                    !BOUND
              IT=NRR(I)
              K=NFK(IT)
              IF(NRSLMX.GE.0)THEN      !N-VALUE
                ITESTH=IHARRY(K)
              ELSE                     !CFG NO.
                ITESTH=K
              ENDIF
              IF(J.GT.JLOWMX.OR.ITESTH.GT.ITESTN)THEN
                                                     !UNRESOLVED
                IF(IWRK3(I).GE.0)THEN
                  NSKP=NSKP+1
                  IWRK3(I)=-1
!                else
!                  write(mw6,*)'correlation, already flagged'
                ENDIF
              ENDIF
            ELSE
              GO TO 600                              !WE ARE DONE
            ENDIF
!          else
!            write(mw6,*)'iwrk3, already flagged'
          ENDIF
        ENDDO
      ENDIF
!
! PRELIMINARY WRITES
!
  600 IF(.NOT.BFOTJ)THEN
        IF(BPRNT0)THEN
          WRITE(MW18,10270)MENG,NZION,MION,EIONMN
          WRITE(MW18,10280)(DTWO*DYY(M8),M8=1,MENG)
          IF(BDOWN.and.BUNPR)THEN
            WRITE(MW18,10260)NZION,MION
          ELSE
            WRITE(MW18,10290)NZION,MION
          ENDIF
        ELSE
          WRITE(MW30)int(MENG),int(NZION),int(MION),EIONMN
          WRITE(MW30)(DTWO*DYY(M8),M8=1,MENG)
          WRITE(MW30)int(NZION),int(MION)
          WRITE(MW30)MBLK
        ENDIF
      ENDIF
      IF(.NOT.BMODE)THEN
        IF(BPRNT0)THEN
          WRITE(MW8,10160)EIONMN
        ELSE
          WRITE(MW28)int(IZERO),int(IZERO),int(IZERO),int(IZERO),       &
     &               int(IZERO),DZERO,DZERO,EIONMN
        ENDIF
      ENDIF
!
      IF(BPRNT0)WRITE(MW6,10790)DCR1,DECORE,DR12
      IF(BAUGER.AND.BPRNT0)WRITE(MW6,10760)LUMAX,MXAAK
      if(lumax.ne.ixaak)write(mw0,*)'lumax,ixaak:',lumax,ixaak
      IF(.NOT.BRAD.AND.BJUMP)GO TO 1100
!
      IF(.NOT.BMODE)THEN
        IF(BPRNT0)THEN
          WRITE(MW8,10230)NENERG-NSKP,2*DG00
        ELSE
          WRITE(MW28)int(NENERG-NSKP),2*DG00
          WRITE(MW28)MBP             !ANY NON-BLANK FLAG
        ENDIF
      ENDIF
!
      IF(BTCC)THEN
        IF(BAUXE)WRITE(MW6,10020)
        IF(.NOT.BLMOD)WRITE(MW6,10460)
        MJX=MAX(MJX,NTRAN)
        IF(MJX.GT.IAXTR)THEN
          WRITE(MW6,10450)MJX
          WRITE(MW0,*)'*** TOO MANY TCCs, INCREASE MAXTR ***'
        ENDIF
        CALL DIMUSE('MAXTR',MJX)
      ENDIF
!
      IF(BPRNT0)THEN
        KO=0
        IF(ISHFTIC.GT.1)KO=ISHFTIC
        IF(IOPTIM.GT.0)KO=NOBSJ
        IF(KO.NE.0)THEN
          WRITE(MW6,10900)LABW,2*DG00,NTEC,KO,MOBS
        ELSE
          WRITE(MW6,10900)LABW,2*DG00,NTEC
        ENDIF
        IF(ABS(ISHFTIC).EQ.1)WRITE(MW6,10950)
      ENDIF
      IF(MODE.EQ.1.AND.IUNIT(MRW15).GT.0)WRITE(MRW15,10070)
!
      IF(IUNIT(MW22).GT.0)WRITE(MW22,10310)      !NENERG need NSPECE now
!
      IF(MENGB.GE.-1)THEN
        ELEM=CELMNT(NZION)
        NZAM=NZA-1
        FIP=ADASIP(ELEM,NZAM)
        if(badas)then
          lab4='    '
        else
          lab4='(0Y)'
        endif
        WRITE(MRW26,10330)ELEM,NZAM,NZION,NZA,FIP,lab4
        ISMX=0
        DO K=1,KMAX                             !CHECK MAX STRING LENGTH
          IS=4*LMX(K)
          ISMX=MAX(ISMX,IS)
        ENDDO
        IF(ISMX.GT.MXSTRG)THEN                   !THIS IS A FORMAT ISSUE
          WRITE(MW6,*)                                                  &
     &              '***SR.DIAGON: adf04 CONFIGURATION STRING TRUNCATED'
          WRITE(MW0,*)                                                  &
     &              '***SR.DIAGON: adf04 CONFIGURATION STRING TRUNCATED'
        ENDIF                                !NOT A DIMENSION ONE PER SE
        MSTRG4=MXSTRG/4                       !MXSTRG IS A MULTIPLE OF 4
      ENDIF
!
  700 CONTINUE
!
!********************************************
!
! WRITE ENERGY-ORDERED LEVEL LIST
!
!********************************************
!
      TIMXIC=etest-2*DG00                            !RYD REL. TO GROUND
!
      IF(JTEC.GT.0)THEN
        JTEC=JTEC-1                               !DECREMENT LEC COUNTER
        IF(BPRNT0)THEN
          JC=ISHFTIC-JTEC
          IF(JTEC.GT.0)THEN
            WRITE(MW6,10900)LABW,2*DG00,NTEC,JC
            IF(JTEC.EQ.1)NTEC=' FINAL LEC'
          ENDIF
        ENDIF
      ENDIF
!
      IF(BINCF)THEN
        IF(INCLUD.GT.KMAX)INCLUD=KMAX         !INCLUD IS CONFIG RESOLVED
      ELSE
        IF(INCLUD.GT.NENERG)INCLUD=NENERG       !INCLUD IS TERM RESOLVED
      ENDIF
!
      DFFS=DZERO                           !INITIALIZE FUNCTIONAL ENERGY
      IF(IOPTIM.NE.0)THEN
        DS0=DONE                           !INITIALIZE FUNCTIONAL WEIGHT
        DAU0=DZERO
      ELSE
        DS0=DZERO                          !INITIALIZE FUNCTIONAL WEIGHT
        DAU0=DD00
      ENDIF
!
      IF(IOPTIM.EQ.2)THEN
        DFC=DZERO
        J=JTMIN
        IF(DELEIC(J,2).NE.DZERO)THEN                         !NOT GROUND
          DO J=1,NENERG
            IF(DELEIC(J,2).EQ.DZERO)GO TO 720
          ENDDO
          WRITE(MW6,*)'***SR.DIAGFS: GROUND LEVEL NOT FOUND IN SHFTIC'
          WRITE(MW0,*)'***SR.DIAGFS: GROUND LEVEL NOT FOUND IN SHFTIC'
          GO TO 2000
  720     WRITE(MW6,*)'***SR.DIAGFS: GROUND LEVEL MIS-MATCH:',J,JTMIN
          WRITE(MW0,*)'***SR.DIAGFS: GROUND LEVEL MIS-MATCH'
          GO TO 2000
        ENDIF
        IF(DG00.GT.EFLGJ0)DFC=DG00-EFLGJ0                          !A.U.
      ENDIF
!
      DO I=1,NTT
        WGT(I)=DZERO
        ETM(I)=DZERO
      ENDDO
!
      if(nmetaj/jaxlv.gt.0)then
        nmetaj=0
        m10=nrr(jtmin)
      else
        m10=0
      endif
!
! LIST DEGENERATE LEVELS BY ASCENDING LV INDEX
! (NEEDED FOR BUNDLED PI CONTINUUM SUM WITHIN SYMMETRY GROUP,
!  SINCE RADIATIVE LOOP IS EO NOT SO. ELSE COSMETIC)
!
      IF(BCONT.AND.(BPRNT0.OR.BUNPA))THEN
        J0=1
        m1p=0
        DECMIN=-D1P20
  750   MSUM=1
        DO J=J0,NENERG
          I=JORIG(J)
          M1=NRR(I)                                                !A.U.
          IF(NFK(M1).LT.0.AND.DENERG(I).LT.DECMIN+TOLB2.AND.m1p.LT.0)   &
     &       THEN
            MSUM=MSUM+1
            m1p=nfk(m1)
          ELSE
            m1p=nfk(m1)
            IF(MSUM.GT.1)GO TO 800
          ENDIF
          DECMIN=DENERG(I)
        ENDDO
        J=NENERG+1
!
  800   DECMIN=DENERG(I)
        if(bunpa)t=denerg(jorig(j-msum))       !-msum = first; -1 = last
        DO M=MSUM,1,-1
          I=JORIG(J-M)
          DWRK(M)=I
          if(bunpa)denerg(i)=t
        ENDDO
!
        CALL HPSRTI(MSUM,DWRK,IWRK2)
!
        DO M=1,MSUM
          I=IWRK2(M)
          I=NINT(DWRK(I),SP)
          JORIG(J-M)=I
        ENDDO
        IF(J.LT.NENERG)THEN
          J0=J+1
          GO TO 750
        ENDIF
      ENDIF
!
! BEGIN LEVEL ENERGY LOOP
!
      M2=0
      IPP=0
      JSP=0
      LSP=0
      IE0=0
      NSPECE=0
      EMIN=EIONPOT
      IF(EMIN.GT.DZERO)THEN
        IAUTO=0
      ELSE
        IAUTO=-1
      ENDIF
      DECMIN=-D1P20
      m1p=0
      NMM=0
!
      DO K=1,KMAX
        E1BCF(K)=DZERO      !HOLD STAT.WEIGHTED MEAN ENERGY, I.E. A "CA"
      ENDDO
!
      DO J=1,NENERG
!
        I=JORIG(J)                              !J=EO -> I=SO
        M1=NRR(I)
        M2=MAX(M1,M2)                          !=NNRGLS EVNTLY
        MWJ=ABS(NFK(M1))
        II=NFQ(M1)
        LP2=QLI(II)/2
        ISS=(QSI(II)+1)
        IP=ISS*(1-QPI(II))
!
        E1BCF(MWJ)=E1BCF(MWJ)+(JN(I)+1)*DENERG(I)           !"CA" ENERGY
!
        DENERG(I)=DENERG(I)-DD00                !RELATIVE TO GROUND
        DRY=DENERG(I)*DTWO
        DEM=DRY*DKCM
        DS=JN(I)+1
        ETM(M1)=DRY*DS+ETM(M1)
        WGT(M1)=WGT(M1)+DS
!
        IF(JTEC.GT.0)THEN                       !DETERMINE LEC
          IF(DELEIC(I,2).GE.DZERO)THEN          !.NE.
            TC=DELEIC(I,2)-DENERG(I)
            DELEIC(I,1)=DELEIC(I,1)+TC
          ELSE
            TC=DZERO
          ENDIF
          IF(BPRNT0)WRITE(MW6,10920)J,I,M1,DEM,IP,LP2,JN(I),NFK(M1),    &
     &                              MBLK,DRY,2*TC
        ENDIF
!
        IF(BTEC)GO TO 900
!
        IF(NFK(M1).GT.0)NMM=NMM+1
!
        IF(IWRK3(I).LT.0)THEN
          MWR=-I
        ELSE
          MWR=I
        ENDIF
        IP2=QPI(II)/2
!                                   default to levels of the ground term
        if(m1.eq.m10)nmetaj=nmetaj+1
!
!        IF(IDIAG.GE.0.AND.ABS(NFK(M1)).GT.NCUT             !CORRELATION
        IF(IWRK4(I).LE.0.OR.BECOR.AND.                                  &
     &     (DRY*ECORRJ.GT.ECORRJ*ECORRJ.OR.DRY.GT.ESKPL.AND.            &
     &     DRY.LT.ESKPH))THEN                               !CORRELATION
          JORIG(J)=-I
          IF(IWRK4(I).EQ.0)THEN
            MBCOR=MSCOR
          ELSE
            MBCOR=MCOR
          ENDIF
        ELSE
          JORIG(J)=I
          MBCOR=MBLK
          if(j.le.jupe)NSPECE=NSPECE+1
        ENDIF
!
        DO K=1,J
          IK=ABS(JORIG(K))
          IF(JN(IK).EQ.JN(I))THEN
            M3=NFQ(NRR(IK))
            IF(QPI(M3).EQ.QPI(II))THEN          !OVERWRITE IWRK4(I) WITH
              IWRK4(I)=K !ENERGY ORDER POSN OF FIRST OCCURRENCE OF SYM I
              GO TO 850
            ENDIF
          ENDIF
        ENDDO
!
  850   IF(IAUTO.GE.0.AND.DENERG(I)-EMIN.LE.TOLE)IAUTO=J+1
        IF(NFK(M1).LT.0.AND.IAUTO.LT.0)THEN
          IAUTO=J
          EMIN=DENERG(I)
        ENDIF
!
        IF(IOPTIM.EQ.2)THEN                    !ADD TO ENERGY FUNCTIONAL
          IF(DELEIC(I,2).GT.DZERO.AND.JORIG(J).GT.0)THEN
            IF(ABS(IWGHT).EQ.2)THEN                !STATISTICAL WEIGHTED
              DD=JN(I)+1
              DDW=DD
              IF(IWGHT.LT.0)DD=DD/MSTAT(MWJ)        !/CF TOT STAT WEIGHT
            ENDIF
            IF(ABS(IWGHT).EQ.1)THEN                      !EQUAL WEIGHTED
              DD=DONE
              DDW=DD
              IF(IWGHT.LT.0)DD=DD/NTJ(MWJ)             !NO. LEVELS IN CF
            ENDIF
            DF0=(ABS(DELEIC(I,2)-DENERG(I))+DFC)/DELEIC(I,2)
            DFFS=DFFS+DF0*DD                         !*DF0
          ELSE                             !IF(DELEIC(I,2).EQ.DZERO)THEN
            DDW=DZERO
          ENDIF
        ENDIF
!
        IWRK2(I)=0
        MYRGE=MBLK
        IF(NFK(M1).LT.0)THEN
          IF(DRY.gt.DECMIN+TOLB.or.m1p.gt.0)IE0=IE0+1    !.or.prev bound
          IF(DRY.LE.TIMXIC)JIMXIC=IE0
          IWRK2(I)=IE0                             !CONT ENERGY INDEX
        ELSEif(m1p.gt.0)then                             !both bound
          IF(DRY.LT.DECMIN+TOLB.and.bmyrge)THEN
!              LSP.EQ.LP2.AND.                !NOT GOOD QU.NO. - REMOVE?
            IF(LSP.EQ.LP2.AND.IPP.EQ.IP2)THEN !NOT ACTIVATED IN PRACTICE
              MYRGE='****'
              IF(IUNIT(MRW15).GT.0)BACKSPACE(MRW15)
              JSP=JSP+JN(I)
              ISP=ISP+IP-1
            ENDIF
          ENDIF
        ENDIF
        IF(MYRGE.EQ.MBLK)THEN
          ISP=IP
          JSP=JN(I)
        ENDIF
        IPP=IP2
        LSP=LP2
        m1p=nfk(m1)
        IF(MBCOR.EQ.MBLK)DECMIN=DRY
        IF(BUNA.AND.IWRK2(I).GT.JIMXIC)IP=0
!
        IF(.NOT.BMODE.AND.MWR.GT.0)THEN
          IF(BPRNT0)THEN
            if(nfk(m1).gt.0)then
              WRITE(MW8,10240)J,JORIG(J),M1,IP,LSP,JN(I),NFK(M1),DRY
            else
              WRITE(MW8,10240)J,JORIG(J),M1,IP,LSP,JN(I),NFK(M1),DRY,   &
     &                        iwrk2(i)
            endif
          ELSE
            WRITE(MW28)int(JORIG(J)),int(M1),int(IP),int(LSP),int(JN(I))&
     &                 ,int(NFK(M1)),DRY,int(iwrk2(i))
          ENDIF
        ENDIF
!
        IF(BPRNT0)THEN
          IF(ISHFTIC.GT.1)THEN
            WRITE(MW6,10920)J,I,M1,DEM,IP,LSP,JN(I),NFK(M1),MBCOR,DRY,  &
     &                      2*DELEIC(I,1)
          ELSE
            IFLAG2=0
            IF(IOPTIM.EQ.2)THEN                     !BREAK FOR NON-ALLOC
              IF(DELEIC(I,2).GE.DZERO)IFLAG2=2                     !.NE.
            ENDIF
            IF(IFLAG2.EQ.2)THEN
              T=DELEIC(I,2)
              TC=T-DENERG(I)
              IF(J.EQ.1)THEN
                T=EFLGJ0
                TC=TC-DG00+T
              ENDIF
              IWD=MAX(NINT(DDW,SP),IONE)
              WRITE(MW6,10820)J,I,M1,DEM,IP,LSP,JN(I),NFK(M1),MBCOR,IWD,&
     &                        DRY,2*TC,2*T
            ELSE
              if(nfk(m1).gt.0)then
                WRITE(MW6,10920)J,I,M1,DEM,IP,LSP,JN(I),NFK(M1),MBCOR,  &
     &                          DRY
              else
                WRITE(MW6,10940)J,I,M1,DEM,IP,LSP,JN(I),NFK(M1),MBCOR,  &
     &                          DRY,iwrk2(i)
              endif
            ENDIF                                               !NO CORR
          ENDIF
!        else
!         write(mw6,997)j,i,m1,dem,ip,lsp,jn(i),nfk(m1),mbcor,dry!unsort
        ENDIF
        IF(MODE.EQ.1.AND.JORIG(J).GT.0.AND.IUNIT(MRW15).GT.0.AND.       &
     &     ISHFTIC.LE.1)WRITE(MRW15,10840)JSP,IPP,ISP,LSP,NFK(M1),NFJ(I)&
     &                                    ,DRY,MYRGE
!
        IF(MENGB.GE.-1.and.JORIG(J).GT.0.and.j.le.jupe)THEN     !NO CORR
          LSP=MIN(LSP,MXLAB2)
          ISS=MIN(ISS,MXLAB2)
          FJT=JN(I)
          FJT=FJT/DTWO
          K=ABS(NFK(M1))
          LMXK=LMX(K)
          IF(LMXK.LE.MSTRG4)THEN
            L1=1
          ELSE                    !TRUNCATE AS TOO LONG FOR ADF04 FORMAT
            L4=LMXK-MSTRG4
            L1=L4+1
          ENDIF
          L2=4*(L1-1)+1           !+2
          IS=0
          DO L=L1,LMXK
            JJK=ABS(QN(QLB(L,K)))
            IF(JJK.GT.999)THEN
              IS=IS+1
              J1000=JJK/1000
              STRING(IS)=NUMB(J1000)
              JJK=JJK-J1000*1000
            ENDIF
            IF(JJK.GT.99)THEN
              IS=IS+1
              J100=JJK/100
              STRING(IS)=NUMB(J100)
              JJK=JJK-J100*100
            ENDIF
            IS=IS+1
            IF(JJK.GT.9)THEN
              J10=JJK/10
              STRING(IS)=NUMB(J10)
              JJK=JJK-J10*10
            ELSE
              STRING(IS)=' '
            ENDIF
            IS=IS+1
            STRING(IS)=NUMB(JJK)
            IS=IS+1
            JJK=MIN(INT(QL(QLB(L,K))/2,SP),MXLAB1)
            STRING(IS)=BIGL(JJK)
            IS=IS+1
            N=MOD(INT(QSB(L,K),SP),I50)
            STRING(IS)=NUMB(N)
          ENDDO
          DO L=IS+1,MXSTRG
            STRING(L)=' '
          ENDDO
          if(badas)then                                      !adf04 only
            if(iunit(MRW26).gt.0)then
              cstan=' '
              ceiss=' '
              if(ismx.le.mstrgh)then
                f542="(i5,1a16,2x,' (',a1,')',a1,'(',f4.1,')',f21.4)"
                write(cstan(1:16),'(16a1)')(string(l),l=1,mstrgh)
                call xxcftr(ione,cstan,ceiss)
                IF(IUNIT(MRW26).GT.0)WRITE(MRW26,f542)nspece,ceiss(1:16)&
     &                                     ,numb(iss),numb(lsp),fjt,dem
              else
                f543="(i5,1a32,2x,' (',a1,')',a1,'(',f4.1,')',f21.4)"
                write(cstan(1:32),'(31a1)')(string(l),l=l2,mxstrg)
                call xxcftr(ione,cstan,ceiss)
                IF(IUNIT(MRW26).GT.0)WRITE(MRW26,f543)nspece,ceiss(1:32)&
     &                                     ,numb(iss),numb(lsp),fjt,dem
              endif
            endif
          else                                 !adf04 or adasexj.in.form
            IF(ISMX.LE.MSTRGH)THEN
              F542="(I5,16(A1),2X,' (',A1,')',A1,'(',F4.1,')',F21.4)"
              IF(IUNIT(MW22).GT.0)WRITE(MW22,F542)NSPECE,               &
     &                                  (STRING(L),L=1,MSTRGH),NUMB(ISS)&
     &                                  ,NUMB(LSP),FJT,DEM
              IF(IUNIT(MRW26).GT.0)WRITE(MRW26,F542)NSPECE,             &
     &                                   (STRING(L),L=1,MSTRGH),        &
     &                                   NUMB(ISS),NUMB(LSP),FJT,DEM
            ELSE
              F543="(I5,32(A1),2X,' (',A1,')',A1,'(',F4.1,')',F21.4)"
              IF(IUNIT(MW22).GT.0)WRITE(MW22,F543)NSPECE,               &
     &                                  (STRING(L),L=L2,MXSTRG),        &
     &                                  NUMB(ISS),NUMB(LSP),FJT,DEM
              IF(IUNIT(MRW26).GT.0)WRITE(MRW26,F543)NSPECE,             &
     &                                   (STRING(L),L=L2,MXSTRG),       &
     &                                   NUMB(ISS),NUMB(LSP),FJT,DEM
            ENDIF
          endif
        ENDIF
!
  900   IF(BPRNT0.AND.ABS(ISHFTIC).EQ.1)THEN
          IF(DELEIC(I,1).NE.DZERO)THEN
            DRY=DELEIC(I,1)*DTWO
            DEM=DRY*DKCM
            WRITE(MW6,10870)I,DEM,DRY
          ENDIF
        ENDIF
!
      ENDDO
!
      IF(IAUTO.LE.0)IAUTO=NENERG+1
!
!  *** END ENERGY WRITE LOOP
!
!
! FORM WEIGHTED MEAN OF FS-LEVELS TO YIELD TERM ENERGIES
!
      LL=0
      IF(.NOT.BMODE.AND.(.NOT.BCONT.OR.BPRNT0))THEN         !.AND.BPRNT5
!
        ITEC=ITEC-1                               !DECREMENT TEC COUNTER
        DMIN=D1P20
        LL=-INCLUD
        ITMIN=0
!
        DO IT=1,M2
          IF(WGT(IT).GT.DZERO)THEN
            ETM(IT)=ETM(IT)/WGT(IT)
!          write(mw6,*)it,etm(it),wgt(it)
!          if(nint(wgt(it),sp).ne.(qli(it)+1)*abs(qsi(it)+1))then
!         write(mw6,*)'*** sr./diagfs: mis-match of level/term weights:'
!     &               it,nint(wgt(it),sp),(qli(it)+1)*abs(qsi(it)+1)
!          endif
            IF(DMIN.GT.ETM(IT))THEN
              DMIN=ETM(IT)
              ITMIN=IT
            ENDIF
          ELSE
            ETM(IT)=D1P20
          ENDIF
        ENDDO
!
        DMIN=DMIN/DTWO
        DG0=DG00+DMIN                         !GROUND TERM ENERGY (A.U.)
!
        IF(IOPTIM.EQ.-2)THEN
          DFC=DZERO
          J=ITMIN
          IF(DELELS(J,2).NE.DZERO)THEN                       !NOT GROUND
            DO J=1,M2
              IF(DELELS(J,2).EQ.DZERO)GO TO 910
            ENDDO
            WRITE(MW6,*)'***SR.DIAGFS: GROUND TERM NOT FOUND IN SHFTLS'
            WRITE(MW0,*)'***SR.DIAGFS: GROUND TERM NOT FOUND IN SHFTLS'
            GO TO 2000
  910       WRITE(MW6,*)'***SR.DIAGFS: GROUND TERM MIS-MATCH:',J,ITMIN
            WRITE(MW0,*)'***SR.DIAGFS: GROUND TERM MIS-MATCH'
            GO TO 2000
          ENDIF
          IF(DG0.GT.EFLG0)DFC=DG0-EFLG0
        ENDIF
!
        IF(BPRNT0)THEN
          IF(ITEC.EQ.0.AND.ISHFTLS.GT.1)MTEC=' FINAL TEC'
          IC=0
          IF(ITEC.GE.0)IC=ISHFTLS-ITEC
          IF(IOPTIM.LT.0)IC=NOBS
          IF(IC.GT.0)THEN
            WRITE(MW6,10830)2*DG0,MTEC,IC,MOBS
          ELSE
            WRITE(MW6,10830)2*DG0,MTEC
          ENDIF
        ENDIF
!
! WRITE TERM ENERGIES IN ENERGY ORDER
!
        IKOW=0
        DO I=1,M2
!
          DRY=D1P20
          DO II=1,M2
            IF(ETM(II).LT.DRY)THEN
              IT=II
              DRY=ETM(II)
            ENDIF
          ENDDO
          IF(DRY.EQ.D1P20)GO TO 1000                        !NONE LEFT
!
          DAU=DRY/DTWO                                      !RYD -> A.U.
          ETM(IT)=D1P20
!
          MWJ=ABS(NFK(IT))
          II=NFQ(IT)
          IP=(1-QPI(II))*(QSI(II)+1)
          L=QLI(II)/2
!
          MBCOR=MBLK
          IF(IDIAG.GE.0.AND.MWJ.GT.NCUT.OR.BECOR.AND.                   &
     &       (DRY*ECORRJ.GT.ECORRJ*ECORRJ.OR.DRY.GT.ESKPL.AND.          &
     &       DRY.LT.ESKPH))THEN                             !CORRELATION
            MBCOR=MCOR
          ELSE
            IKOW=IKOW+1
          ENDIF
!
          DD=DZERO
          DDW=DD
!
! LL=-INCLUD
          IF(LL.EQ.0)GO TO 940
!
          IF(LL.GT.0)THEN
            IF(BINCF)THEN
              IMATCH=NFK(IT)
            ELSE
              IMATCH=IT
            ENDIF
            DO K=1,LL
              IF(INDEXW(K).EQ.IMATCH)THEN
                DD=WGHT(K)
                DDW=DD
                GO TO 920   !WILL INCLUDE CORRELATION IF USER FLAGS SUCH
              ENDIF
            ENDDO
            IF(IOPTIM.EQ.0)GO TO 940
          ENDIF
!
          IF(BINCF)IKOW=NFK(IT)
          IF(IKOW.GT.INCLUD.AND.IOPTIM.EQ.0)GO TO 940           !IKOW<-I
!
          IF(MBCOR.EQ.MCOR)GO TO 940    !OMIT CORR. FROM DF FOR INCLUD>0
!
! WEIGHT ENERGY FOR FUNCTIONAL:
!(N.B.IWGHT.LT.0 FORMS THE ARITHMETIC MEAN OF THE CONFIG WEIGHTED MEANS)
!
! STATISTICAL FS-AV TERM-WEIGHTED MEAN
!
          IF(ABS(IWGHT).EQ.2)THEN
            DD=WGT(IT)
            DDW=DD
            IF(IWGHT.LT.0)DD=DD/MSTAT(MWJ)           !CF TOT STAT WEIGHT
          ENDIF
!
! EQUAL (FS-AV) TERM-WEIGHTED (ARITHMETIC) MEAN
!
          IF(ABS(IWGHT).EQ.1)THEN
            DD=DONE
            DDW=DD
            IF(IWGHT.LT.0)DD=DD/(NTG(MWJ)-NTG(MWJ-1))   !NO. TERMS IN CF
          ENDIF
!
! ADD TO ENERGY FUNCTIONAL (HERE, ANY AND ALL CORRELATION IS OMITTED)
!
  920     IF(IOPTIM.EQ.0)THEN                                  !STANDARD
            DFFS=DFFS+DAU*DD
            DS0=DS0+DD
          ELSE                                            !DIFF WITH OBS
            IF(IOPTIM.EQ.-2)THEN                                  !TERMS
              IF(DELELS(IT,2).GT.DZERO)THEN
                DF0=(ABS(DELELS(IT,2)-DAU+DMIN)+DFC)/DELELS(IT,2)
                DFFS=DFFS+DF0*DD
              ELSEIF(DELELS(IT,2).EQ.DZERO)THEN
                DDW=DZERO
              ENDIF
            ELSE
              DDW=DZERO
            ENDIF
          ENDIF
!
  940     DRY=(DAU-DMIN)*DTWO
          DEM=DRY*DKCM
          IF(ITEC.GT.0.OR.IOPTIM.LT.0)THEN
            IF(DELELS(IT,2).GE.DZERO)THEN                    !UPDATE TEC
              T=DELELS(IT,2)
              TC=T-DAU
              IF(IOPTIM.EQ.0)THEN
                DELELS(IT,1)=DELELS(IT,1)+TC
                IF(BPRNT0)WRITE(MW6,10880)I,IT,DEM,IP,L,NFK(IT),MBCOR,  &
     &                                    DDW,DRY,2*TC
              ELSE
                IF(I.EQ.1)THEN
                  T=EFLG0
                  TC=TC-DG0+T
                ENDIF
                IF(BPRNT0)WRITE(MW6,10880)I,IT,DEM,IP,L,NFK(IT),MBCOR,  &
     &                                    DDW,DRY,2*TC,2*T
              ENDIF
            ELSE
              IF(BPRNT0)WRITE(MW6,10880)I,IT,DEM,IP,L,NFK(IT),MBCOR,DDW,&
     &                                  DRY
            ENDIF
          ELSE
            IF(BPRNT0)THEN
              IF(ISHFTLS.GT.1)THEN
                WRITE(MW6,10880)I,IT,DEM,IP,L,NFK(IT),MBCOR,DDW,DRY,    &
     &                          DELELS(IT,1)*2
              ELSE
                WRITE(MW6,10880)I,IT,DEM,IP,L,NFK(IT),MBCOR,DDW,DRY
              ENDIF
            ENDIF
          ENDIF
!
        ENDDO                                      !END TERM ENERGY LOOP
!
      ENDIF
!
 1000 CONTINUE
!
! IF(BTEC)GO TO NEXT ITERATION
!
      IF(ITEC.GT.0.OR.JTEC.GT.0)GO TO 300
!
! WRITE SOME TERMINATORS
!
      IF(MODE.EQ.1.AND.IUNIT(MRW15).GT.0)WRITE(MRW15,10840)IZERO,IZERO, &
     &   IZERO,IZERO,IZERO,IZERO,2*DG00
!
      IF(IUNIT(MW22).GT.0)WRITE(MW22,10320)
!
! FINALIZE "CA" ENERGY
!
      DMAX=-D1P20
      DO K=1,KMAX
        DD=DTWO*E1BCF(K)/MSTAT(K)
        IF(DD.GT.DMAX)DMAX=DD
        E1BCF(K)=DD
      ENDDO
!
! local
      if(allocated(iwrkn))then
        deallocate(iwrkn)
      endif
      allocate(iwrkn(kmax),stat=ierr)
      if(ierr.ne.0)then
        write(mw0,*)'diagfs: allocation fails for iwrkn'
        nf=0
        go to 1100
      endif
!
      IF(DMAX.GT.DZERO)THEN                       !e.g.LPS
        DO K=1,KMAX
          E1BCF(K)=E1BCF(K)-DMAX
        ENDDO
      ENDIF
!
      CALL HPSRTI(KMAX,E1BCF,IWRKN)
!
      IF(DMAX.GT.DZERO)THEN                       !e.g.LPS
        DO K=1,KMAX
          E1BCF(K)=E1BCF(K)+DMAX
        ENDDO
      ENDIF
!
      DMIN=E1BCF(IWRKN(1))
!
! TBD WRITE TO ALT FILE,
!     ELSE JUST TO UNIT6 WHEN IWGHT.LT.0 (BUT ANY INCLUD)
!     FORM OR UNFORM, BUT NON-RYD ONLY - THIS COMBO MAY CHANGE.
!
      IF(IWGHT0.NE.0)THEN
        MRWXX=MRW15               !APPEND TO LEVELS, NOT SAFE FOR SCRIPT
      ELSE
        MRWXX=-1                        !TO UNIT6 ONLY
      ENDIF
!
      IF(MRWXX.GT.0)THEN
        IF(IUNIT(MRWXX).LE.0)MRWXX=-1   !NEED A UNIT
        IF(IWGHT.GE.0)MRWXX=-1          !NEED "CA" FLAG
        IF(MODE.NE.1)MRWXX=-1           !NEED NON-RYD
      ENDIF
      IF(MRWXX.GT.0)WRITE(MRWXX,10080)
!
      BWGHT=IWGHT.LT.0.AND.(BPRNT0.OR.INCLUD.EQ.0)
      IF(BWGHT)WRITE(MW6,10910)DMIN+2*DECORE
!
      DO K=1,KMAX
        K0=IWRKN(K)                               !EO -> SO
        M2=QCG(NF,K0)
        KW=K0
        MST=MSTAT(K0)
        IF(IYY(M2).GT.0)THEN
          M1=QL(M2)+1
          KW=-K0
          MST=MSTAT(K0)/(M1+M1)
        ENDIF
        DRY=E1BCF(K0)-DMIN
        DEM=DRY*DKCM
        MBCOR=MBLK
        IF(IDIAG.GE.0.AND.K0.GT.NCUT)THEN
          MBCOR=MCOR
        ELSEIF(MRWXX.GT.0)THEN
          ISP=MSTAT(K0)
          IPP=QCP(K0)/2
          WRITE(MRWXX,10850)ISP,IPP,K0,DRY
        ENDIF
        IF(BWGHT)WRITE(MW6,10930)K,K0,DEM,MST,KW,MBCOR,DRY
      ENDDO
!
      IF(MRWXX.GT.0)WRITE(MRWXX,10850)IZERO,IZERO,IZERO,DMIN+2*DECORE
!
! ALTERNATE FORM OF ENERGY FUNCTIONAL - ORIGINAL SS DIFFERENCE BETWEEN
! CALCULATED AND OBSERVED FS-AV TERM ENERGIES, RELATIVE TO GROUND IN CM,
! AND FLAGGED BY USER INPUT INDEXW .LT. 0, SO DS=0, ASSUMING IOPTIM=0.
!
      IF(DS0.EQ.DZERO)THEN
        DS0=DONE
        DAU0=DZERO
        DECORE=DZERO
        DO I=1,LL
          II=-INDEXW(I)
!          IF(II.EQ.0)II=IORIG(I)        !AS SR.DIAGON HAS SET IF NECESS
          T=ETM(II)*DKCM
          DO J=1,I
            JJ=-INDEXW(J)
!            IF(JJ.EQ.0)JJ=IORIG(J)
            TT=T-ETM(JJ)*DKCM
            DFFS=(TT-WGHT(I)+WGHT(J))**2+DFFS
          ENDDO
          IF(BAUX)WRITE(MW6,10890)I,T,WGHT(I),DFFS
        ENDDO
      ENDIF
!
! FINALIZE ENERGY FUNCTIONAL DFFS
!
      DFFS=DAU0+DFFS/DS0
!
! WRITE INFO TO DW PASSING FILE
!
      IF(IDW.NE.0)THEN                                          !DW DUMP
        WRITE(MRW10)NMETAJ                                       !4ALGX0
        WRITE(MRW10)(NMETGJ(I),I=1,NJO)                          !4ALGX0
        NNN=NENERG                                               !4ALGX0
        IF(BECOR)NNN=-NNN                                        !4ALGX0
        WRITE(MRW10)NNN,KCUT                                     !4ALGX0
        WRITE(MRW10)(JORIG(I),I=1,NENERG)                        !4ALGX0
        WRITE(MRW10)(DENERG(abs(JORIG(I)))*DTWO,I=1,NENERG)      !4ALGX0
        WRITE(MRW10)NCTOT                                        !4DWXBP
        WRITE(MRW10)(TFUJ(I),I=1,INT(NCTOT,SP))                  !4DWXBP
      ENDIF
!
! GET ANY CF'S PARTITION ABOUT IONIZATION LIMIT (ENERGIES AND WEIGHTS)
!
      IF(NMETAPJ.GT.0)THEN
        NMM=MIN(NMM,NMETAPJ)
      ELSE
        NMM=MIN(-NRSLMX,KMAX)
      ENDIF
!
! NEW LOCAL ALLOCATE
!
      IF(NMM.GT.0)THEN
        ALLOCATE(JCP(NMM),JTP(NMM),JWRN(NMM),JWRD(NMM),ERN(NMM),ERD(NMM)&
     &           )
      ENDIF
!
      IF(NMETAPJ.GT.0)THEN
!
        ALLOCATE(JRP(NENERG))
!
        J=0
        DO J0=1,NMETAPJ
          I=JORIG(J0)
          I=ABS(I)                                    !CASE CORR.
          M1=NRR(I)
          IF(NFK(M1).GT.0)THEN
            J=J+1
            JTP(J)=I
            JCP(J)=NFK(M1)
            JWRN(J)=JN(I)+1
            JWRD(J)=JWRN(J)
            ERN(J)=DENERG(I)+DG00
            ERN(J)=ERN(J)*2
            ERD(J)=ERN(J)
            NLASTP=J0
            IF(J.EQ.NMM)THEN                           !WE ARE DONE
              DO K=J0,NENERG
                JRP(K)=J
              ENDDO
              GO TO 1050
            ENDIF
          ENDIF
          JRP(J0)=J
        ENDDO
 1050   NMM=J                                          !ACTUAL FOUND
      ENDIF
!
      NMM0=NMM
!
      IF(NRSLMX.LT.0)THEN
        DO K=1,NMM
          JTP(K)=0
          JCP(K)=K
          ERN(K)=DZERO
          ERD(K)=DZERO
          JWRN(K)=0
          JWRD(K)=0
        ENDDO
        DO J=1,NENERG
          I=JORIG(J)
          I=ABS(I)                                    !CASE CORR
          M1=NRR(I)
          K=NFK(M1)
          IF(K*K.LE.NMM*K)THEN                         !OMITS K<0: CONT
            JW=JN(I)+1
            IF(DENERG(I).LT.EMIN)THEN
              ERN(K)=ERN(K)+DENERG(I)*JW
              JWRN(K)=JWRN(K)+JW
            ELSE
              ERD(K)=ERD(K)+DENERG(I)*JW
              JWRD(K)=JWRD(K)+JW
            ENDIF
          ENDIF
        ENDDO
        DO K=1,NMM
          IF(JWRN(K).GT.0)THEN
            ERN(K)=ERN(K)/JWRN(K)
            ERN(K)=ERN(K)+DG00
            ERN(K)=ERN(K)*2
          ENDIF
          IF(JWRD(K).GT.0)THEN
            ERD(K)=ERD(K)/JWRD(K)
            ERD(K)=ERD(K)+DG00
            ERD(K)=ERD(K)*2
          ENDIF
!          m=jwrn(k)+jwrd(k)
!          if(m.gt.0.and.k.le.ncut)then             !also needs nast=0
!            if(m.ne.mstat(k))then                     !checksum error
!              write(mw6,*)'cf=',k,' s.w. checksum error:',mstat(k),m
!              go to 2100
!            endif
!          endif
        ENDDO
      ENDIF
!
! WRITE TCCDW.DAT FILE
!
      IF(BTCC.AND.KTCC.GT.0.AND.MPNCH.LT.0.AND..NOT.BAUXE)THEN
!
        WRITE(MW4,10600)NSPECE,NENERG          !SPEC, TOT LEVEL ENERGIES
        J0=0
        DO J=1,NENERG                                       !IC PROLOGUE
          I0=JORIG(J)
          IF(I0.GT.0)THEN                              !SKIP CORRELATION
            I=ABS(I0)
            M1=NRR(I)
            II=NFQ(M1)
            J0=J0+1
!            J0=J
!            IF(I0.LT.0)J0=-J                          !FLAG CORRELATION
            WRITE(MW4,10590)J0,JN(I),QPI(II)/2,DTWO*DENERG(I),I,M1
          ENDIF
        ENDDO
!
        if(j0.ne.nspece)then
          write(mw6,*)'tcc index error',j0,nspece
          write(mw0,*)'tcc index error'
          go to 2000                                             !return
        endif
!
        WRITE(MW4,10550)                  !NOW ENERGY LEVEL ORDERED TCCS
        J0=0
        DO J=1,NENERG
          I0=JORIG(J)
          IF(I0.GT.0)THEN                              !SKIP CORRELATION
            I=ABS(I0)
            NTRAN=ID(I)
            NTRR=MIN(NTRAN,IAXTR)
            NTRAN0=ID(I-1)
            N1=NTRR-NTRAN0
            L2=MIN(N1,IFOUR)
            L2=L2+NTRAN0
            NTRAN0=NTRAN0+1
            DO KK=NTRAN0,NTRR        !GET ASCENDING ENERGY ORDERED TERMS
              JK=KK
              J1=JK-1
              IE=MMIKE(JK)
              DO IK=NTRAN0,J1
                IF(JK.GE.KK)THEN
                  NK=NMIKE(IK)
                  IF(IE.GT.MMIKE(NK))GO TO 1055
                ENDIF
                NMIKE(JK)=NMIKE(JK-1)
                JK=JK-1
 1055         ENDDO
              NMIKE(JK)=KK
            ENDDO
            J0=J0+1
!            J0=J
!            IF(I0.LT.0)J0=-J                          !FLAG CORRELATION
            WRITE(MW4,*)' '
            WRITE(MW4,10530)J0,N1,                                      &
     &                      (MMIKE(NMIKE(L)),DT(NMIKE(L)),L=NTRAN0,L2)
            IF(N1.GT.4)THEN
              WRITE(MW4,10540)(MMIKE(NMIKE(L)),DT(NMIKE(L)),L=L2+1,NTRR)
            ENDIF
          ENDIF
        ENDDO
      ENDIF
!
      IF(BCPRNT.AND.MPNCH.LT.0)THEN                     !CLOSE TCC FILES
        IF(KTCC.LT.0)THEN
          WRITE(MW1,"(9X,'0    0',5X,'TCC END')")
          CLOSE(MW1,STATUS='KEEP')
        ELSEIF(KTCC.GT.0)THEN
          CLOSE(MW4,STATUS='KEEP')
        ENDIF
      ENDIF
!
! DE-ALLOCATE
!
 1100 CONTINUE
!
! ex-common/nrbtmp/
      if(allocated(ncc0))then
        deallocate(ncc0,iorb,isxdk)
      endif
!
! DE-ALLOCATE OLD LOCAL
!
      IF(ALLOCATED(LMX))THEN
        DEALLOCATE(LMX,QSB,QLB,ICF)
      ENDIF
!
      deallocate(nal)
      if(allocated(iwrk5))deallocate(iwrk5)                  !iwrk5=test
!
      if(allocated(nadlu))then
        deallocate(nadlu)
      endif
      if(allocated(iwrkn))then
        deallocate(iwrkn)
      endif
      if(allocated(ncf))then
        deallocate(ncf,kmap,iwrk1,luj)
      endif
      if(allocated(decorn))then
        deallocate(decorn)
      endif
      if(allocated(iwrks))then
        deallocate(iwrks,nslb)
      endif
!
      IF(BALLH)THEN
        DEALLOCATE(DVU,DE,IDY,NVEC,IWRK6,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGFS: DE-ALLOCATION FAILS FOR DVU,DE,IDY,NVEC'
          NF=MIN(NF,IZERO)
        ENDIF
        IF(BPRNT0.AND.ALLOCATED(DVP))THEN
          DEALLOCATE(DVP,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'DIAGFS: DE-ALLOCATION FAILS FOR DVP'
            NF=MIN(NF,IZERO)
          ENDIF
        ENDIF
        BALLH=.FALSE.
      ENDIF
!
!      IF(ALLOCATED(DU))THEN
!        DEALLOCATE(DU,STAT=IERR)
!        IF(IERR.NE.0)THEN
!          WRITE(MW0,*)
!     &              'DIAGFS: DE-ALLOCATION FAILS FOR DU'
!          NF=MIN(NF,IZERO)
!        ENDIF
!      ENDIF
!
      IF(BALLA)THEN
        DEALLOCATE(DUI,DVI,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGFS: DE-ALLOCATION FAILS FOR DUI,DVI'
          NF=MIN(NF,IZERO)
        ENDIF
        DEALLOCATE(DDY)
        BALLA=.FALSE.
      ENDIF
!
      IF(BTCC)THEN
        DEALLOCATE(DT,MMIKE,NMIKE,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGFS: DE-ALLOCATION FAILS FOR DT,MMIKE,NMIKE'
          NF=0
          GO TO 1900
        ENDIF
      ENDIF
!
      IF(NF.LE.0)GO TO 1900                                      !RETURN
!
!
!********************************************
!
!   ***COMPUTE MULTIPOLE RADIATIVE DATA***
!
!********************************************
!NRB: RE-WRITTEN FOR N^3 MULT. AND TO USE THE
! LOOP OVER ALG STORAGE AS ONE OF THESE LOOPS.
!********************************************
!
!
      IF(.NOT.BRAD.AND.BJUMP)GO TO 1900               !NO RE-CALCULATION
!
      MLAM=0
!
      IF(.NOT.BRADAT)GO TO 1800
!
      IF(NCTOT.GT.ABS(IAXJU))GO TO 2200                   !SHOULD NOT BE
!
      IF(BKUTDSK)THEN             !TFUJ ONLY HOLDS TWO E-VECTORS, SO
!
        IF(ALLOCATED(TFUJ))THEN
          DEALLOCATE(TFUJ,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'DIAGFS: DE-ALLOCATION FAILS FOR TFUJ'
            NF=MIN(NF,IZERO)
          ENDIF
        ENDIF
!
        ALLOCATE(TFUJ(2*IAXDK),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGFS:    ALLOCATION FAILS FOR TFUJ'
          NF=0
          GO TO 1800
        ENDIF
!
      ENDIF
!
      NPOSX=(IOS-IRK)
      if(nposx.le.0)go to 1800
      BPOS=.TRUE.                                         !FORCE FOR NOW
      BOMRC=.FALSE.
!
      MXORB2=MXORBR*MXORBR                                        !FLAGX
!
      MX=MPOLX
      MX=MX-MPOL0                                                 !FLAGX
      MXPOL=MAX(IONE,MX/2+1)
!
      IF(BPOS)THEN                           !PRE-DECODE ADDRESS
!
        ALLOCATE(NPOS(4,NPOSX),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGFS:    ALLOCATION FAILS FOR NPOS'
          NF=0
          GO TO 1900                                    !RETURN
        ENDIF
!
        i1=mb+1                                                   !FLAGX
        i2=i1
        NPOS0=IRK
        MCI=0
        DO NC=1,NSL0
          MC=NSL(NC)
          DO ND=1,NC
            N1=NED(1,ND,MCI+1)
            IF(N1.GT.0)THEN
              DO MD1=1,MC
                ND1=MD1+MCI
                N1=NED(1,ND,ND1)
                N2=NED(2,ND,ND1)
                if(irlx.lt.0)then
                  kf=abs(nfk(nd1))
                  i1=icfgp(kf)*mb+1
                endif
                DO M=N1,N2
                  NS=M-NPOS0
                  n8=MXORB2*MXPOL
                  M1=INT(NRK(M)/n8,SP)
                  M2=M1+1
                  NPOS(1,NS)=M2                     !TERM
                  if(irlx.lt.0)then
                    kg=abs(nfk(m2))
                    i2=icfgp(kg)*mb+1
                  endif
                  n8=M1*n8
                  MX=INT((NRK(M)-n8)/MXORB2,SP)
                  MK=MX
                  MK=MK+MPOL0/2                                   !FLAGX
                  NPOS(2,NS)=MK                     !MULTIPOLE
                  n8=n8+MX*MXORB2
                  n8=NRK(M)-n8
                  M0=INT(n8/MXORBR,SP)
                  M1=M0+I1
                  MM=INT(n8-M0*MXORBR+I2,SP)
                  M2=MIN(M1,MM)
                  NPOS(3,NS)=M2                     !ORBITAL
                  M1=M1+MM-M2
                  IF(MM.NE.M1)M1=-M1
                  NPOS(4,NS)=M1                     !ORBITAL
                ENDDO
              ENDDO
            ENDIF
          ENDDO
          MCI=MCI+MC
        ENDDO
      ELSE
        NPOS0=0
        WRITE(MW6,11000)NPOSX
        WRITE(MW0,11000)NPOSX
      ENDIF
!
      IF(.NOT.BFOTJ)THEN
!        ALLOCATE(DVECF(MENG,NENERG),STAT=IERR)
        ALLOCATE(DVECF(NENERG,MENG),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGFS:    ALLOCATION FAILS FOR DVECF'
          NF=0
          GO TO 1700
        ENDIF
        IF(MPOLE.GT.2)THEN
!          ALLOCATE(DVECM(MENG,NENERG),STAT=IERR)
          ALLOCATE(DVECM(NENERG,MENG),STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'DIAGFS:    ALLOCATION FAILS FOR DVECM'
            NF=0
            GO TO 1700
          ENDIF
        ENDIF
      ENDIF
!
      ALLOCATE(IDY(IAXDK),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DIAGFS:    ALLOCATION FAILS FOR IDY'
        NF=0
        GO TO 1700
      ENDIF
!
! LOCAL
      K0=MAX(IZERO,NMM)
      ALLOCATE(SUMRN(0:K0),SUMRD(0:K0))
!
      IF(BUNPR)THEN
        ALLOCATE(SUMPN(MENG,0:K0),SUMPD(MENG,0:K0))
      ENDIF
!
      BAUX=JPRINT.EQ.1.OR.JPRINT.GT.4      !.NOT.BAUX IGNORE CORRELATION
!
      BDEL=MDEL.GT.0
      IF(IDIAG.LT.0)WLG0=DTEN**MDEL
!
!      BJSEL=MULTS.EQ.0
!      IF(IDIAG.LT.0)BJSEL=.TRUE.
      IF(.NOT.BJSEL)THEN
        WRITE(MW0,10800)            !PRINT WARNING IF LS SELECTION RULES
        WRITE(MW6,10800)            !PRINT WARNING IF LS SELECTION RULES
      ENDIF
!
      BMPRNT=.NOT.BBORN.OR.(BBORN.AND.ABS(MBP2MX).GT.0)
!
      NTRAN=0
      IORT=ABS(MORT)
      DEM=2*DG00                              !GROUND ENERGY (RYD)
      IF(EIONMN.EQ.DZERO)EIONMN=etest         !ENABLE B-C SPLIT
      IF(NMETAPJ.GT.0)etest=dzero             !no rad bundle for upward
!
      IF(.NOT.BMODE.AND.BPRNT0)WRITE(MW8,10210)NZION,MION
      IF(.NOT.BMODE.AND..NOT.BPRNT0)WRITE(MW28)int(NZION),int(MION)
!
      STOL=STOLB
      IF(MENGB.NE.1)STOL=100*STOL
      WLGO=100*STOL/DZA2
!
      IF(MENGB.GE.-1)THEN            !INITIALIZE OMEGA BORN
!
        WRITE(MW6,10810)
        TOLO=D1M10
!
        if(nmetaj.gt.0)then
          nmin=min(NMETAJ,NSPECE)
          ixr=irow(nmin,nspece,ione1,nspece)
          ixc=0
          if(idw.eq.0.and.ABS(MENGB).eq.1)ixc=icol(nmin,nspece,ione1)
          nomwrt=max(ixr,ixc)
        else
          NOMWRT=(NSPECE*(NSPECE+1-2*ione1))/2
        endif
!
        IF(ABS(MENGB).EQ.1)THEN              !INFINITE ENERGY ONLY
!
          BSCRO=.TRUE.       !(REMOVE "ELSE" TO USE INTERNAL - WASTEFUL)
!
          ALLOCATE(OMR(NOMWRT),OMC(NOMWRT),STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'DIAGFS: ALLOCATION FAILS FOR OMR,OMC'
            NF=0
            GO TO 1700
          ENDIF
          BOMRC=.TRUE.
          NOMWRX=NOMWRT
!
          IF(NOMWRT.GT.NOMWRX)THEN            !NO LONGER POSSIBLE
            NNN=2*NOMWRT/MENG+1
            WRITE(MW6,10860)NNN
            WRITE(MW0,*)'*** WORKING ARRAYS TOO SMALL IN SR.DIAGFS'
            GO TO 2100
          ENDIF
          DO I=1,NOMWRX
            OMR(I)=DZERO
            OMC(I)=DZERO
          ENDDO
!
        ELSE                                  !FINITE ENERGY
!
          BSCRO=.TRUE.       !.T. USE SCRATCH FILE, .F. STORE INTERNALLY
!
          IF(.NOT.BSCRO)THEN
            ALLOCATE(OMEGA(0:MXNXB1,NOMWRT),STAT=IERR)
            IF(IERR.NE.0)THEN
              BSCRO=.TRUE.
            ELSE
              BSCRO=.FALSE.
            ENDIF
          ENDIF
          NOMWRY=NOMWRT
!
!
          IF(BSCRO)THEN
!            WRITE(MW0,*)'DIAGFS: USING SCRATCH FOR BORN MULTIPOLE SUM'
!            WRITE(MW6,*)'DIAGFS: USING SCRATCH FOR BORN MULTIPOLE SUM'
          ELSE
            DO N=1,NOMWRT
              DO NX=0,MXNXB1
                OMEGA(NX,N)=0
              ENDDO
            ENDDO
          ENDIF
!
          DO NX=1,MXNXB
            XS(NX)=SQRT(DONE-DONE/XB(NX))   !CASE ICR NOT DONE IN DIAGON
          ENDDO
!
        ENDIF
!
        MSC0=80
        MSC=MSC0-1
        IBOMX=0
!        ibifmx=0
!
      ENDIF
!                 INITIALIZE GEOMETRIC COEFFICIENTS
      ALLOCATE(DG(0:IXBLM))
!
      DG(0)=DZERO
      IF(MPOLE.LE.8)THEN
        IP=1
        DO I=2,MPOLE,2
          IP=IP*(I+1)*2
          IM=I/2
          DG(IM)=2*(I+1)*(IM+1)
          DG(IM)=DG(IM)/(IM*REAL(IP,WP)*REAL(IP,WP))
        ENDDO
      ELSE
        TIP=1
        DO I=2,MPOLE,2
          TIP=TIP*(I+1)*2
          IM=I/2
          DG(IM)=2*(I+1)*(IM+1)
          DG(IM)=DG(IM)/(IM*TIP*TIP)
!          write(mw0,*)im,tip,2*(i+1)*(im+1),im*tip*tip,dg(im)
        ENDDO
      ENDIF
!
      if(btime)call nrb_time(timei)
!
      MLAM=MPOL00-2
 1200 MLAM=MLAM+2
      NGROUP=MLAM/2
!
      BCASC=BCASC.AND.NGROUP.EQ.1
      BBORN=MENGB.GT.1.OR.(MENGB.EQ.1.AND.NGROUP.NE.1)
      BFOTJ=.NOT.BFOT.OR..NOT.BLAG
!      BFOTJ=BFOTJ.OR.NGROUP.NE.1            !UNCOMMENT TO WRITE E1 ONLY
      BFAST=.NOT.BBORN.AND..NOT.BPRNT0.AND.BJSEL.AND.BELONG
!      bfast=.true.
!
      IF(BSCRO)THEN                                         !MENGB.GE.-1
        MSC=MSC0+NGROUP
        OPEN(MSC,STATUS='SCRATCH',FORM='UNFORMATTED')
      ENDIF
!
!      if(bborn)then       !initialize flag to count Born usage
!        do i=1,mb4(0)
!          iflagb(i)=-1
!        enddo
!      endif
!
      BEKVEL=NGROUP.EQ.1.OR..NOT.BMPRNT.OR..NOT.BELONG  !I.E. VEL=.TRUE.
!
      IF(MPOLM.GT.0)THEN
        BM1BP=NGROUP.EQ.2.AND.ABS(MBP2MX).GT.0  ! 1/2-BODY M1+BP EXISTS
        BM1NBP=NGROUP.EQ.2.AND.MBP2MX.EQ.0.AND.MBP1MX.LT.0.AND.         &
     &         mpolm.le.2
!     &      .and.mpole.lt.6          !M1 NON-REL - NB: SYNC WITH ALGEB4
      ELSE
        BM1BP=.FALSE.
        BM1NBP=.FALSE.
      ENDIF
!
      ISB=1+ione1
!
      IF(NGROUP.EQ.1)THEN
        MP=0
        IF(IORT.GT.20)ISB=IORT
        IF(BPRNT0)THEN
          WRITE(MW6,*)' '
          IF(.NOT.BELONG)WRITE(MW6,10360)
          IF(NGROUP.LT.10)THEN
            WRITE(MW6,10340)NGROUP
          ELSE
            WRITE(MW6,10350)NGROUP
          ENDIF
          IF(ISB.GT.2)WRITE(MW6,10370)ISB,JORIG(ISB)
        ENDIF
        IF(WLG1.LT.DZERO)THEN
          WLG=D1M2
          IF(IDIAG.LT.0.AND.BDEL)WLG=WLG0
        ELSE
          WLG=DZERO
        ENDIF
        WLG=MAX(WLG,WLG1)
        WLGS=DKON
        IF(NPRNT5.GE.0)WLGS=D1M20
      ELSE
        IF(WLG2.LT.DZERO)THEN
          WLG=D1M7
        ELSE
          WLG=DZERO
        ENDIF
        WLG=MAX(WLG,WLG2)
        WLGS=DKON
        IF(BPRNT0)WRITE(MW6,*)' '
        IF(NGROUP.gt.1.AND.BMPRNT)THEN
          MP=5
          MBCOR=MBLK
          IF(BM1BP)MBCOR=MBP
          IF(BPRNT0)THEN
            IF(.NOT.BELONG)WRITE(MW6,10680)
            if(ngroup.eq.2.and..not.bborn)then                    !lande
              LAB9='GK(LANDE)'
            else
              LAB9='OMG(BORN)'
            endif
            IF(NGROUP.LT.10)THEN
              WRITE(MW6,10380)NGROUP,NGROUP-1,MBCOR,LAB9
            ELSE
              WRITE(MW6,10390)NGROUP,NGROUP-1,MBCOR,LAB9
            ENDIF
          ENDIF
        ELSE
          MP=5
          IF(BPRNT0)THEN
            IF(.NOT.BELONG)WRITE(MW6,10690)
            IF(NGROUP.LT.10)THEN
              WRITE(MW6,10400)NGROUP,MP
            ELSE
              WRITE(MW6,10410)NGROUP,MP
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      ISGNN=1-2*mod(abs(NGROUP),ITWO)                   !(-1)**NGROUP
!
      JOS=0
      KTRAN=0
      JPOLD=-1
      IIMN=1                                          !case jjmn.gt.jjmx
      ILF=ione1
      JJMN=1+ione1
      JJMN=max(JJMN,ISB)
      JJMX=NENERG
      IF(JRAD.GT.0)THEN
        IF(JRAD.EQ.2.OR.JRAD.EQ.3.OR.JRAD.EQ.5)JJMN=MAX(JJMN,IAUTO)
        IF(JRAD.EQ.1)JJMX=MIN(IAUTO-1,NENERG)
      ENDIF
      JJMN=MAX(JJMN,JUPMN)
      JJMX=MIN(JJMX,JUPMX)
!
!************************************
! START LOOP OVER UPPER ENERGY LEVELS
!************************************
!
      DO IAB=JJMN,JJMX
!
        IF(.NOT.BAUX.AND.JORIG(IAB).LT.0)GO TO 1500         !CORRELATION
        KTRAN=ABS(KTRAN)
        IF(JORIG(IAB).GT.0)THEN
          ILF=ILF+1
        ELSE
          KTRAN=-KTRAN
        ENDIF
        I=ABS(JORIG(IAB))
        IT=NRR(I)
!
        IF(NFK(IT).LT.0)THEN                  !CONT
          IF(.NOT.BFOT)GO TO 1500             !BUT NO PI
          IF(BDOWN.AND.BUNPA.AND.IWRK2(I).GT.JIMXIC)GO TO 1500   !FOR RR
        ENDIF
!
        ND=NFQ(IT)
        MNS=QSI(ND)
        IF(BMULT.AND.MNS.NE.MULTSM)GO TO 1500
        MNL=QLI(ND)
        MQJ=JN(I)
        DZ9=MQJ+1
        NDJ=NGR(I)
        NCJ=NGRPJ(NDJ)                        !=I-NAJ(I)
        NADRUU=NADRUJ(I)                      !SET UPPER
!
        if(btime)call nrb_time(timeir)
!
! flag if mixing coefficient exists
!
        if(mode.ne.2)then                     !b-b only
          if(bkutls)then
            do n=1,nt(ndj)
              j=ncj+n
              jt=nrr(j)
              if(nfk(jt).eq.nfk(it))then
                idy(n)=-1
              else
                idy(n)=0
              endif
            enddo
          else
            do n=1,nt(ndj)
              idy(n)=-1
            enddo
          ENDIF
        elseif(nfk(it).gt.0)then              !i is bound
          do n=1,nt(ndj)
            j=ncj+n
            jt=nrr(j)
            if(bkutls)then
              btest=nfk(jt).eq.nfk(it)        !scf
            else
              btest=nfk(jt).gt.0              !b-b
            endif
            if(btest)then
              idy(n)=-1
            else                              !b-c/kf.ne.kg
              idy(n)=0
            endif
          enddo
        else                                  !j is continuum
          if(.not.bkutls)then
            m=-nfk(it)
            m=qcg(nf,m)
            ij=ieq(m)
          endif
          do n=1,nt(ndj)
            j=ncj+n
            jt=nrr(j)
            if(nfk(jt).gt.0)then              !c-b
              idy(n)=0
            else
              if(bkutls)then
                btest=nfk(jt).eq.nfk(it)      !c-c
              else
                m=-nfk(jt)
                m=qcg(nf,m)
                btest=ieq(m).eq.ij            !c-c
              endif
              if(btest)then
                idy(n)=1
              else                            !c-c'
                idy(n)=0
              endif
            endif
          enddo
        endif
!
        IIMN=1
        IIMX=IAB-ione1
        if(nmetaj.gt.0)iimx=min(iimx,nmetaj)
        IF(NMETAPJ.GT.0)IIMX=MIN(IIMX,NLASTP)
        IF(JRAD.GT.0)THEN
          IF(JRAD.EQ.3)IIMN=MAX(IONE,IAUTO)
          IF(JRAD.EQ.1.OR.JRAD.EQ.2.OR.JRAD.EQ.4)IIMX=MIN(IAUTO-1,IIMX)
        ENDIF
        IF(.NOT.BUNA)THEN               !OUTWITH DROPPED, NOT BUNDLED
          IIMN=MAX(IIMN,JLOWMN)
          IIMX=MIN(IIMX,JLOWMX)
        ENDIF
!
! LOAD E-VECTOR
!
        IF(BKUTDSK)THEN                         !GET E-VECTOR LENGTH
!
          if(bkutls)then
            m1=abs(nfk(it))
            m0=jwrkb(2,m1,NDJ)
!         write(mw6,*)NDJ,nfk(it),i,NADRUU,m0
          else
            if(nfk(it).gt.0)then                                  !bound
              l1=jwrkg0(ndj-1)
              l2=jwrkg0(ndj)
              m0=l2-l1
            else               !continuum (already skipped if .not.bfot)
              m1=-nfk(it)
              m2=qcg(nf,m1)
              m2=ieq(m2)
              m0=jwrkg(m2,NDJ)                     !need kgroup resolved
            endif
          endif
!
          CALL DISKTF(NDJ,NADRUU,M0,TFUJ(1),IONE)
!
          NADRUU=0
        ENDIF
!
! INITIALIZE/ZEROIZE
!
        DO J=1,NENERG
          IWRK4(J)=ABS(IWRK4(J))
          DVECL(J)=DZERO
          DVECV(J)=DZERO
          DVECA(J)=DZERO
        ENDDO
!
        IF(.NOT.BFOTJ.AND.NFK(IT).LT.0)THEN
          DO J=1,NENERG
            DO M8=1,MENG
!            DVECF(M8,J)=DZERO
              DVECF(J,M8)=DZERO
            ENDDO
          ENDDO
          IF(MPOLE.GT.2)THEN
            DO J=1,NENERG
              DO M8=1,MENG
!              DVECM(M8,J)=DZERO
                DVECM(J,M8)=DZERO
              ENDDO
            ENDDO
          ENDIF
        ENDIF
!
! PRE-DETERMINE (MAXIMAL) BORN USAGE (IXBIF):
!
        IF(BBORN)THEN
!
          IBO=0                            !INITIALIZE
          DO J=1,NENERG
            ID(J)=0
          ENDDO
!
          NCJP=0
          DO KK=1,NJO                 !BEGIN LOOP OVER "LOWER" JP GROUPS
!
            NC=NSLJ(1,KK)
            M=QPI(NC)+QPI(ND)
            IF(MOD(M+MLAM,IFOUR).NE.0)GO TO 1220
            MQJP=JN(NCJP+1)
            M=ABS(MQJ-MQJP)
            IF(M.GT.MLAM)GO TO 1220
            M=MQJ+MQJP
            IF(M.LT.MLAM)GO TO 1220
!        DZ8=MQJP+1
!        DSJ=SQRT(DZ8*DZ9)
!
            NCJP0=0
            DO NGJP=1,NGSLJ(KK)      !BEGIN LOOP OVER "LOWER" SLP GROUPS
!
              NC=NSLJ(NGJP,KK)
              IF(NMETAG(NC)+NMETAG(ND).GT.1)GO TO 1210
!
              MQSP=QSI(NC)                     !=MNSP
              MQLP=QLI(NC)                     !=MNLP
!
!        IF(.NOT.BJSEL)THEN                  !LS SELECTION RULES APPLIED
!          IF(MNS.NE.MQSP)GO TO 2333
!          IF(ABS(MNL-MQLP).GT.MLAM)GO TO 2333
!          IF(MNL+MQLP.LT.MLAM)GO TO 2333
!        ENDIF
!
              DO NJP1=1,NSL(NC)
                J=NCJP+NCJP0+NJP1             !=NCJ+POSITION IN JP GROUP
                LSL=NRR(J)
                IF(IWRK4(J).LE.IAB-ione1.AND.IWRK4(J).LE.IIMX.AND.      &
     &             NFK(LSL).GT.0)THEN
!            .AND.IWRKX(J).GT.IIMN            !IWRKX NOT SET-UP YET
                  IWRK4(J)=-ABS(IWRK4(J))    !FLAG EXISTS
                ENDIF
              ENDDO
!
              NCJ0=0
              DO NGJ=1,NGSLJ(NDJ)   !BEGIN LOOP OVER UPPER CI SLP GROUPS
!
                ND=NSLJ(NGJ,NDJ)
                MQS=QSI(ND)
                MQL=QLI(ND)
!
!        IF(.NOT.BJSEL)THEN            !LS SELECTION RULES IMPOSED ON CI
!          IF(MQS.NE.MNS)GO TO 2340
!          IF(MQL.NE.MNL)GO TO 2340
!        ENDIF
!
                IF(MQSP.NE.MQS)GO TO 1208
                IF(NMETAG(NC)+NMETAG(ND).GT.1)GO TO 1208
                IF(ABS(MQL-MQLP).GT.MLAM)GO TO 1208
                IF(MQL+MQLP.LT.MLAM)GO TO 1208
!
!        DRACL=SJS(MQL,MQJ,MQS,MQJP,MQLP,MLAM)*DSJ*   !SJS slow, and
!     &           (1-MOD(MQS+MQL+MQJP+MLAM,4))
!        IF(ABS(DRACL).LT.D1M7)GO TO 2340        !possibly safer to skip
!
                BEQGRP=ND.EQ.NC
                BING=ND.LE.NC
                IF(BING)THEN
                  NU=NC
                  NL=ND
!n          ngl=ndj
                  NNNU=NCJP+NCJP0
                  NNNL=NCJ+NCJ0
                ELSE
                  NU=ND
                  NL=NC
!n          ngl=kk
                  NNNU=NCJ+NCJ0
                  NNNL=NCJP+NCJP0
                ENDIF
!
                J0=NNNU+1
                I0=NRR(J0)
                IF(NED(1,NL,I0).EQ.0)GO TO 1208
!
                DO N=1,NSL(NU)        !BEGIN LOOP OVER UPPER SYM. LEVELS
!
                  J0=NNNU+N                   !UPPER LEVEL INDEX
                  I0=NRR(J0)                  !UPPER TERM INDEX
!
 1202             IF(BING)THEN
                    LSL=I0
                    J=J0
                    IF(IWRK4(J).GT.0)GO TO 1206
                  ELSE
                    KSL=I0
                    K=J0
                    if(idy(k-ncj).eq.0)go to 1206
!          NI=NADRUU+NAJ(K)
!          DD1=TFUJ(NI)
!          IF(ABS(DD1).LT.CMXICR)GO TO ibid      !possibly safer to skip
                  ENDIF
!
                  N1=NED(1,NL,I0)-NPOS0
                  N2=NED(2,NL,I0)-NPOS0
!
                  DO M=N1,N2          !BEGIN LOOP OVER LOWER SYM. LEVELS
!
                    IF(BPOS)THEN             !M2=LOWER TERM INDEX
                      M2=NPOS(1,M)
                    ELSE
                      n8=MXORB2*MXPOL
                      M1=INT(NRK(M)/n8,SP)
                      M2=M1+1
                    ENDIF
!
                    K0=NNNL+M2-NRR(NNNL+1)+1 !LOWER LEVEL INDEX
!
                    IF(BING)THEN
                      KSL=M2
                      K=K0
                      if(idy(k-ncj).eq.0)go to 1204
!          NI=NADRUU+NAJ(K)
!          DD1=TFUJ(NI)
!          IF(ABS(DD1).LT.CMXICR)GO TO ibid      !possibly safer to skip
                    ELSE
                      IF(I0.EQ.M2)GO TO 1204
                                 !AVOID DOUBLE COUNTING
                      LSL=M2
                      J=K0
                      IF(IWRK4(J).GT.0)GO TO 1204
                    ENDIF
!
                    IF(BPOS)THEN             !M2=LOWER TERM INDEX
                      MK=NPOS(2,M)
                      IF(MK.NE.NGROUP)GO TO 1204
                    ELSE
                      n8=M1*n8
                      MX=INT((NRK(M)-n8)/MXORB2,SP)
                      MK=MX
                      MK=MK+MPOL0/2                               !FLAGX
                      IF(MK.NE.NGROUP)GO TO 1204
                    ENDIF
!
!OLD        JG=J                            !STORE IN ORGINAL GROUP POSN
                    jg=jwrkg0(kk-1)+naj(j)
                                         !store in e-vector posn as tfuj
                    if(bkutls)jg=jg+jwrkb(1,nfk(nrr(j)),kk)
!
                    IF(ID(JG).EQ.0)THEN
                      IBO=IBO+1
                      ID(JG)=IBO
                    ENDIF
!
 1204             ENDDO           !END LOOP OVER LOWER SYM. LEVELS
!
 1206             IF(BEQGRP)THEN                 !PICK-UP OTHER HALF
                    IF(BING)THEN
                      BING=.FALSE.
                      J0=NNNL-NRR(NNNL+1)+I0+1
                      NNNL=NCJP+NCJP0
                      GO TO 1202
                    ELSE
                      BING=.TRUE.
!n            ngl=ndj
                      NNNL=NCJ+NCJ0
                    ENDIF
                  ENDIF
!
                ENDDO             !END LOOP OVER UPPER SYM. LEVELS
!
 1208           NCJ0=NCJ0+NSL(ND)
              ENDDO               !END LOOP OVER UPPER CI SLP GROUPS
!
 1210         NCJP0=NCJP0+NSL(NC)
            ENDDO                 !END LOOP OVER "LOWER" SLP GROUPS
!
 1220       NCJP=NCJP+NT(KK)
          ENDDO                   !END LOOP OVER "LOWER" JP GROUPS
!
          IXBIF=IBO
!
          IF(IXBIF.GT.MXBIF)THEN
            IF(MXBIF.GT.0)WRITE(MW6,10990)IXBIF,MXBIF
          ENDIF
!        write(mw0,*)ixbif
!        ibifmx=max(ibifmx,ixbif)
!
          ALLOCATE(DBL(IXD33,IXBIF),STAT=IERR)  !MXBIF
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'DIAGFS: ALLOCATION FAILS FOR DBL'
            NF=0
            GO TO 1700
          ENDIF
!                                                !RE-INITIALIZE
          IBO=0
          DO J=1,NENERG
            ID(J)=0
          ENDDO
!
        ENDIF
!
!**********************************************************************
! PRE-MULTIPLY UPPER MIXING MATRIX BY MULTIPOLE MATRIX FOR ALL "LOWER"
! STATES (ALL, BECAUSE THE "LOWER" STATES ARE TO BE MIXED SUBSEQUENTLY)
!**********************************************************************
!
!                ***** ELECTRIC *****
!
!**********************************************************************
!      DVECL(J)=                                       !EK LENGTH
!      IF(NGROUP.NE.2.OR.BBORN)DVECV(J)=               !EK VELOCITY
!**********************************************************************
!
!
        NCJP=0
        DO KK=1,NJO                  !BEGIN LOOP OVER "LOWER" JP GROUPS
!
! FOR SPEED PRE-SELECT ACCORDING TO PARITY, TOTAL J:
!
          NC=NSLJ(1,KK)
          M=QPI(NC)+QPI(ND)
          IF(MOD(M+MLAM,IFOUR).NE.0)GO TO 1260
          MQJP=JN(NCJP+1)
          M=ABS(MQJ-MQJP)
          IF(M.GT.MLAM)GO TO 1260
          M=MQJ+MQJP
          IF(M.LT.MLAM)GO TO 1260
          DZ8=MQJP+1
          DSJ=SQRT(DZ8*DZ9)
!
          NCJP0=0
          DO NGJP=1,NGSLJ(KK)        !BEGIN LOOP OVER "LOWER" SLP GROUPS
!
            NC=NSLJ(NGJP,KK)
            IF(NMETAG(NC)+NMETAG(ND).GT.1)GO TO 1240
!
            MQSP=QSI(NC)                     !=MNSP
            MQLP=QLI(NC)                     !=MNLP
!
            IF(.NOT.BJSEL)THEN
                          !LS SELECTION RULES APPLIED
              IF(MNS.NE.MQSP)GO TO 1240
              IF(ABS(MNL-MQLP).GT.MLAM)GO TO 1240
              IF(MNL+MQLP.LT.MLAM)GO TO 1240
            ENDIF
!
            DO NJP1=1,NSL(NC)
              J=NCJP+NCJP0+NJP1              !=NCJ+POSITION IN JP GROUP
              LSL=NRR(J)
              IF(IWRK4(J).LE.IAB-ione1.AND.IWRK4(J).LE.IIMX.AND.NFK(LSL)&
     &           .GT.0)THEN
!          .AND.IWRKX(J).GT.IIMN             !IWRKX NOT SET-UP YET
                IWRK4(J)=-ABS(IWRK4(J))     !FLAG EXISTS
              ENDIF
            ENDDO
!
            NCJ0=0
            DO NGJ=1,NGSLJ(NDJ)     !BEGIN LOOP OVER UPPER CI SLP GROUPS
!
              ND=NSLJ(NGJ,NDJ)
              MQS=QSI(ND)
              MQL=QLI(ND)
!
              IF(.NOT.BJSEL)THEN     !LS SELECTION RULES IMPOSED ON CI
                IF(MQS.NE.MNS)GO TO 1230
                IF(MQL.NE.MNL)GO TO 1230
              ENDIF
!
! IC REDUCED MATRIX ELEMENT IS ZERO IF LS SELECTION RULES NOT SATISFIED
! IT IS JUST A TRANSFORMATION OF LS REDUCED MATRIX ELEMENT (EJN EQU 116)
!
              IF(MQSP.NE.MQS)GO TO 1230
              IF(NMETAG(NC)+NMETAG(ND).GT.1)GO TO 1230
              IF(ABS(MQL-MQLP).GT.MLAM)GO TO 1230
              IF(MQL+MQLP.LT.MLAM)GO TO 1230
!
              MMM=(MQL-MQLP)/2
              DS=1-2*mod(abs(MMM),ITWO) !(-1)**MMM
              IF(BFANO)DS=DS*ISGNN
!
              DRACL=SJS(MQL,MQJ,MQS,MQJP,MQLP,MLAM)                     &
     &              *DSJ*(1-MOD(MQS+MQL+MQJP+MLAM,IFOUR))
              IF(ABS(DRACL).LT.D1M7)GO TO 1230
!
              BEQGRP=ND.EQ.NC
              BING=ND.LE.NC
              IF(BING)THEN
                NU=NC
                NL=ND
!n        ngl=ndj
                NNNU=NCJP+NCJP0
                NNNL=NCJ+NCJ0
              ELSE
                NU=ND
                NL=NC
!n        ngl=kk
                NNNU=NCJ+NCJ0
                NNNL=NCJP+NCJP0
              ENDIF
!
              J0=NNNU+1
              I0=NRR(J0)
              IF(NED(1,NL,I0).EQ.0)GO TO 1230
!
              DO N=1,NSL(NU)          !BEGIN LOOP OVER UPPER SYM. LEVELS
!
                J0=NNNU+N                   !UPPER LEVEL INDEX
                I0=NRR(J0)                  !UPPER TERM INDEX
!
 1222           IF(BING)THEN
                  LSL=I0
                  J=J0
                  IF(IWRK4(J).GT.0)GO TO 1226
                ELSE
                  KSL=I0
                  K=J0
                  if(idy(k-ncj).eq.0)go to 1226
                  NI=NADRUU+NAJ(K)
                  DD1=TFUJ(NI)
                  IF(ABS(DD1).LT.CMXICR)GO TO 1226
                ENDIF
!
                N1=NED(1,NL,I0)-NPOS0
                N2=NED(2,NL,I0)-NPOS0
!
                DO M=N1,N2          !BEGIN LOOP OVER LOWER SYM. LEVELS
!
                  IF(BPOS)THEN             !M2=LOWER TERM INDEX
                    M2=NPOS(1,M)
                  ELSE
                    n8=MXORB2*MXPOL
                    M1=INT(NRK(M)/n8,SP)
                    M2=M1+1
                  ENDIF
!
                  K0=NNNL+M2-NRR(NNNL+1)+1 !LOWER LEVEL INDEX
!
                  IF(BING)THEN
                    KSL=M2
                    K=K0
                    if(idy(k-ncj).eq.0)go to 1224
                    NI=NADRUU+NAJ(K)
                    DD1=TFUJ(NI)
                    IF(ABS(DD1).LT.CMXICR)GO TO 1224
                  ELSE
                    IF(I0.EQ.M2)GO TO 1224
                               !AVOID DOUBLE COUNTING
                    LSL=M2
                    J=K0
                    IF(IWRK4(J).GT.0)GO TO 1224
                  ENDIF
!
                  IF(BPOS)THEN             !M2=LOWER TERM INDEX
                    MK=NPOS(2,M)
                    IF(MK.NE.NGROUP)GO TO 1224
                  ELSE
                    n8=M1*n8
                    MX=INT((NRK(M)-n8)/MXORB2,SP)
                    MK=MX
                    MK=MK+MPOL0/2                                 !FLAGX
                    IF(MK.NE.NGROUP)GO TO 1224
                  ENDIF
!
!OLD      JG=J                            !STORE IN ORGINAL GROUP POSN
                  jg=jwrkg0(kk-1)+naj(j)  !store in e-vec posn as tfuj
                  if(bkutls)jg=jg+jwrkb(1,nfk(nrr(j)),kk)
!
                  IF(BPOS)THEN
                    M2=NPOS(3,M)
                    MM=NPOS(4,M)
                    M1=ABS(MM)
                  ELSE
                    n8=n8+MX*MXORB2
                    n8=NRK(M)-n8
                    I1=1
                    I1=I1+MB                                      !FLAGX
                    M0=INT(n8/MXORBR,SP)
                    M1=M0+I1
                    MM=INT(n8-M0*MXORBR+I1,SP)
                    M2=MIN(M1,MM)
                    M1=M1+MM-M2
                  ENDIF
!
                  IN=ICOL(M2,M1,IZERO)
                  INV=IXD28+IN
!
                  DSC=DZERO
                  IF(NGROUP.GT.0)DSC=DOSC(IN,NGROUP/2)
!
                  DRY=DD1*DRK(M+NPOS0)*DRACL
                  BINT=LSL.LE.KSL
                  IF(.NOT.BINT)DRY=DRY*DS
!
                  DVECL(JG)=DVECL(JG)+DRY*DSC      !LENGTH
!
                  IF(BREL.AND.NFK(IT).GT.0.AND.irtard.GT.0)THEN
                                                   !RETARD ALREADY ON PI
                    DDD=DENERG(J)-DENERG(K)
                    DDD=4*DDD*DDD*DRY
                    DVECL(JG)=DVECL(JG)-DALF4*DDD*DOSC(IN,NGROUP/2+1)   &
     &                        /(4*NGROUP+6)
                  ENDIF
!
!      write(mw6,899)i,k,j,jg,m+npos0,dd1,drk(m+npos0)
!     &           ,dracl,dry,dsc,dvecl(jg)
! 899  format(4i5,6(1pe12.3))
!
                  IF(.NOT.BFOTJ.AND.NFK(IT).LT.0)THEN
                                                   !PHOTO
                    M7=NFOSS(ngroup/2,M1,M2)
                    IF(M7.GT.0)THEN
                      ISYGN=1
                      IF(MM.NE.M1)ISYGN=-ISYGN
                      IF(.NOT.BINT)ISYGN=-ISYGN
                      IF(ISYGN.LT.0)THEN
                        DO M8=1,MENG
                          DSC=DRY                  !LENGTH/ACCELERATION
                          IF(IGAG(M8).EQ.0)DSC=-DSC
                                           !VELOCITY
!              DVECF(M8,JG)=DVECF(M8,JG)+DFOSS(M7,M8,1)*DSC
                          DVECF(JG,M8)=DVECF(JG,M8)+DFOSS(M7,M8,1)*DSC
                        ENDDO
                      ELSE
                        DO M8=1,MENG
!              DVECF(M8,JG)=DVECF(M8,JG)+DFOSS(M7,M8,1)*DRY
                          DVECF(JG,M8)=DVECF(JG,M8)+DFOSS(M7,M8,1)*DRY
                        ENDDO
                      ENDIF
                    ENDIF
!
                  ENDIF
!
                  IF(BFAST)GO TO 1224
!
                  IF(BVEL.AND.BEKVEL)THEN
                    DSC=DZERO
                    IF(NGROUP.GT.0)DSC=DOSC(INV,NGROUP/2)
!                                 !CHANGE OF ORBITAL TO TERM ORDER (VEL)
                    IF(MM.NE.M1)DSC=-DSC
                    IF(.NOT.BINT)DSC=-DSC
                    DVECV(JG)=DVECV(JG)+DRY*DSC    !VELOCITY
                  ENDIF
!
                  IF(BBORN)THEN
                                                   !BORN
                    IF(ID(JG).EQ.0)THEN
                      IBO=IBO+1
                      IF(IBO.LE.IXBIF)THEN
                        ID(JG)=IBO
                        DO IX=1,MB3(0)
                          DBL(IX,IBO)=DZERO
                        ENDDO
                      ELSE
                        ID(JG)=-IBO
                      ENDIF
                    ENDIF
                    IF(ID(JG).GT.0)THEN
                      IB=ID(JG)
                      IN=ICOL(M2,M1,IZERO)
                      IF(BINDB(IN,NGROUP/2))THEN
                        IX=INDX(IN)
                        DBL(IX,IB)=DBL(IX,IB)+DRY
                      ELSE
                        WRITE(MW6,*)IAB,K,J,M,NGROUP,M2,M1
                                              !as no map of level so->eo
                        WRITE(MW0,*)'DIAGFS: BORN M1 M2 NOT FOUND'
                        GO TO 2100
                      ENDIF
                    ENDIF
                  ENDIF
!
 1224           ENDDO           !END LOOP OVER LOWER SYM. LEVELS
!
 1226           IF(BEQGRP)THEN                 !PICK-UP OTHER HALF
                  IF(BING)THEN
                    BING=.FALSE.
                    J0=NNNL-NRR(NNNL+1)+I0+1
                    NNNL=NCJP+NCJP0
                    GO TO 1222
                  ELSE
                    BING=.TRUE.
!n          ngl=ndj
                    NNNL=NCJ+NCJ0
                  ENDIF
                ENDIF
!
              ENDDO             !END LOOP OVER UPPER SYM. LEVELS
!
 1230         NCJ0=NCJ0+NSL(ND)
            ENDDO               !END LOOP OVER UPPER CI SLP GROUPS
!
 1240       NCJP0=NCJP0+NSL(NC)
          ENDDO                 !END LOOP OVER "LOWER" SLP GROUPS
!
 1260     NCJP=NCJP+NT(KK)
        ENDDO                   !END LOOP OVER "LOWER" JP GROUPS
!
        IF(BBORN)THEN
          IBOMX=MAX(IBOMX,IBO)
          IF(IBO.GT.IXBIF)THEN                     !SHOULDN'T HAPPEN
            WRITE(MW6,*)'SR.DIAGFS: DIMENSION ERROR, INCREASE MXBIF TO '&
     &                  ,IBO
            WRITE(MW0,*)'SR.DIAGFS: DIMENSION ERROR, INCREASE MXBIF'
            GO TO 2100
          ENDIF
        ENDIF
!
!
!**********************************************************************
!
!                ***** MAGNETIC *****
!
!**********************************************************************
!
! M1 (NON-REL)
!      DVECA(J)=                                       !M1
!**********************************************************************
!
        IF(BM1NBP)THEN
!
          MLAMM=MLAM-2                                 !MLAMM=2 FOR M1
!
          NCJP=0
          DO KK=1,NJO               !BEGIN LOOP OVER "LOWER" JP GROUPS
!
            IF(NMETGJ(KK)+NMETGJ(NDJ).GT.1)GO TO 1280
!
! FOR SPEED PRE-SELECT ACCORDING TO PARITY, TOTAL J:
!
            NC=NSLJ(1,KK)
            M=QPI(NC)+QPI(ND)
            IF(MOD(M+MLAM,IFOUR).NE.0)GO TO 1280
            MQJP=JN(NCJP+1)
            M=ABS(MQJ-MQJP)
            IF(M.GT.MLAMM)GO TO 1280
            M=MQJ+MQJP
            IF(M.LT.MLAMM)GO TO 1280
!
            NCJP0=0
            DO NGJP=1,NGSLJ(KK)     !BEGIN LOOP OVER "LOWER" SLP GROUPS
              NC=NSLJ(NGJP,KK)
!
              IF(.NOT.BJSEL)THEN
                          !LS SELECTION RULES APPLIED
                MNSP=QSI(NC)
                MNLP=QLI(NC)
                IF(MNS.NE.MNSP)GO TO 1270
                IF(ABS(MNL-MNLP).GT.MLAMM)GO TO 1270
                IF(MNL+MNLP.LT.MLAMM)GO TO 1270
              ENDIF
!
              NPP=NSL(NC)
              DO NJP1=1,NPP         !BEGIN LOOP OVER "LOWER" SLJP LEVELS
!
                J=NCJP+NCJP0+NJP1             !=NCJ+POSITION IN JP GROUP
!
                IF(IWRK4(J).GT.IAB-ione1)GO TO 1265
                IF(IWRK4(J).GT.IIMX)GO TO 1265
!       IF(IWRKX(J).LT.IIMN)GO TO 6330    !IWRKX NOT SET-UP YET
                LSL=NRR(J)
                IF(NFK(LSL).LT.0)GO TO 1265
                IWRK4(J)=-ABS(IWRK4(J))           !FLAG EXISTS
!
!OLD        JG=J                          !STORE IN ORIGINAL GROUP POSN
                jg=jwrkg0(kk-1)+naj(j)    !store in e-vec posn as tfuj
                if(bkutls)jg=jg+jwrkb(1,nfk(nrr(j)),kk)
!
                NCJ0=0
                DO NGJ=1,NGSLJ(NDJ)       !LOOP OVER UPPER CI SLP GROUPS
!
                  ND=NSLJ(NGJ,NDJ)
                  IF(NMETAG(NC)+NMETAG(ND).GT.1)GO TO 1264
                  IF(NC.NE.ND)GO TO 1264           !NC=ND FOR NON-REL M1
                  MQS=QSI(ND)
                  MQL=QLI(ND)
!
                  IF(.NOT.BJSEL)THEN         !LS SELECTION IMPOSED ON CI
                    IF(MQS.NE.MNS)GO TO 1264
                    IF(MQL.NE.MNL)GO TO 1264
                  ENDIF
!
                  NP=NSL(ND)
                  DO NJP=1,NP          !LOOP OVER UPPER CI SLJP LEVELS
!
                    K=NCJ+NCJ0+NJP
                    if(idy(k-ncj).eq.0)go to 1262
                    M=NADRUU+NAJ(K)
                    DD1=TFUJ(M)
!
                    IF(ABS(DD1).LT.CMXICR)GO TO 1262
!
                    KSL=NRR(K)
!          write(mw0,*)njp1,lsl,nc,njp,ksl,nd
                    IF(KSL.EQ.LSL.AND.ABS(MQJ-MQJP).LE.2)THEN
                      IF(MQJ.EQ.MQJP)THEN
                        MJ=(MQJ+2)*MQJ
                        DSC=(MQS+2)*MQS-(MQL+2)*MQL+3*MJ
                        DD8=(MQJ+1)*MJ
                      ELSE
                        MJ=MAX(MQJ,MQJP)
                        DD8=REAL                                        &
     &                      (((MJ-MQS+MQL)*(MJ+MQS-MQL)*MJ*(MJ+MQS+MQL+ &
     &                      2)*(MQS+MQL+2-MJ))/2,WP)
                        DSC=1
                        IF(K.GT.J)THEN
                          DSC=-DSC            !OVERALL PHASE - EJN (123)
                          IF(BFANO)DSC=-DSC
                        ENDIF
!                write(mw0,*)
!     &          k,j,mqj,mqjp !k.gt.j iff mqj.lt.mqjp (mqj.ne.mqjp)
                      ENDIF
!
                      DVECA(JG)=DVECA(JG)+DD1*DSC*SQRT(DD8)/(DFOUR*MJ)
                                                              !NONREL M1
!
                    ENDIF
!
 1262             ENDDO         !END LOOP OVER UPPER CI SLJP LEVELS
!
 1264             NCJ0=NCJ0+NSL(ND)
                ENDDO           !END LOOP OVER UPPER CI SLP GROUPS
!
 1265         ENDDO             !END LOOP OVER "LOWER" SLJP LEVELS
!
 1270         NCJP0=NCJP0+NPP
            ENDDO               !END LOOP OVER "LOWER" SLP GROUPS
!
 1280       NCJP=NCJP+NT(KK)
          ENDDO                 !END LOOP OVER "LOWER" JP GROUPS
!
          GO TO 1350
!
        ENDIF                   !END NON-REL M1
!
!**********************************************************************
!
! M1BP AND MK>1
!
!      IF(NGROUP.EQ.2.AND..NOT.BBORN)DVECV(J)=         !MK0/E1 REL VEL
!      DVECA(J)=                                       !MK1
!**********************************************************************
!
!
        IF(NGROUP.EQ.0)GO TO 1350                !ALLOW MK (K=NGROUP-1)
        IF(NGROUP.EQ.1.AND.MEKVMX.LT.2)GO TO 1350       !NO E1 REL VEL
        IF(NMD1(1,1,1).LT.0.AND.NMD2(1,1,1).LT.0)GO TO 1350
                                                        !NO MK
        IF(NGROUP.GT.2.AND.NMD1(1,1,1).LT.0)GO TO 1350  !NO MK
        MLAMM=MLAM-2                                 !TEST MLAM-2 FOR MK
        IF(NGROUP.EQ.1)MLAMM=MLAM
!
        NCJP=0
        DO KK=1,NJO                 !BEGIN LOOP OVER "LOWER" JP GROUPS
!
          IF(NMETGJ(KK)+NMETGJ(NDJ).GT.1)GO TO 1340
!
! FOR SPEED PRE-SELECT ACCORDING TO PARITY, TOTAL J:
!
          NC=NSLJ(1,KK)
          M=QPI(NC)+QPI(ND)
          IF(MOD(M+MLAM,IFOUR).NE.0)GO TO 1340
          MQJP=JN(NCJP+1)
          M=ABS(MQJ-MQJP)
          IF(M.GT.MLAMM)GO TO 1340
          M=MQJ+MQJP
          IF(M.LT.MLAMM)GO TO 1340
!
          NPP=NT(KK)
          DO NJP1=1,NPP
!
            J=NCJP+NJP1
            IF(IWRK4(J).GT.IAB-ione1)GO TO 1300
            IF(IWRK4(J).GT.IIMX)GO TO 1300
!       IF(IWRKX(J).LT.IIMN)GO TO 833    !IWRKX NOT SET-UP YET
            LSL=NRR(J)
            IF(NFK(LSL).LT.0)GO TO 1300
            IWRK4(J)=-ABS(IWRK4(J))           !FLAG EXISTS
!
 1300     ENDDO
!
          BEQGRP=KK.EQ.NDJ
          BING=NDJ.LE.KK
          IF(BING)THEN
            NU=KK
            NL=NDJ
            NNN=NCJP
            DS=1-MOD(ABS(MQJ-MQJP),IFOUR)
            IF(BFANO)DS=DS*(1-MOD(MLAMM,IFOUR))
          ELSE
            NU=NDJ
            NL=KK
            NNN=NCJ
            DS=1
          ENDIF
!
          NP=NT(NU)
          DO NJP=1,NP                    !LOOP OVER UPPER CI JP LEVELS
!
            J0=NNN+NJP
!
 1310       IF(BING)THEN
              J=J0
              IF(IWRK4(J).GT.0)GO TO 1330
            ELSE
              K=J0
              IF(.NOT.BJSEL)THEN           !LS SELECTION IMPOSED ON CI
                KSL=NRR(K)
                ND=NFQ(KSL)
                MQS=QSI(ND)
                MQL=QLI(ND)
                IF(MQS.NE.MNS)GO TO 1330
                IF(MQL.NE.MNL)GO TO 1330
              ENDIF
              if(idy(k-ncj).eq.0)go to 1330
              M=NADRUU+NAJ(K)
              DD1=TFUJ(M)
              IF(ABS(DD1).LT.CMXICR)GO TO 1330
              DD8=DD1*DS
            ENDIF
!
! 2-BODY
!
            IF(NGROUP.EQ.2.and.NMD2(1,1,1).GE.0)THEN
              N1=NMD2(1,NL,J0)
              N2=NMD2(2,NL,J0)
!        write(mw6,*)n1,n2,j,nl,j0
              DO N=N1,N2     !BEGIN 2-BODY LOOP OVER LOWER JP LEVELS
                N82=(MSS(N)-1)/IPLANT_MI                          !MAXMI
                MJ=INT(MSS(N)-N82*IPLANT_MI,SP)                   !MAXMI
                K0=INT(N82,SP)+1
!
                IF(BING)THEN
                  K=K0
                  IF(.NOT.BJSEL)THEN
                                !LS SELECTION RULES APPLIED
                    LSL=NRR(K)
                    NC=NFQ(LSL)
                    MNSP=QSI(NC)
                    MNLP=QLI(NC)
                    IF(MNS.NE.MNSP)GO TO 1315
                    IF(ABS(MNL-MNLP).GT.MLAMM)GO TO 1315
                    IF(MNL+MNLP.LT.MLAMM)GO TO 1315
                  ENDIF
                  if(idy(k-ncj).eq.0)go to 1315
                  M=NADRUU+NAJ(K)
                  DD1=TFUJ(M)
                  IF(ABS(DD1).LT.CMXICR)GO TO 1315
                  DD8=DD1*DS
                ELSE
                  IF(J0.EQ.K0)GO TO 1315          !AVOID DOUBLE COUNTING
                  J=K0
                  IF(IWRK4(J).GT.0)GO TO 1315
                ENDIF
!
!OLD          JG=J                       !STORE IN ORIGINAL GROUP POSITN
                jg=jwrkg0(kk-1)+naj(j)   !store in bound-bound c.f. tfuj
                if(bkutls)jg=jg+jwrkb(1,nfk(nrr(j)),kk)
!
                DVECA(JG)=DVECA(JG)+DNL(MJ)*DSS(N)*DD8           !REL M1
!          write(mw6,*)n,j,dveca(j)
 1315         ENDDO                !END 2-BODY LOOP OVER LOWER JP LEVELS
            ENDIF
!
! 1-BODY (REL)
!
            IF(NMD1(1,1,1).LT.0)GO TO 1330
            N1=NMD1(1,NL,J0)
            N2=NMD1(2,NL,J0)
!
!      write(mw6,*)nl,j0,n1,n2
!      if(n1.eq.0)go to 834
!
            DO N=N1,N2       !BEGIN 1-BODY LOOP OVER LOWER JP LEVELS
              N81=(NRKP(N)-1)/IPLANT_SOI                          !MXSOI
              MJ=INT(NRKP(N)-N81*IPLANT_SOI,SP)                   !MXSOI
              KX=QRLP(4,MJ)
              K0=INT(N81,SP)+1
!
              IF(BING)THEN
                K=K0
                IF(.NOT.BJSEL)THEN
                            !LS SELECTION RULES APPLIED
                  LSL=NRR(K)
                  NC=NFQ(LSL)
                  MNSP=QSI(NC)
                  MNLP=QLI(NC)
                  IF(MNS.NE.MNSP)GO TO 1320
                  IF(ABS(MNL-MNLP).GT.MLAMM)GO TO 1320
                  IF(MNL+MNLP.LT.MLAMM)GO TO 1320
                ENDIF
                if(idy(k-ncj).eq.0)go to 1320
                M=NADRUU+NAJ(K)
                DD1=TFUJ(M)
                IF(ABS(DD1).LT.CMXICR)GO TO 1320
                DD8=DD1*DS
              ELSE
                IF(J0.EQ.K0)GO TO 1320            !AVOID DOUBLE COUNTING
                J=K0
                IF(IWRK4(J).GT.0)GO TO 1320
              ENDIF
!
!OLD      JG=J                            !STORE IN ORGINAL GROUP POSITN
              jg=jwrkg0(kk-1)+naj(j)      !store in bound-bound c.f.tfuj
              if(bkutls)jg=jg+jwrkb(1,nfk(nrr(j)),kk)
!
              DRY=(DENERG(K)-DENERG(J))*2              !TEST K->I
!
!      write(mw6,*)n,kx,k,j,dry
!
              M1=QRLP(1,MJ)
              M2=QRLP(2,MJ)
!
              IF(KX.NE.2.AND.KX.NE.3)THEN
                if(m2.gt.m1)stop 'sr.diagfs:m2.gt.m1...'   !shouldn't be
                IN=ICOL(M2,M1,IZERO)
              ENDIF
!
              in1=icol(m1,m1,izero)
              in2=icol(m2,m2,izero)
!
              dry0=dey(m1)-duy(in1)-(dey(m2)-duy(in2))
                                                   ! a.u.
              dry0=abs(dry0+dry0)                  !abs <- falling order
!      if(nfk(it).lt.0)dry=dry+dyy(nrel)*2
              if(nfk(it).lt.0)dry=dry0
!      dry=dry0                                    !test use of orb ener
              IF(KX.GT.8)THEN                         !1-BODY MK
                IF(QRLP(3,MJ).NE.MLAMM)GO TO 1320     !WRONG MULTIPOLE
                DSC=DRLP1(MJ)
                IF(KX.EQ.9.AND.BREL)THEN
!         write(mw6,*)dsc
                  IF(.NOT.BEKVEL)DVECV(JG)=DVECV(JG)+DRKP(N)*DD8*DSC
                                                                    !MK0
                  IF(NFK(IT).GT.0.AND.irtard.GE.0)THEN
                    IF(.NOT.BREL2)THEN
!                     2* for spin
                      DSC=DSC-2*DALF4*DRY*DRY*DOSC(IN,NGROUP/2)         &
     &                    /(4*NGROUP-2)
!           write(mw6,*)m1,m2,ngroup,dsc,dry,dosc(in,ngroup/2)
                    ELSEIF(.NOT.BEKVEL)THEN
                      IF(NGROUP.GT.2)THEN
                        DSC0=DOSC(IN,NGROUP/2-1)
                      ELSE
                        IF(M1.EQ.M2)THEN
                          DSC0=DONE
                        ELSE
                          DSC0=DZERO
                        ENDIF
                      ENDIF
                      DVECV(JG)=DVECV(JG)+DRKP(N)*DD8*(DSC0-DSC)    !MK0
                    ENDIF
                  ELSE
!           already retarded
                  ENDIF
                ENDIF
                DSC=DRKP(N)*DD8*DSC               !DD1->DD8
                IF(KX.EQ.10)DSC=DSC*DRY*DRY     !*DALF4 sync with radbp1
!
!        write(mw6,*)
!     &  ngroup,i,j,k,kx,qrlp(1,mj),qrlp(2,mj),dsc,drkp(n),drlp1(mj),dry
!
                DVECA(JG)=DVECA(JG)+DSC                             !MK1
!
!       if(kx.eq.10)write(mw6,*)dry,drlp1(mj),DRKP(N)*DD8,j,jg,dveca(jg)
!       write(mw6,*)j,jg,dveca(jg)
!
! qrlp -> m1.gt.m2
                IF(.NOT.BFOTJ.AND.NFK(IT).LT.0)THEN
                                                  !PHOTO
                  IF(KX.EQ.9)THEN
                    M7=NFOSS((ngroup-2)/2,M2,M1)
                    IF(M7.GT.0)THEN
                      DSC=DRKP(N)*DD8
                      DO M8=1,MENG
!                DVECM(M8,JG)=DVECM(M8,JG)+DFOSS(M7,M8,1)*DSC
                        DVECM(JG,M8)=DVECM(JG,M8)+DFOSS(M7,M8,1)*DSC
!                write(mw6,*)m8,m7,DFOSS(M7,M8,1),dsc,j,jg,dvecm(jg,m8)
                      ENDDO
                    ENDIF
                  ELSE                            !KX.EQ.10
                    M7=NFOSS(ngroup/2,M2,M1)
                    IF(M7.GT.0)THEN
                      DSC=DRKP(N)*DD8*DALF4
                      dry0=-(dey(m2)-duy(in2))  !a.u.
!              dry0=abs(denerg(k)-denerg(j))
                      DO M8=1,MENG
                        DRY2=(dry0+DYY(M8))*2
!                DVECM(M8,JG)=DVECM(M8,JG)+DFOSS(M7,M8,1)*DSC*DRY2*DRY2
                        DVECM(JG,M8)=DVECM(JG,M8)+DFOSS(M7,M8,1)        &
     &                               *DSC*DRY2*DRY2
!      write(mw6,*)m8,dry2,m7,DFOSS(M7,M8,1),dsc/DALF4,j,jg,dvecm(jg,m8)
                      ENDDO
                    ENDIF
                  ENDIF
                ENDIF
                GO TO 1320
              ENDIF
!
              IF(NGROUP.GT.2)GO TO 1320
                                       !ORIGINAL REL PERT IS DIPOLE ONLY
!
              DSC=DRLP1(MJ)
!      write(mw6,*)'kx=',kx,m1,m2,dsc
!       dry0=dry                               !test use of level energy
!                                              !check rad/radial
              btest=kx.eq.4.or.kx.eq.6.or.kx.eq.7.or.kx.eq.8
              if(igagr.gt.0.and.btest.and.ql(m1).eq.ql(m2))then
                if(qn(m1).ne.qn(m2))then
!                  mx=max(m1,m2)
!                  mn=min(m1,m2)
                  tt=dry0*dry0*dosc(in,ngroup/2)/4
!      write(mw6,*)'kx=',kx,mx,mn,dry0,dosc(in,ngroup/2)
! case l1=n1-1, l2.lt.l1 only                          !check rad/radial
                  if(ql(m1).ne.ql(m2))then
                    t1=real(min(ql(m1),ql(m2))/2+1,wp)
                    t2=real(max(ql(m1),ql(m2))+1,wp)
                    tt=-tt*t1/t2
                  endif
                else
                  tt=2*(dey(m1)-duy(in1))+2*(dey(m2)-duy(in2))
! case l1=n1-1, l2.lt.l1 only                          !check rad/radial
                  if(ql(m1).ne.ql(m2))then
                    t1=real(min(ql(m1),ql(m2))/2+2,wp)
                    t2=real(max(ql(m1),ql(m2))+1,wp)
                    tt=tt/sqrt(t1*t2)
                  endif
                endif
              else
                tt=dzero
              endif
              IF(KX.EQ.8)THEN
                DSC=(tt-D2LL(IN)-DSC*DRY*DRY/D20)*DALF4*DTWO
                IF(M2.EQ.M1)THEN
                  DSC=DSC+1
                  IF(.NOT.BEKVEL)DVECV(JG)=DVECV(JG)+DD8*DRKP(N) !REL M0
                ENDIF
              ELSEIF(KX.EQ.7)THEN
                IF(igagr.GT.0.AND.ql(m1).EQ.ql(m2))THEN
                                                       !check rad/radial
                  dsc=tt*DALF4*nzion/nza
                else
                  DSC=-NZION*DSC
                endif
              ELSEIF(KX.EQ.5)THEN
                DSC=DRY*DRY*DSC/D20
              ELSEIF(KX.EQ.6)THEN
                DSC=DRY*DSC+(tt-D2LL(IN))*DALF4
              elseif(kx.eq.4)then
                dsc=dsc-tt*DALF4
              ENDIF
!
              DRAC=DD8*DRKP(N)*DSC
!      write(mw6,*)'kx=',kx,m1,m2,tt,dsc,drkp(n),drac,dveca(jg),j,jg
!
              IF(QPI(NC).NE.QPI(ND))THEN
!        write(mw6,*)dvecv(jg),drac
                IF(BVEL)DVECV(JG)=DVECV(JG)+2*NZION*DRAC/DRY
                                               !REL E1(VEL)
              ELSE
                DVECA(JG)=DVECA(JG)+DRAC       !REL M1
!        write(mw6,*)j,jg,kx,dveca(jg)-drac,dveca(jg),dvecv(jg)
              ENDIF
!        write(mw6,*)qrlp(1,mj),qrlp(2,mj),kx,drkp(m),dsc
!
 1320       ENDDO                  !END 1-BODY LOOP OVER LOWER JP LEVELS
!
 1330       IF(BEQGRP)THEN      !PICK-UP OTHER HALF
              IF(BING)THEN
                BING=.FALSE.
                GO TO 1310
              ELSE
                BING=.TRUE.
              ENDIF
            ENDIF
!
          ENDDO                 !END LOOP OVER UPPER CI JP LEVELS
!
 1340     NCJP=NCJP+NT(KK)
        ENDDO                   !END LOOP OVER "LOWER" JP GROUPS
!
! END M1BP AND MK>1
!
!**********************************************************************
!
! END LOOPS OVER EK, MK CONNECTION TO UPPER ENERGY LEVELS
!
!**********************************************************************
!
 1350   CONTINUE
!
        if(btime)then
          call nrb_time(timefr)
          timer1=timer1+timefr-timeir
          timeir=timefr
        endif
!
! *********************************************
!
! START LOOP OVER LOWER ENERGY LEVELS (EK & MK)
!
!**********************************************
!
        SUMRN(0)=DZERO
        SUMRD(0)=DZERO
        IF(NMM.GT.0)THEN
          NMM=NMM0
          IF(NMETAPJ.GT.0)NMM=MIN(NMM,JRP(IIMX))
          DO K=1,NMM
            SUMRN(K)=DZERO
            SUMRD(K)=DZERO
          ENDDO
        ENDIF
!
        IF(BUNPR.AND.NFK(IT).LT.0)THEN
          I3P=ABS(IWRK3(I))
          IF(I3P.NE.JPOLD)THEN                 !NEW UPPER PI STATE
            DO M8=1,MENG
              SUMPN(M8,0)=DZERO
              SUMPD(M8,0)=DZERO
            ENDDO
            DO K=1,NMM
              DO M8=1,MENG
                SUMPN(M8,K)=DZERO
                SUMPD(M8,K)=DZERO
              ENDDO
            ENDDO
            IF(BUNA)JPOLD=I3P                  !SUM OVER NMETA CONT
          ENDIF
        ENDIF
!
        ILI=0
        DO JAB=IIMN,IIMX
!
          IF(.NOT.BAUX.AND.JORIG(JAB).LT.0)GO TO 1450
          IF(JORIG(JAB).GT.0)THEN
            ILI=ILI+1
            IF(KTRAN.GE.0)KTRAN=KTRAN+1
          ENDIF
          J=ABS(JORIG(JAB))
          IF(IWRK4(J).GT.0)GO TO 1450
          IF(ABS(MENGB).EQ.1.AND.MOD(NGROUP,ITWO).EQ.1)THEN
            IX=IROW(ILI,ILF,ione1,NSPECE)
            IF(OMR(IX).LT.-TOLO)GO TO 1450
                                        !****DIPOLE ALREADY COMPUTED****
          ENDIF
          ITP=NRR(J)
!      if(dvecl(j).eq.dzero)
!     & write(133,*)NFK(IT),iab,i,' - ',nfk(itp),jab,j
!
          IF(IDIAG.GE.0.AND.BDEL)THEN
            MRD=0
            I5=0
            M3=NFK(IT)
            M3=ABS(M3)
            M4=NFK(ITP)
            DO I3=1,MXORB
              I4=NEL(I3,M3)-NEL(I3,M4)
              IF(I4.NE.0)THEN
                I5=I5+1
                MRDP=MRD
                MRD=ABS(QN(I3))
                ISGN=1-2*mod(abs(I5),ITWO)         !(-1)**I5
                IF(ISGN.GT.0.AND.ABS(MRD-MRDP).GE.MDEL)GO TO 1360
              ENDIF
            ENDDO
            GO TO 1450
 1360       CONTINUE
          ENDIF
!
! START LOOP (L1,L2) OVER LOWER ENERGY LEVEL MIXING
!
          DLEN=DZERO                            !EK_L
          DVEL=DZERO                            !EK_V OR MK0
          DMK1=DZERO                            !MK1
          IF(.NOT.BFOTJ.AND.NFK(IT).LT.0)THEN   !PHOTO
            DO M8=1,MENG
              DFOT(M8)=DZERO
              DFOTm(M8)=DZERO
            ENDDO
          ENDIF
!
          II=NFQ(ITP)
          MNSP=QSI(II)
          MNLP=QLI(II)
          DZ8=JN(J)+1
          NN=NGR(J)
!
! e-vector storage posn
!
          if(bkutls)then                  !could do better...?
            l1=jwrkg0(nn-1)+jwrkb(1,nfk(itp),nn)
            l2=l1+jwrkb(2,nfk(itp),nn)
          else
            l1=jwrkg0(nn-1)
            l2=jwrkg0(nn)
          endif
          M0=L2-L1
!
          N1=NADRUJ(J)                           !START OF MIXING VECTOR
!
          IF(BKUTDSK)THEN
!
            CALL DISKTF(NN,N1,M0,TFUJ(IAXDK+1),IONE)
!
            N1=IAXDK
          ENDIF
!
          IF(BFAST)THEN
            IF(BFOTJ.OR.NFK(IT).GT.0)THEN
          IF(LAPAK.GT.0)THEN                                     !LAPACK
            DLEN=DDOT(M0,TFUJ(N1+1),IONE,DVECL(L1+1),IONE)       !LAPACK
          ELSE                                                   !LAPACK
              DO M=1,M0
                DLEN=DLEN+TFUJ(N1+M)*DVECL(L1+M)
              ENDDO
          ENDIF                                                  !LAPACK
            ELSE
          IF(LAPAK.GT.0)THEN                                     !LAPACK
            DLEN=DDOT(M0,TFUJ(N1+1),IONE,DVECL(L1+1),IONE)       !LAPACK
            DO M8=1,MENG                                         !LAPACK
          DFOT(M8)=DDOT(M0,TFUJ(N1+1),IONE,DVECF(L1+1,M8),IONE)  !LAPACK
              IF(NGROUP.GT.1)                                           &!LAPACK
     &   DFOTM(M8)=DDOT(M0,TFUJ(N1+1),IONE,DVECM(L1+1,M8),IONE)  !LAPACK
            ENDDO                                                !LAPACK
          ELSE                                                   !LAPACK
              DO M=1,M0
                DLEN=DLEN+TFUJ(N1+M)*DVECL(L1+M)
              ENDDO
              DO M8=1,MENG
                DO M=1,M0
                  DFOT(M8)=DFOT(M8)+TFUJ(N1+M)*DVECF(L1+M,M8)
                ENDDO
                IF(NGROUP.GT.1)THEN
                  DO M=1,M0
                    DFOTM(M8)=DFOTM(M8)+TFUJ(N1+M)*DVECM(L1+M,M8)
                  ENDDO
                ENDIF
              ENDDO
          ENDIF                                                  !LAPACK
            ENDIF
          ELSE
            IF(BBORN)THEN                        !BORN
              DO K=1,MB3(0)
                SBL(K)=DZERO
              ENDDO
            ENDIF
            L1=L1+1
            DO L=L1,L2
              N1=N1+1                           !NADRUJ(J)+NAJ(L)
              DD2=TFUJ(N1)
              IF(ABS(DD2).LT.CMXICR)GO TO 1370
              IF(.NOT.BJSEL)THEN
                             !LS SELECTION RULES IMPOSED ON CI
                lb=iwrkj(l)                     !lb=l mode.ne.2
                LSL=NRR(lb)
                IB=NFQ(LSL)
                MQSP=QSI(IB)
                MQLP=QLI(IB)
                IF(MQLP.NE.MNLP)GO TO 1370
                IF(MQSP.NE.MNSP)GO TO 1370
              ENDIF
              DLEN=DLEN+DD2*DVECL(L)
              DVEL=DVEL+DD2*DVECV(L)
              DMK1=DMK1+DD2*DVECA(L)
              IF(BBORN)THEN                      !BORN
                IBO=ID(L)
                IF(IBO.GT.0)THEN
                  DO M=1,MB3(0)
                    SBL(M)=SBL(M)+DD2*DBL(M,IBO)
                  ENDDO
                ENDIF
              ENDIF
              IF(.NOT.BFOTJ.AND.NFK(IT).LT.0)THEN
                                                 !PHOTO
                DO M8=1,MENG
!              DFOT(M8)=DFOT(M8)+DD2*DVECF(M8,L)
                  DFOT(M8)=DFOT(M8)+DD2*DVECF(L,M8)
                ENDDO
                IF(NGROUP.GT.1)THEN
                  DO M8=1,MENG
!                DFOTm(M8)=DFOTm(M8)+DD2*DVECM(M8,L)   !merge with ek?
                    DFOTm(M8)=DFOTm(M8)+DD2*DVECM(L,M8)
                                                      !merge with ek?
                  ENDDO
                ENDIF
              ENDIF
 1370       ENDDO
          ENDIF
!
! END LOOP OVER LOWER LEVEL MIXING
!
!      if(dlen.eq.dzero)write(134,*)NFK(IT),iab,i,' - ',nfk(itp),jab,j
          OBOX=DZERO
          IF(MENGB.EQ.-1.AND.ABS(DLEN).GT.WLGO)OBOX=D1P30
          IF(NGROUP.EQ.0)DLEN=DZERO
          IF(NGROUP.GT.0.AND.ABS(DLEN).LT.DEPS.AND.ABS(DMK1)            &
     &       .LT.DEPS.and.nfk(it).gt.0)GO TO 1450
!
! BORN MULTIPOLES
!
          IF(BBORN)THEN !BORN
            DO IE=1,MENGB
              OBO(IE)=DZERO
            ENDDO
            OMG1=DZERO
            DLAM=2*NGROUP+1
            NH=NGROUP/2
            DO N=1,MB4(0)
              L=INDL(N)
              K=INDK(N)
              SSB=SBL(K)*SBL(L)
              IF(ABS(SSB).GT.STOL)THEN
                DO IE=1,MENGB
                  DB=SSB*BL(IE,N,NH)
!              if(db.ne.dzero)iflagb(n)=abs(iflagb(n))   !flag used
                  OBO(IE)=OBO(IE)+DB+DB
                  IF(L.EQ.K)OBO(IE)=OBO(IE)-DB
                ENDDO
                IF(NGROUP.EQ.1)THEN
                  DB=SSB*TM2(N)
                  OMG1=OMG1+DB+DB
                  IF(L.EQ.K)OMG1=OMG1-DB
                ENDIF
              ENDIF
            ENDDO
            DB=DEIGHT*DLAM
            DO IE=1,MENGB
              OBO(IE)=DB*OBO(IE)
            ENDDO
            OBOX=OBO(MINFB)
            OMG1=DB*OMG1
          ENDIF
!
! ELECTRIC AND MAGNETIC MULTIPOLES
!
          JOS=JOS+1
          DRY=DENERG(I)-DENERG(J)
          IF(DRY.EQ.DZERO)then
            IF(iab.NE.jab.AND.mengb.LT.-1)GO TO 1450
                                                  !CASE M1/E2 DEGENERATE
            dry=d1m10
          endif
!
          IF(NFK(IT).LT.0)DRY=DRY+DYY(NREL)
          DRY=DRY+DRY
          MI=IAB
          MJ=JAB
          IF(NFK(IT).LT.0)MI=-MI
!     IF(NFK(ITP).LT.0)MJ=-MJ
          MWJ=JN(J)+1
          MWI=JN(I)+1
          MBCOR=MBLK
          IF(JORIG(IAB).LT.0.OR.JORIG(JAB).LT.0)MBCOR=MCOR
          WLG=ABS(WLG)
          IF(NFK(IT).LT.0)WLG=-WLG
!      ISGNJ=1-2*mod(abs((JN(I)-JN(J))/2),2)   !(-1)**((JN(I)-JN(J))/2)
!      ISGN=ISGNJ                                !SWITCH DOWN TO UP ON F
!      IF(BFANO)ISGN=ISGN*ISGNN
          ISGN=1                                 !ALL DOWN
          DB=ISGN*(DRY*DFSC)**(MLAM-1)/DFSC
          if(db.eq.dzero)then                    !avoids overflow*zero
            dlen=dzero
            dvel=dzero
            dmk1=dzero
          endif
          SEK=ABS(DLEN)*DLEN                         !SEK_L
          GFL=DG(NGROUP)*DB*SEK                      !GF_L
          IF(NFK(IT).GT.0)AEK=C1*GFL*DRY*DRY/DZ9     !AEK
          IF(NFK(IT).LT.0)AEK=C2*GFL/DZ8
          WLEN=D1P8/(DRY*DKCM)                       !WAVELENGTH(A)
!
          IF(NGROUP.GT.1.AND.BMPRNT)THEN             !MAGNETIC
            IF(BEKVEL)THEN
              SMK0=DZERO                             !SMK0
              GFV=DG(NGROUP)*DB*ABS(DVEL)*DVEL/(DRY*DRY)
                                                     !GF_V
              GFLV=GFV
            ELSE
              SMK0=ABS(DVEL)*DVEL                    !SMK0
              GFLV=GFL
            ENDIF
            SMK1=ABS(DMK1)*DMK1                      !SMK1
            AMK=DG(NGROUP-1)*ABS(SMK1)*DB/4
            if(ngroup.eq.2.and..not.bborn)then       !lande
              if(iab.eq.jab.and.jn(i).ne.0)then
                t=jn(i)*(jn(i)+2)*(jn(i)+1)
                glande=abs(dmk1)*dtwo/sqrt(t)
              else
                glande=dzero
              endif
              obox=glande                            !print transfer
            endif
          ELSE
            IF(NGROUP.GT.1.AND..NOT.BMPRNT)THEN
              SMK=ABS(DMK1)*DMK1                     !SMK
              AMK=DG(NGROUP-1)*ABS(SMK)*DB/4
            ELSE
              AMK=DZERO
            ENDIF                                    !omit dry if orb de
            GFV=DG(NGROUP)*DB*ABS(DVEL)*DVEL/(DRY*DRY)
                                                     !GF_V
            FAB=DTEN**MP*GFL/DZ8                     !F(UP)_L
            FEM=DTEN**MP*GFL/DZ9                     !F(DOWN)_L
          ENDIF
          IF(NFK(IT).GT.0)AMK=C1*AMK/DZ9             !AMK
          IF(NFK(IT).LT.0)AMK=C2*AMK/(DZ8*DRY*DRY)
!
!                Lt. for PI underflow at low-E (but not at high-E)
          IF(AEK*AEK.LT.ABS(AEK)*WLG.AND.ABS(OBOX).LT.WLGO.AND.         &
     &       GFL*GFL.LT.WLGS.AND.AMK*AMK.LT.ABS(AMK)*WLG)GO TO 1450
!                but amk=0 for E1, so no drop. need to add .and.wlg.gt.0
!
          IF(.NOT.BELONG.AND.ABS(AEK).GT.WLG)THEN    !USE VEL AEK,SEK
            AEK=GFV*AEK/GFL
            SEK=GFV*SEK/GFL
          ENDIF
!
          IF(NGROUP.EQ.1)THEN
            APOL=DFOUR*ABS(FAB)/(DRY*DRY)        !POLARIZABILITY (a_0^3)
            IF(.NOT.BELONG)APOL=APOL*ABS(GFV/GFL)
            OMG=DFOUR*GFL/DRY
            IF(ABS(MENGB).EQ.1)THEN
              OMGINF=-ABS(OMG)
              OMG=OMG*LOG(EINF*DZ2)
              OMG=-ABS(OMG)                         !TAG DIPOLE NEGATIVE
              IF(OMG.GE.-TOLO)OMG=DZERO      !ZERO VANISHINGLY SMALL CPT
            ELSEIF(MENGB.GT.1)THEN
              OMG=-ABS(OMG)                          !4S/3
              if(nmetaj.eq.0)nmetaj=iimx             !pwb
            ENDIF
            if(idw.eq.0)then
              if(nmetaj.eq.0)nmetaj=nenerg           !for RM
            else
              if(nmetaj.eq.0)nmetaj=iimx
            endif
          ELSE
            APOL=OBOX                                !COPY BORN IN
            OMG=OBOX
            IF(OMG.LT.DZERO)OMG=D1M30                !keep non-negative
            OMGINF=OMG
          ENDIF
!
! DETERMINE BORN OMEGAS
!
          BPRNTO=.FALSE.
          IF(MPOL00.EQ.0.AND.MBCOR.EQ.MBLK)THEN
                                              !MPOL0 CATCHES E1
            IF(ABS(MENGB).EQ.1)THEN          !INFINITE ENERGY BORN ONLY
              BPRNTO=.TRUE.
              IXC=ICOL(ILI,ILF,ione1)
              IF(IXC.LE.NOMWRX)OMC(IXC)=OMC(IXC)+OMG
              IXR=IROW(ILI,ILF,ione1,NSPECE)
              IF(IXR.LE.NOMWRX)OMR(IXR)=OMR(IXR)+OMG
              OMEGAB(MXNXB1)=OMGINF
            ELSEIF(MENGB.GT.1)THEN                          !FINITE BORN
              IF(ABS(OBO(MINFB)).GT.WLGO)THEN
                BPRNTO=.TRUE.
                CALL BRNINT(BPRNT0,NLAGB,MXNXB,MV0,MV1,DRY,V0,V1,XB,XS, &
     &                      DB0,DB1,OMG1,OBO,OMEGAB)
                OMEGAB(MXNXB1)=OMG                   !INFINITE ENERGY
!            if(nlagb.lt.0)go to 3000                !brnint failure
              ELSEIF(ABS(AMK).GT.WLG)THEN            !ONLY M_K HERE
                BPRNTO=.TRUE.
                DO K=1,MXNXB1
                  OMEGAB(K)=DZERO
                ENDDO
              ENDIF
            ENDIF
          ENDIF
!
! OUTPUT ELECTRIC AND MAGNETIC MULTIPOLE DATA.
!
!          aek=dzero                          !***test output mk only***
!          amk=dzero                          !***test output ek only***
          IF(BPRNT0)THEN
            IF(NGROUP.GT.1.AND.BMPRNT)WRITE(MW6,10430)JOS,MBCOR,MI,MJ,  &
     &         AEK,AMK,SEK,SMK1,SMK0,GFLV,WLEN,OBOX
            IF(NGROUP.LT.2.OR..NOT.BMPRNT)WRITE(MW6,10420)JOS,MBCOR,MI, &
     &         MJ,AEK,SEK,GFL,FAB,FEM,WLEN,GFV,APOL
          ENDIF
          IF(BPRNTO)THEN
            T=ABS(AEK)+ABS(AMK)
            IF(BSCRO)THEN
              WRITE(MSC)MI,MJ,T,(OMEGAB(K),K=1,MXNXB1)
            ELSE
              OMEGA(0,KTRAN)=OMEGA(0,KTRAN)+REAL(T,RP)
              T=REAL(OMEGA(MXNXB1,KTRAN),WP)
              KMX=MXNXB1
              IF(MOD(NGROUP,ITWO).EQ.1.AND.T.LT.-TOLO)KMX=MXNXB
                                                             !OLD DIPOLE
              DO K=1,KMX
                OMEGA(K,KTRAN)=OMEGA(K,KTRAN)+REAL(OMEGAB(K),RP)
              ENDDO
            ENDIF
          ENDIF
!
          IF(MODE.LT.1)GO TO 1400
          DB=DENERG(J)+DENERG(J)+DEM
          IF(NFK(IT)*NFK(ITP).LT.0)GO TO 1380
!
          IF(JAB.LE.JLOWMX.AND.DB.LE.etest.AND.IHARRY(NFK(ITP))         &
     &       .LE.NRSLMX)THEN                                   !RESOLVED
            IF(NGROUP.GT.1)AEK=ABS(AEK)+ABS(AMK)            !OUT MK + EK
            IF(ABS(AEK).LT.WLG)GO TO 1450
            IF(BPRNT0)WRITE(MW8,10140)NFK(IT),I,MWI,NFK(ITP),J,MWJ,AEK, &
     &                                DRY,DB
            IF(.NOT.BPRNT0)WRITE(MW28)int(NFK(IT)),int(I),int(MWI),     &
     &                                int(NFK(ITP)),int(J),int(MWJ),AEK,&
     &                                DRY,DB
          ELSEIF(BUNR)THEN                                      !BUNDLED
            T=ABS(AEK)+ABS(AMK)
            IF(BDOWN)THEN                       !USED BY ADASDR & ADASPE
              M=0
              IF(NFK(ITP).LE.-NRSLMX)M=NFK(ITP)
            ELSE                                !NOT USED BY PP'S....
              T=T*MWI
              T=T/MWJ
              M=JAB
            ENDIF
            IF(DB.LT.EIONMN)THEN
              SUMRN(M)=SUMRN(M)+T
            ELSE
              SUMRD(M)=SUMRD(M)+T
            ENDIF
          ENDIF
          GO TO 1400
!
 1380     IF(BFOTJ)GO TO 1450
          DTEST=ABS(DFOT(MENG))
          IF(NGROUP.GT.1)DTEST=DTEST+ABS(DFOTm(MENG))
          IF(DTEST.EQ.DZERO)GO TO 1450
!
! N.B. SIGN OF REDUCED MATRIX ELEMENT IS FOR DOWNWARD TRANSITION.
! TO GET SIGN FOR UPWARD TRANSITION, UNCOMMENT NEXT DO-LOOP.
!      DO  M8=1,MENG
!        DFOT(M8)=DFOT(M8)*ISGN
!        IF(NGROUP.GT.1)THEN
!          DFOTm(M8)=DFOTm(M8)*ISGN
!        ENDIF
!      ENDDO
!
          DC0=C2*DG(NGROUP)/(DZ8*DFSC)
          T=DENERG(I)-DENERG(J)
          DO M8=1,MENG
            DRY=T+DYY(M8)
            DRY=DRY+DRY
            T1=DRY*DFSC
            TT=T1**NGROUP
            TT=TT*DFOT(M8)
            DFOT(M8)=DC0*TT*ABS(TT)/T1
            IF(BPRNT0.AND.ABS(DFOT(M8)).LT.D1M99)DFOT(M8)=DZERO
!test
!      dfot(m8)=0     !***** LOOK AT MAGNETIC OUTPUT  ONLY *****
!test
          ENDDO
          IF(NGROUP.GT.1)THEN
            DC0=C2*DG(NGROUP-1)*DFSC/(4*DZ8)
            DO M8=1,MENG
              DRY=T+DYY(M8)
              DRY=DRY+DRY
              T1=DRY*DFSC
              TT=T1**NGROUP
              TT=TT*DFOTm(M8)
              DFOTm(M8)=DC0*TT*ABS(TT)/T1**3
              IF(BPRNT0.AND.ABS(DFOTm(M8)).LT.D1M99)DFOTm(M8)=DZERO
!test
!      dfotm(m8)=0     !***** LOOK AT ELECTRIC OUTPUT  ONLY *****
!test
            ENDDO
          ENDIF
!
! AEK IS GIVEN BY RADIATIVE IGAUGE, DFOT IS GIVEN BY PI GAUGE.
!
          IF(JAB.LE.JLOWMX.AND.DB.LE.etest.AND.IWRK2(I).LE.JIMXIC.AND.  &
     &       IHARRY(NFK(ITP)).LE.-NMM)THEN                     !RESOLVED
            DRY=DENERG(I)+DENERG(I)+DEM
            IF(NGROUP.GT.1)THEN                             !OUT MK + EK
              AEK=ABS(AEK)+ABS(AMK)
              DO M8=1,MENG
                DFOT(M8)=ABS(DFOT(M8))+ABS(DFOTm(M8))
              ENDDO
            ENDIF
            IF(BPRNT0)THEN
              WRITE(MW18,10140)NFK(ITP),J,MWJ,NFK(IT),I,IWRK2(I),AEK,DB,&
     &                         DRY
              WRITE(MW18,10280)(DFOT(M8),M8=1,MENG)
            ELSE
              WRITE(MW30)int(NFK(ITP)),int(J),int(MWJ),int(NFK(IT)),    &
     &                   int(I),int(IWRK2(I)),AEK,DB,DRY
              WRITE(MW30)(DFOT(M8),M8=1,MENG)
            ENDIF
          ELSEIF(BUNPR)THEN                                     !BUNDLED
            DO M8=1,MENG
              DFOT(M8)=ABS(DFOT(M8))
            ENDDO
            IF(NGROUP.GT.1)THEN                             !OUT MK + EK
              DO M8=1,MENG
                DFOT(M8)=DFOT(M8)+ABS(DFOTm(M8))
              ENDDO
            ENDIF
            IF(BDOWN)THEN                          !AS RESOLVED PI IS UP
              M=0
              IF(NFK(ITP).LE.-NRSLMX)M=NFK(ITP)
              TW=MWJ
              TWW=DALF4*TW/MWI
              DO M8=1,MENG
                DRY=T+DYY(M8)
                DRY=DRY+DRY
                DFOT(M8)=DFOT(M8)*DRY*DRY*TWW
              ENDDO
            ELSE                                !AS ONLY CONT IS BUNDLED
              M=JRP(JAB)
            ENDIF
            IF(DB.LT.EIONMN)THEN
              DO M8=1,MENG
                SUMPN(M8,M)=SUMPN(M8,M)+DFOT(M8)
              ENDDO
            ELSE
              DO M8=1,MENG
                SUMPD(M8,M)=SUMPD(M8,M)+DFOT(M8)
              ENDDO
            ENDIF
          ENDIF
          GO TO 1450
!
! SET UP ARRAY CONTAINING DIPOLE TRANSITION RATES FOR USE BY CASC
!
 1400     IF(BCASC)THEN
            NTRAN=NTRAN+1
            IF(NTRAN.GT.IXNOR)THEN
              IXXX=7*(IXNOR/5+1)
!
              WRITE(MW6,*)'*** DIAGFS: increasing MXNOR from ',IXNOR,   &
     &                    ' to: ',IXXX
              WRITE(MW0,*)'*** DIAGFS: increasing MXNOR from ',IXNOR,   &
     &                    ' to: ',IXXX
!
              CALL RE_ALLOC(AP,IONE,IXNOR,IXXX,IERR)
              CALL RE_ALLOC(MADD,IZERO,IXNOR,IXXX,IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)'DIAGFS: RE-ALLOCATION FAILS FOR AP,MADD'
                NF=0
                GO TO 1700
              ENDIF
              IXNOR=IXXX
            ENDIF
            AP(NTRAN)=ABS(AEK)
            MADD(NTRAN)=(IAB-1)*NENERG+JAB-1
          ENDIF
!
!
 1450   ENDDO                                !END LOOP OVER LOWER LEVELS
!
        IF(ALLOCATED(DBL))DEALLOCATE(DBL,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGFS: DE-ALLOCATION FAILS FOR DBL'
          NF=0
          GO TO 1700
        ENDIF
!
        if(btime)then
          call nrb_time(timefr)
          timer2=timer2+timefr-timeir
        endif
!
!                                                           !UNRESOLVED
        WLG=ABS(WLG)
        IF(SUMRN(0).GT.WLG)THEN
          IF(BPRNT0)WRITE(MW8,10140)NFK(IT),I,MWI,IZERO,IZERO,IZERO,    &
     &                              SUMRN(0),DZERO,DEM
          IF(.NOT.BPRNT0)WRITE(MW28)int(NFK(IT)),int(I),int(MWI),       &
     &                              int(IZERO),int(IZERO),int(IZERO),   &
     &                              SUMRN(0),DZERO,DEM
        ENDIF
        IF(SUMRD(0).GT.WLG)THEN
          IF(BPRNT0)WRITE(MW8,10140)NFK(IT),I,MWI,IZERO,IZERO,IZERO,    &
     &                              SUMRD(0),DZERO,DZERO
          IF(.NOT.BPRNT0)WRITE(MW28)int(NFK(IT)),int(I),int(MWI),       &
     &                              int(IZERO),int(IZERO),int(IZERO),   &
     &                              SUMRD(0),DZERO,DZERO
        ENDIF
!                                                           !CF RESOLVED
        DO M=1,NMM
          IF(SUMRN(M).GT.WLG)THEN
            IF(BPRNT0)WRITE(MW8,10140)NFK(IT),I,MWI,JCP(M),JTP(M),      &
     &                                JWRN(M),SUMRN(M),DZERO,ERN(M)
            IF(.NOT.BPRNT0)WRITE(MW28)int(NFK(IT)),int(I),int(MWI),     &
     &                                int(JCP(M)),int(JTP(M)),          &
     &                                int(JWRN(M)),SUMRN(M),DZERO,ERN(M)
          ENDIF
          IF(SUMRD(M).GT.WLG)THEN
            IF(BPRNT0)WRITE(MW8,10140)NFK(IT),I,MWI,JCP(M),JTP(M),      &
     &                                JWRD(M),SUMRD(M),DZERO,ERD(M)
            IF(.NOT.BPRNT0)WRITE(MW28)int(NFK(IT)),int(I),int(MWI),     &
     &                                int(JCP(M)),int(JTP(M)),          &
     &                                int(JWRD(M)),SUMRD(M),DZERO,ERD(M)
          ENDIF
        ENDDO
!
        IF(.NOT.BUNPR.OR.NFK(IT).GT.0)GO TO 1500
!
        IF(JPOLD.LE.0)THEN
          JP=I
        ELSE
          IF(IAB.LT.JJMX)THEN
            JP=ABS(JORIG(IAB+1))
            JPNEW=ABS(IWRK3(JP))
            IF(IWRK2(I).GT.JIMXIC)JPOLD=JPNEW
          ELSE
            JPNEW=-1
            IF(IWRK2(I).GT.JIMXIC)THEN
              JPOLD=NENERG+1
              jpt=NNRGLS+1
              nrr(JPOLD)=jpt                   !we now allocate nenerg+1
              NFK(jpt)=0
              IWRK2(JPOLD)=0
              DENERG(JPOLD)=DZERO
              DEM=DZERO
            ENDIF
          ENDIF
          IF(JPNEW.EQ.JPOLD)GO TO 1500         !SUM OVER CONT DEGENERACY
          JP=JPOLD
        ENDIF
!
        jpt=nrr(jp)
!
        DRY=DENERG(JP)+DENERG(JP)+DEM
!                                                            !UNRESOLVED
        IF(SUMPN(1,0).GT.DZERO)THEN
          IF(BPRNT0)THEN
            WRITE(MW18,10140)IZERO,IZERO,IZERO,NFK(JPt),JP,IWRK2(JP),   &
     &                       DZERO,DEM,DRY
            WRITE(MW18,10280)(SUMPN(M8,0),M8=1,MENG)
          ELSE
            WRITE(MW30)int(IZERO),int(IZERO),int(IZERO),int(NFK(JPt)),  &
     &                 int(JP),int(IWRK2(JP)),DZERO,DEM,DRY
            WRITE(MW30)(SUMPN(M8,0),M8=1,MENG)
          ENDIF
        ENDIF
        IF(SUMPD(1,0).GT.DZERO)THEN
          IF(BPRNT0)THEN
            WRITE(MW18,10140)IZERO,IZERO,IZERO,NFK(JPt),JP,IWRK2(JP),   &
     &                       DZERO,DZERO,DRY
            WRITE(MW18,10280)(SUMPD(M8,0),M8=1,MENG)
          ELSE
            WRITE(MW30)int(IZERO),int(IZERO),int(IZERO),int(NFK(JPt)),  &
     &                 int(JP),int(IWRK2(JP)),DZERO,DZERO,DRY
            WRITE(MW30)(SUMPD(M8,0),M8=1,MENG)
          ENDIF
        ENDIF
!                                                               !BUNDLED
        DO M=1,NMM
          IF(SUMPN(1,M).GT.DZERO)THEN
            IF(BPRNT0)THEN
              WRITE(MW18,10140)JCP(M),JTP(M),JWRN(M),NFK(JPt),JP,       &
     &                         IWRK2(JP),DZERO,ERN(M),DRY
              WRITE(MW18,10280)(SUMPN(M8,M),M8=1,MENG)
            ELSE
              WRITE(MW30)int(JCP(M)),int(JTP(M)),int(JWRN(M)),          &
     &                   int(NFK(JPt)),int(JP),int(IWRK2(JP)),DZERO,    &
     &                   ERN(M),DRY
              WRITE(MW30)(SUMPN(M8,M),M8=1,MENG)
            ENDIF
          ENDIF
          IF(SUMPD(1,M).GT.DZERO)THEN
            IF(BPRNT0)THEN
              WRITE(MW18,10140)JCP(M),JTP(M),JWRD(M),NFK(JPt),JP,       &
     &                         IWRK2(JP),DZERO,ERD(M),DRY
              WRITE(MW18,10280)(SUMPD(M8,M),M8=1,MENG)
            ELSE
              WRITE(MW30)int(JCP(M)),int(JTP(M)),int(JWRD(M)),          &
     &                   int(NFK(JPt)),int(JP),int(IWRK2(JP)),DZERO,    &
     &                   ERD(M),DRY
              WRITE(MW30)(SUMPD(M8,M),M8=1,MENG)
            ENDIF
          ENDIF
        ENDDO
!
!
 1500 ENDDO                                  !END LOOP OVER UPPER LEVELS
!
!
! determine usage of Born integrals
!
!      if(bborn)then
!      nh=ngroup/2
!      icount=0
!      icountb=0
!      do i=1,mb4(0)
!      if(bl(i,nh).ne.dzero)then
!      nc=indl(i)
!      j=mb4(nc)
!      k=mb3(nc)
!      if(mod(ngroup,2).eq.mod((ql(j)+ql(k))/2,2))then
!      icount=icount+1
!      if(iflagb(i).gt.0)icountb=icountb+1
!!      write(777,6999)i,indl(i),iflagb(i),icountb
!! 6999 format(i7,i5,i3,i6)
!      endif
!      endif
!      enddo
!      p=icountb
!      if(icount.gt.0)p=100*p/icount
!      npp=nint(p,sp)
!      write(mw0,*)'BORN INTEGRALS:CALC=',icount,'USED=',icountb,npp,'%'
!      write(mw6,777)icount,icountb,npp
!  777 FORMAT(/'BORN INTEGRALS: CALC=',I7,'  USED=',I7,I5,'%'/)
!      endif
!
! END MULTIPOLE LOOP OVER RADIATIVE TRANSITIONS
!
      IF(MLAM.LT.MPOLE)GO TO 1200
!
      DEALLOCATE(DG)
!
      if(btime)then
        call nrb_time(timef)
        times=timef-timei
!par        if(iam.ge.0)then                                        !par
!par          write(iwp,*)'proc',iam,' for diagfs:'                 !par
!par          write(iwp,*)'    radiative time=',nint(times),'sec'   !par
!par          call flush(iwp)                                       !par
!par        else                                                    !par
        write(iw,*)'radiative timer1=',nint(timer1),'sec'
        write(iw,*)'radiative timer2=',nint(timer2),'sec'
        write(iw,*)'radiative time=',nint(times),'sec'
!par        endif                                                   !par
      endif
!
! WRITE AN ADF04 (AND, MAYBE, INFINITE ENERGY OMEGA) FILE
!
      IF(MENGB.GE.-1)THEN                   !BBORN
!
        if(btime)timei=timef
!
! WRITE DATA TO OMGINF FILE
!
        WRITE(MW6,*)' '
        WRITE(MW6,*)'IBOMX=',IBOMX
!        write(mw0,*)ibifmx,ibomx
!
        CALL DIMUSE('MXBIF',IBOMX)
!
        do j=jupe,1,-1                               !nenerg
          if(jorig(j).gt.0)go to 1550
        enddo
        j=jupe                                       !shouldn't get here
 1550   jupe=j
!
        IF(ABS(MENGB).EQ.1)THEN            !INF ENG BORN, ROW *AND* COL
!
          IF(MENGB.EQ.-1)THEN
            DO I=1,NOMWRT
              OMR(I)=MIN(OMR(I),D1P30)
              OMC(I)=MIN(OMC(I),D1P30)
            ENDDO
          ENDIF
!
          K=0
          DO J=1,jupe                       !NENERG
            I=JORIG(J)
            IF(I.GT.0)THEN
              K=K+1
              II=NFQ(NRR(I))
              IWRK3(K)=(JN(I)+1)*(1-QPI(II))
              DWRK(K)=DENERG(I)*DTWO/DZ2
            ENDIF
          ENDDO
!
          IF(K.NE.NSPECE)THEN
            WRITE(MW6,*)'DIAGFS: ENERGY MISMATCH',K,NSPECE     !,jupe
            WRITE(MW0,*)'DIAGFS: ENERGY MISMATCH'
            GO TO 2100
          ENDIF
!
          if(nmetaj.eq.0)nmetaj=nspece                       !case no E1
          if(nmetaj.lt.nspece)then
            ixr=irow(nmetaj,nspece,ione1,nspece)
            if(ixr.lt.nomwrt)nomwrt=ixr
            ixc=icol(nmetaj,nspece,ione1)
          else
            ixc=nomwrt
          endif
          if(nmetj0.eq.0)nmetaj=-nmetaj
!
          F713='(1PE14.8,6E11.3/(14X,6E11.3))'    !SUPPRESS IFORT REMARK
!
          WRITE(MRW24,*)NZION,MION
          WRITE(MRW24,*)NSPECE,ABS(MENGB),NOMWRT
          WRITE(MRW24,*)('  0',IWRK3(I),I=1,NSPECE)
          WRITE(MRW24,10440)(DWRK(I),I=1,NSPECE)
          WRITE(MRW24,F713)EINF,(OMR(I),I=1,NOMWRT)
!
          IF(IDW.EQ.0)THEN                           !COLUMNWISE AS WELL
            NOMWRT=(NSPECE*(NSPECE+1-2*ione1))/2
            if(ixc.lt.nomwrt)nomwrt=ixc
!
            WRITE(MRW24,*)NZION,MION
            WRITE(MRW24,*)NSPECE,ABS(MENGB),-NOMWRT
            WRITE(MRW24,*)('  0',IWRK3(I),I=1,NSPECE)
            WRITE(MRW24,10440)(DWRK(I),I=1,NSPECE)
            WRITE(MRW24,F713)EINF,(OMC(I),I=1,NOMWRT)
          ENDIF
!
        ENDIF                                 !SUM BORN MULTIPOLES
!
! WRITE DATA TO ADF04 FILE
!
        BEXP=.FALSE.                          !TRUE=1.0E+0, FALSE=1.0+0
        IF(NSPECE.LT.1000)THEN
          i1=0
          IF(BEXP)THEN
            F761='(F5.2,4X,"1", 8X,20(1PE10.2))'
            F762='(2I4,22(1PE10.2))'
          ELSE
            F761='(F5.2,4X,"1", 6X, 20(A5, A3))'
            F762='(2I4, 22(A5, A3))'
          ENDIF
        ELSE
          i1=1
          IF(BEXP)THEN
            F761='(F5.2,4X,"1",10X,20(1PE10.2))'
            F762='(2I5,22(1PE10.2))'
          ELSE
            F761='(F5.2,4X,"1", 8X, 20(A5, A3))'
            F762='(2I5, 22(A5, A3))'
          ENDIF
        ENDIF
!
        if(ieq(0).ne.0)then
!
          WRITE(MRW26,F542)-1             !OLD TERMINATOR
!
        else
!                                      !now write orbital energy in s.o.
          cardx=' '
          cardx(4:5)='-1'
          orbfmt='(1x,f7.?)'
!
! truncate to spectroscopic orbitals
          if(bort)then
            isob=0
            inx=0
            do i=1,mxorb
              if(dey(i).ne.dzero)then
                if(dadjus(i).lt.dzero)go to 1560
                isob=i
                in=abs(qn(i))
                inx=max(inx,in)
              endif
            enddo
          else
            isob=mxorb
            inx=abs(qn(isob))
          endif
! re-map
 1560     isox=0
          inx=(inx*(inx+1))/2
!
 1580     allocate(isorb(0:inx))
!
          do i=1,inx
            isorb(i)=0
          enddo
          do i=1,isob
            in=abs(qn(i))
            il=ql(i)/2
            iso=(in*(in-1))/2+il+1
            if(iso.le.inx)isorb(iso)=i
            isox=max(isox,iso)
          enddo
!
          if(isox.gt.inx)then
            deallocate(isorb)
!         write(mw6,*)'***sr.diagfs: isorb buffer too short, need ',isox
            inx=isox
            go to 1580
          endif
!
          is=9+2*i1
          ie=is+abs(isox)*8
          IF(ie.GT.mxlenx)THEN
                            !note, >200(=7d) not passed by dwxbp,adasexj
!            write(mw6,*)'***sr.diagfs: cardx too short, need mxlenx=',i
            isox=-(mxlenx-is)/8
          endif
          if(isox.lt.0)then
!            write(mw6,*)'***adf04ic note: truncated orbital energy list
!!          write(mw0,*)'***adf04ic note: truncated orbital energy list'
            isox=-isox
          endif
! print
          do ix=1,isox
            ie=is+7
            i=isorb(ix)
            t=dzero
            if(i.gt.0)then              !break into two for bounds check
              if(dey(i).ne.dzero)then
                in=icol(i,i,izero)
                t=dey(i)-duy(in)
                if(bmvdr)t=t+dmass(in)+dcd(in)
                t=-2*t
              endif
            endif
            imt=max(itwo,ifive-max(izero,int(log10(max(t,d1m30)),sp)))
            write(orbfmt(8:8),'(i1)')imt
            write(cardx(is:ie),orbfmt)t
            is=ie+1
          enddo
!
          orbfmt=' '
          orbfmt(1:7)='(a    )'
          write(orbfmt(3:6),'(i4)')ie
          write(MRW26,orbfmt)cardx(1:ie)
!
          deallocate(isorb)
!
        endif
!
        IF(BEXP)THEN
          WRITE(MRW26,F761)REAL(NZA),(XB(K),K=1,MXNXB)
        ELSE
          MSCP=MSC+1
          OPEN(MSCP,STATUS='SCRATCH',FORM='FORMATTED')
          WRITE(MSCP,10650)(XB(K),K=1,MXNXB)
          BACKSPACE(MSCP)
          READ(MSCP,10660)(XMANT(K),IEXP(K),K=1,MXNXB)
          WRITE(MRW26,F761)REAL(NZA),(XMANT(K),IEXP(K),K=1,MXNXB)
        ENDIF
!
        DO M=MSC0,MSC                     !RE-POINT BORN MULTIPOLE FILES
          REWIND(M)
        ENDDO
!
        IOLD=JJMN               !1+ione1
        JOLD=IIMN               !1
!
        if(nenerg.eq.ione1)go to 1650
!
        if(jorig(iold).lt.0.or.jorig(jold).lt.0)then
          write(mw6,*)'Lowest two levels cannot be correlation!'
          write(mw0,*)'Lowest two levels cannot be correlation!'
          go to 2100
        endif
        INEW=IOLD                         !FIRST 2 LEVELS CANNOT BE CORR
        JNEW=JOLD
        KTRAN=0
!
 1600   IF(BSCRO)THEN
!
          BBORN=.FALSE.
          DO K=0,MXNXB1
            OMEGAB(K)=DZERO
          ENDDO
!
          IP=JORIG(IOLD)
          IP=NFQ(NRR(IP))
          IP=QPI(IP)
          JP=JORIG(JOLD)
          JP=NFQ(NRR(JP))
          JP=QPI(JP)
          IF(IP.NE.JP)THEN
            MMN=MSC0+1                      !ODD MULTIPOLES
            MMX=MSC+MOD(MSC,ITWO)-1
          ELSE
            MMN=MSC0
            MMX=MSC-MOD(MSC,ITWO)
          ENDIF
!
          IFLAGO=999
          DO M=MMN,MMX,2
            READ(M,END=1620,ERR=1620)I,J,(XS(K),K=0,MXNXB1)
            IF(I.GT.IOLD.OR.J.GT.JOLD)THEN
              BACKSPACE(M)
              GO TO 1620
            ELSE
              if(jold.gt.iimx)then
                if(nmetj0.eq.0)then
                  go to 1620         !unfortunate interchange of i,j use
                else
                  stop '370'
                endif
              endif
              BBORN=.TRUE.
              KMX=MXNXB1
              IF(IP.NE.JP)THEN
                LAM=MOD(M,I80)
                IF(LAM.EQ.1.AND.ABS(XS(MXNXB1)).GT.TOLO)IFLAGO=1 !E1 LIM
                IF(LAM.GT.IFLAGO)KMX=MXNXB     !DON'T OVERWRITE E1 LIMIT
              ENDIF
              DO K=0,KMX
                OMEGAB(K)=OMEGAB(K)+XS(K)
              ENDDO
            ENDIF
 1620     ENDDO
!
        ELSE
          KTRAN=KTRAN+1
          DO K=0,MXNXB1
            OMEGAB(K)=REAL(OMEGA(K,KTRAN),WP)
          ENDDO
        ENDIF
!
        IF(BBORN)THEN
          DO K=0,MXNXB
            OMEGAB(K)=ABS(OMEGAB(K))
            IF(OMEGAB(K).LT.D1M99)OMEGAB(K)=DZERO
          ENDDO
          IF(OMEGAB(0).LT.D1M30)OMEGAB(0)=D1M30
          IF(OMEGAB(MXNXB1).GT.D1P30)OMEGAB(MXNXB1)=D1P30
          IF(BEXP)THEN
            WRITE(MRW26,F762)INEW,JNEW,(OMEGAB(K),K=0,MXNXB1)
          ELSE
            BACKSPACE(MSCP)
            WRITE(MSCP,10650)(OMEGAB(K),K=0,MXNXB1)
            BACKSPACE(MSCP)
            READ(MSCP,10660)(XMANT(K),IEXP(K),K=0,MXNXB1)
            WRITE(MRW26,F762)INEW,JNEW,(XMANT(K),IEXP(K),K=0,MXNXB1)
          ENDIF
        ENDIF
!
 1650   JOLD=JOLD+1
        IF(JOLD.GT.IOLD-ione1.or.JOLD.GT.IIMX.and.nmetj0.ne.0)THEN
 1660     IOLD=IOLD+1
          IF(IOLD.GT.jupe)THEN           !NENERG              !TERMINATE
            WRITE(MRW26,F762)-1
            WRITE(MRW26,F762)-1,-1
            if(.not.badas)then                      !adas skip comments
              WRITE(MRW26,10610)
              NREC=1
 1665         NREC=NREC+1
              BACKSPACE(MR5)
              BACKSPACE(MR5)
              READ(MR5,10670)CARD4
              IF(CARD4.NE.'A.S.'.AND.CARD4.NE.'S.S.')GO TO 1665
              REWIND(MR5)
              DO N=1,NREC
                READ(MR5,10630)CARD
                WRITE(MRW26,10620)CARD
              ENDDO
              DATE='        '
              CALL DATE_AND_TIME(DATE)
              WRITE(MRW26,10640)DATE(7:7),DATE(8:8),DATE(5:5),DATE(6:6),&
     &                          DATE(3:3),DATE(4:4)
            endif
            DO M=MSC0,MSC
              CLOSE(M)
            ENDDO
            IF(.NOT.BEXP)CLOSE(MSCP)
          ELSE
            IF(JORIG(IOLD).LT.0)GO TO 1660
            JOLD=IIMN          !1
            JNEW=IIMN          !1
            INEW=INEW+1
            GO TO 1600
          ENDIF
        ELSE
          IF(JORIG(JOLD).LT.0)GO TO 1650
          JNEW=JNEW+1
          GO TO 1600
        ENDIF
!
        if(btime)then
          call nrb_time(timef)
          timew=timef-timei
!par          if(iam.ge.0)then                                      !par
!par            write(iwp,*)'proc',iam,' for diagfs:'               !par
!par            write(iwp,*)'    radiative time=',nint(times),'sec' !par
!par            call flush(iwp)                                     !par
!par          else                                                  !par
          write(iw,*)'adf04/omginf time=',nint(timew),'sec'
!par          endif                                                 !par
        endif
!
      ENDIF                               !END ADF04/OMGINF WRITES
!
! CHECK TO SEE IF SIZE OF ARRAYS MADD AND AP HAS BEEN EXCEEDED
! (TBD: COULD STORE NTRAN IN MADD(0) THEN USE AP(IXNOR), MADD(IXNOR) AS
!       "NORMAL".)
!
      IF(NTRAN.GT.0.AND.MOD(ABS(MPNCH),IFOUR)/2.EQ.1)THEN
        IF(NTRAN.LE.IXNOR)THEN
          MADD(0)=NTRAN
        ELSE                              !SHOULD NOT HAPPEN NOW
          WRITE(MW6,10120)NTRAN
          WRITE(MW0,*)'***SR.DIAGFS: CASCADE DIMENSION MXNOR EXCEEDED'
          GO TO 2100
        ENDIF
        IM=NTRAN+1
        CALL DIMUSE('MXNOR',IM)
      ENDIF
!
! DE-ALLOCATE
!
 1700 CONTINUE
!
      IF(BOMRC)THEN
        DEALLOCATE(OMR,OMC,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGFS: DE-ALLOCATION FAILS FOR OMR,OMC'
          NF=MIN(NF,IZERO)
        ENDIF
        BOMRC=.FALSE.
      ENDIF
!
      IF(ALLOCATED(IDY))THEN
        DEALLOCATE(IDY,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGFS: DE-ALLOCATION FAILS FOR IDY'
          NF=MIN(NF,IZERO)
        ENDIF
      ENDIF
!
      IF(ALLOCATED(OMEGA))THEN
        DEALLOCATE(OMEGA,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGFS: DE-ALLOCATION FAILS FOR OMEGA'
          NF=MIN(NF,IZERO)
        ENDIF
      ENDIF
!
      IF(.NOT.BFOTJ.AND.ALLOCATED(DVECF))THEN
        DEALLOCATE(DVECF,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGFS: DE-ALLOCATION FAILS FOR DVECF'
          NF=MIN(NF,IZERO)
        ENDIF
      ENDIF
!
      IF(.NOT.BFOTJ.AND.ALLOCATED(DVECM))THEN
        DEALLOCATE(DVECM,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGFS: DE-ALLOCATION FAILS FOR DVECM'
          NF=MIN(NF,IZERO)
        ENDIF
      ENDIF
!
      IF(BPOS)THEN
        DEALLOCATE(NPOS,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGFS: DE-ALLOCATION FAILS FOR NPOS'
          NF=MIN(NF,IZERO)
        ENDIF
        BPOS=.FALSE.
      ENDIF
!
      IF(NF.LE.0)GO TO 1900                                      !RETURN
!
! UPDATE FUNCTIONAL (RE-ENTRY POINT IF NO RADIATION)
!
 1800 DRY=DFFS
      IF(IOPTIM.EQ.0)DRY=DRY+DECORE
      DRY=DRY*DTWO
      IF(BPRNT0)THEN
        WRITE(MW6,10960)INCLUD,DRY,JPRINT
        IF(DRY.NE.DZERO.AND.IWGHT.LT.0)WRITE(MW6,10970)
      ENDIF
!
! FINISH-UP
!
 1900 NL=NL0                                                    !RESTORE
!
      IF(ALLOCATED(TFUJ))THEN
        DEALLOCATE(TFUJ,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGFS: DE-ALLOCATION FAILS FOR TFUJ'
          NF=MIN(NF,IZERO)
        ENDIF
      ENDIF
!
      IF(.NOT.BCASC.AND.ALLOCATED(JORIG))THEN      !MAY HOLD FOR SR.CASC
        DEALLOCATE(JORIG,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGFS: DE-ALLOCATION FAILS FOR JORIG'
          NF=MIN(NF,IZERO)
        ENDIF
      ENDIF
!
! LOCAL DEALLOCATE
!
      IF(ALLOCATED(IHARRY))THEN
        DEALLOCATE(IHARRY,E1BCF,SUMA)
      ENDIF
      IF(ALLOCATED(DENERG))THEN
        DEALLOCATE(DENERG,IWRK2,ID,NADRUJ,NAJ,DVECL,DVECV,DVECA)
      ENDIF
      IF(ALLOCATED(ETM))THEN
        DEALLOCATE(ETM,WGT)
      ENDIF
      IF(ALLOCATED(DWRK))THEN
        DEALLOCATE(DWRK,IWRK3,IWRK4)
      ENDIF
      IF(ALLOCATED(JCP))THEN
        DEALLOCATE(JCP,JTP,JWRN,JWRD,ERN,ERD)
      ENDIF
      IF(ALLOCATED(JRP))DEALLOCATE(JRP)
      IF(ALLOCATED(SUMRN))THEN
        DEALLOCATE(SUMRN,SUMRD)
      ENDIF
      IF(ALLOCATED(SUMPN))THEN
        DEALLOCATE(SUMPN,SUMPD)
      ENDIF
      if(allocated(iwrkj))then
        deallocate(iwrkj)
      endif
      if(allocated(jwrkb))then
        deallocate(jwrkb)
      endif
      if(allocated(jwrkg0))then
        deallocate(jwrkg0,NGRPJ)
      endif
      if(allocated(jwrkg))then
        deallocate(jwrkg)
      endif
      IF(ALLOCATED(ITMP))DEALLOCATE(ITMP)
!
! WRITE TERMINATORS
!
      IF(.NOT.BMODE)THEN
        IF(BPRNT0)WRITE(MW8,10250)MBLK
        IF(.NOT.BPRNT0)WRITE(MW28)int(IZERO),int(IZERO),int(IZERO),     &
     &                            int(IZERO),int(IZERO),int(IZERO),     &
     &                            DZERO,DZERO,DZERO
      ENDIF
      IF(.NOT.BFOTJ)THEN
        IF(BPRNT0)WRITE(MW18,10250)MBLK
        IF(.NOT.BPRNT0)WRITE(MW30)int(IZERO),int(IZERO),int(IZERO),     &
     &                            int(IZERO),int(IZERO),int(IZERO),     &
     &                            DZERO,DZERO,DZERO
      ENDIF
!
! CLOSE SOME FILES
!
      IF(IUNIT(MW22).GT.1)THEN
        CLOSE(MW22)
        IUNIT(MW22)=-1
      ENDIF
      IF(IUNIT(MRW24).GT.1)THEN               !so par scratch not closed
        CLOSE(MRW24)
        IUNIT(MRW24)=-1
      ENDIF
      IF(IUNIT(MRW26).GT.1)THEN
        CLOSE(MRW26)
        IUNIT(MRW26)=-1
      ENDIF
!
      IF(BKUTDSK)THEN
        DO KGROUP=1,NJO
          CALL DISKTF(KGROUP,IVEC,ILEN,TFUJ,IZERO)
        ENDDO
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
 2000 IF(NF.GT.0)NF=-1
      GO TO 1100                                            !DE-ALLOCATE
!
 2100 IF(NF.GT.0)NF=-1
      GO TO 1700                                            !DE-ALLOCATE
!
! DIMENSION EXCEEDED, ABORT.
!
 2200 WRITE(MW6,10010)NCTOT,ABS(IAXJU)
      WRITE(MW0,*)'SR.DIAGFS: MAXJU DIMENSION EXCEEDED'
      GO TO 2000
!
!-----------------------------------------------------------------------
!
10010 FORMAT(/' SR.DIAGFS WILL NOT COMPUTE RADIATIVE TRANSITION',       &
     &       ' PROBABILITIES BECAUSE IT REQUIRES',I9,'.GT.MAXJU=',I9,   &
     &       ' FOR ARRAY TFUJ')
10020 FORMAT(//' *****WARNING*****--- IF SR. DIAGFS HAS PUNCHED TERM',  &
     &       ' COUPLING COEFFICIENTS, THE SET WILL BE INCOMPLETE'/      &
     &       ' BECAUSE',                                                &
     &      ' NOT ENOUGH STORAGE WAS ALLOWED FOR STORING TRANSFORMATION'&
     &      ,' COEFFICIENTS IN DIAGON :  INCREASE MAXUC')
10030 FORMAT(//5X,'ZETA(   A    B ) = SPIN-ORBIT PARAMETERS')
10040 FORMAT(I5,4X,2I5,8X,E14.7)
10050 FORMAT(I5,I4,4I3,F14.5,F14.6,I3,I4,10F8.4)
10060 FORMAT((56X,10F8.4))
10070 FORMAT('2J P',2X,' S L',3X,'CF',3X,'NI',7X,'ENERGY(RYD)')
10080 FORMAT(/8X,'W P',3X,'CF',7X,'ENERGY(RYD)')
10090 FORMAT(/' ONE-BODY RELATIVISTIC INTEGRALS'/' I(R)  I(  A,  C )',  &
     &       ' = ',6X,'MASS',9X,'DARWIN',24X,'<P**2>')
10100 FORMAT(I5,3X,2I4,3X,2F14.7,16X,F14.7)
10110 FORMAT(22X,'2MXLBD=',I3)
10120 FORMAT(/5X,10('*'),' IF YOU REQUIRE CASCADE COEFFICIENTS AUGMENT',&
     &       ' MXNOR TO A VALUE GREATER THAN',I8)
10130 FORMAT(//'   LV   T 2J 2S+1L  P',6X,'H(1)/2RY EIGEN-HBP/2RY CF  ',&
     &       'NO',2X,'CI-MATRIX <GJ!CASLJ>  AND  H(2)/2RY-TRIANGLE.',   &
     &       '  E(CORE)/2RY=',F10.4,F11.4)
10140 FORMAT(6I5,1PE15.5,2(0PF15.6))
10150 FORMAT(11X,I4,2I5,1PE15.3,2(0PF15.4))
10160 FORMAT(60X,F15.6)
10170 FORMAT(4X,'NA',8X,'W',3X,'LV',2X,'LVP',8X,'AA*SEC',6X,            &
     &       'ECONT(A.U)',7X,'E-I(A.U)')
10180 FORMAT(8X,'I-S',12X,'C-S',11X,'AUTO-IONIZATION DATA',7X,'Z=',I2,  &
     &       3X,'N=',I2/3X,'CF',3X,'LV',4X,'W',3X,'CF',3X,'LV',4X,'W',  &
     &       6X,'AA*SEC',9X,'E-C(RYD)',6X,'E-I(RYD)')
10190 FORMAT(5I5,4X,'X',1PE15.5,2(0PF15.6))
10200 FORMAT(I3,'CFIC',2X,'G',3X,'Z=',I2,4X,'N=',I2,2X,'NL',62(I3,I2))
10210 FORMAT(8X,'I-S',12X,'G-S',15X,'RADIATIVE DATA',9X,'Z=',I2,3X,'N=',&
     &       I2/3X,'CF',3X,'LV',4X,'W',3X,'CF',3X,'LV',4X,'W',6X,       &
     &       'AR*SEC',9X,'DEL(RYD)',6X,'E-G(RYD)')
10220 FORMAT('+',67X,'(AA DATA INCLUDES TERM/LEVEL ENERGY CORRECTION)')
10230 FORMAT(3X,'NLEVEL=',I5,39X,'E1/RY=',F15.6/4X,'K',3X,'LV',4X,'T',  &
     &       ' 2S+1',4X,'L',3X,'2J',3X,'CF',5X,'(EK-E1)/RY')
10240 FORMAT(7I5,F15.6,I10)
10250 FORMAT(A2)
10260 FORMAT(8X,'I-S',12X,'C-S',7X,'PHOTO-RECOMBINATION DATA',7X,'Z=',  &
     &       I2,3X,'N=',I2/3X,'CF',3X,'LV',4X,'W',3X,'CF',3X,'LV',3X,   &
     &       'EO',6X,' P/CM2',9X,'E-I(RYD)',6X,'E-C(RYD)')
10270 FORMAT(I3,' E(RYD) ',2X,'Z=',I2,4X,'N=',I2,5X,'Intermediate-',    &
     &       'Coupling',1X,'EIONMIN=',F15.6)
10280 FORMAT(5(1PE15.5))
10290 FORMAT(8X,'I-S',12X,'C-S',10X,'PHOTO-IONIZATION DATA',7X,'Z=',I2, &
     &       3X,'N=',I2/3X,'CF',3X,'LV',4X,'W',3X,'CF',3X,'LV',3X,'EO', &
     &       6X,' P/CM2',9X,'E-I(RYD)',6X,'E-C(RYD)')
10300 FORMAT(2I5,4X,I1,I2,1X,10(I2,A1))
10310 FORMAT(' &ADASEX NLEVS= XXX',' &END')                    !,I4
10320 FORMAT('NAME:'/'DATE:'/'.')
10330 FORMAT(A2,'+',I2,2I10,F15.4,A4)
10340 FORMAT(7X,'E',I1,'-DATA',3X,'K  KP',11X,'A(EK)*SEC',11X,'S',15X,  &
     &       'G*F',10X,'F(ABS)   -F(EMI)',4X,'WAVEL/AE',6X,'GF(VEL)',6X,&
     &       'ALPHA(POL)')
10350 FORMAT(6X,'E',I2,'-DATA',3X,'K  KP',11X,'A(EK)*SEC',11X,'S',15X,  &
     &       'G*F',10X,'F(ABS)   -F(EMI)',4X,'WAVEL/AE',6X,'GF(VEL)',6X,&
     &       'ALPHA(POL)')
10360 FORMAT(34X,'VELOCITY',7X,'VELOCITY',74X,'VELOCITY')
10370 FORMAT(' RESTARTED FROM K=',I5,3X,'LV=',I5)
10380 FORMAT(4X,'E',I1,'/M',I1,'-DATA',3X,'K  KP',11X,'A(EK)*SEC',6X,   &
     &       'A(MK)*SEC',A4,7X,'SE',11X,'SM',11X,'SM0',12X,'G*F',6X,    &
     &       'WAVEL/AE',4X,A9)
10390 FORMAT(2X,'E',I2,'/M',I2,'-DATA',3X,'K  KP',11X,'A(EK)*SEC',6X,   &
     &       'A(MK)*SEC',A4,7X,'SE',11X,'SM',11X,'SM0',12X,'G*F',6X,    &
     &       'WAVEL/AE',4X,A9)
10400 FORMAT(7X,'E',I1,'-DATA',3X,'K  KP',11X,'A(EK)*SEC',11X,'S',15X,  &
     &       'G*F',3X,'10**',I1,'* ','F(ABS)   -F(EMI)',4X,'WAVEL/AE',  &
     &       6X,'GF(VEL)',7X,'OMG(BORN)')
10410 FORMAT(6X,'E',I2,'-DATA',3X,'K  KP',11X,'A(EK)*SEC',11X,'S',15X,  &
     &       'G*F',3X,'10**',I1,'* ','F(ABS)   -F(EMI)',4X,'WAVEL/AE',  &
     &       6X,'GF(VEL)',7X,'OMG(BORN)')
10420 FORMAT(I9,A4,I5,I4,5X,1PE15.3,5X,0PF10.6,3X,1PE15.3,3X,2(0PF10.5),&
     &       2X,F11.4,3X,1PE10.2,3X,E12.3)
10430 FORMAT(I9,A4,I5,I4,5X,2(1PE15.3),4X,3E13.3,E15.3,0PF11.2,1PE13.3)
10440 FORMAT(1P,5E16.6)
!10450 FORMAT(1PE14.8,6E11.3/(14X,6E11.3))
10450 FORMAT(/' *****WARNING*****  IF SR.DIAGFS HAS PUNCHED TERM ',     &
     &       'COUPLING COEFFICIENTS THE SET WILL BE INCOMPLETE,'/20X,   &
     &       'BECAUSE MAXTR.GE.',I9,'  IS REQUIRED')
10460 FORMAT(' NO TERM-COUPLING COEFFICIENTS CALCULATED BECAUSE OF ',   &
     &       'INCORRECT CHOICE OF MOD : CHOOSE MOD =0 OR -1')
10470 FORMAT(41X,2I5,4(I5,F12.8))
10480 FORMAT((51X,4(I5,F12.8)))
10490 FORMAT(43X,'....',9X,I3,I5,12X,'HEADING CARD FOR TERM COUPLING ', &
     &       'COEFFICIENTS'/(43X,'...',5(2I3,F9.6)))
10500 FORMAT(5X,2I5,5X,"TCC'S BASED ON FANO-AS","  Z =",I3,",  N =",I3)
10510 FORMAT(5X,2I5,5X,"TCC'S BASED ON C&S -AS","  Z =",I3,",  N =",I3)
10520 FORMAT(40X,'HEADING CARD FOR TERM COUPLING COEFFICIENTS')
10530 FORMAT(2I5,4(I5,F18.14))
10540 FORMAT((10X,4(I5,F18.14)))
10550 FORMAT(/'  RECOUPLING MATRIX: ROWS ARE J LEVELS, COLUMNS ARE',    &
     &       ' LS TERMS'//' LEVEL   #         LS TERM #S/COEFFICIENTS')
10560 FORMAT(5(I3,I2,F9.6))
10570 FORMAT(1P,(4(2I4,E12.4E1)))
10580 FORMAT(/'*** TCC WARNING: HIGHEST SPECTROSCOPIC TERM BELOW',      &
     &       ' ALL CORRELATION IS AT ',I5,' BUT THERE ARE',I5,          &
     &       ' OTHERS HIGHER')
10590 FORMAT(3I7,F16.7,I15,I7)
10600 FORMAT(/I5,' J LEVELS',I5//'  LEVEL     2J     PI     ENERGY(RYD)'&
     &       ,'  ORIG. LEVEL # TERM #')
10610 FORMAT('C',79('-')/'C'/'C')
10620 FORMAT('C ',A200)
10630 FORMAT(A200)
10640 FORMAT('C'/'C'/'C',79('-')/'C'/'C',1X,                            &
     &       'AUTOSTRUCTURE PLANE-WAVE BORN'/'C'/'C NAME:'/'C DATE: ',  &
     &       2(A1),'/',2(A1),'/',2(A1)/'C'/'C',79('-'))
10650 FORMAT(22(1PE9.2))
10660 FORMAT(22(A5,1X,A3))
10670 FORMAT(A4)
10680 FORMAT(34X,'VELOCITY',24X,'VELOCITY',33X,'VELOCITY')
10690 FORMAT(34X,'VELOCITY',7X,'VELOCITY')
10700 FORMAT(/' GAM  ONE-BODY MASS-VELOCITY INTEGRALS')
10710 FORMAT(/' GAM  ONE-BODY DARWIN INTEGRALS')
10720 FORMAT(/' GAM  ONE-BODY <P**2> INTEGRALS')
10730 FORMAT(1X,I3,9F14.7/(4X,9F14.7))
10740 FORMAT('*****STORAGE EXCEEDED IN SR.DIAGFS, INCREASE MXAAK TO',I9)
10750 FORMAT(I6)
10760 FORMAT(' ',I9,' USED, MXAAK=',I9)
10770 FORMAT(7X,3I5,F14.6,3X,2F12.6,F13.7,20X,F12.6)
10780 FORMAT(//9X,'ONE-BODY RELATIVISTIC CORRECTIONS TO INDIVIDUAL ',   &
     &       'ORBITALS IN UNITS OF 2*RY',35X,'IC.JPRINT =',I4/9X,       &
     &       'GAM    N    L    E(NON.REL)',8X,'E(MASS)',6X,'E(DAR)',7X, &
     &       'E(TOT)',23X,'<P**2/RY>')
10790 FORMAT(' PLUS CORE CONTRIBUTION',F13.4,2X,F12.5,9X,'RELATIVISTIC',&
     &       ' CORE CONTRIBUTION ALONE',F13.4)
10800 FORMAT(' ******WARNING LS SELECTION RULES APPLIED TO RADIATIVE',  &
     &       ' TRANSITIONS IN SR.DIAGFS'/)
10810 FORMAT(//'*** ATTN: BECAUSE BORN MULTIPOLES ARE BEING COMPUTED',  &
     &     ' FOR NON-E1 TRANSITIONS, RADIATIVE DATA IS NOT COMPUTED FOR'&
     &     ,' THOSE E3/M2 ETC TRANSITIONS'/10X,                         &
     &     'FOR WHICH E1 DATA ALREADY',                                 &
     &     ' EXISTS (SO AS NOT TO OVERWRITE THE E1-LIMIT)'/)
10820 FORMAT(I11,2I10,F13.0,I7,3I5,A4,I2,F13.8,27X,F15.8,2X,F15.8)
10830 FORMAT(/' LIST OF TERMS WITH A WEIGHTED MEAN OVER THE FINE ',     &
     &       'STRUCTURE'/9X,'I',8X,' T',8X,'K*CM',2X,'2S+1 L   CF',5X,  &
     &       'WEIGHTS',8X,'(EI-E1)/RY     E1/RY =',F13.6,3X,A10,I5,1X,  &
     &       A8)
10840 FORMAT(2I2,1X,I3,I2,2I5,F18.8,3X,A4)
10850 FORMAT(I9,I2,I5,F18.6)
10860 FORMAT(/' *** WORKING ARRAYS TOO SMALL IN SR.DIAGFS, INCREASE',   &
     &       ' MXAAK TO:',                                              &
     &       I9/' *** OR REDUCE NUMBER OF SPECTROSCOPIC TERMS')
10870 FORMAT(96X,I5,F10.0,F11.6)
10880 FORMAT(2I10,F13.0,I5,I2,I5,A4,F8.3,F18.6,24X,2F14.6)
10890 FORMAT(I6,' CALC ',F10.1,'     OBS ',F10.1,'   SQ-DIF.SUM',E16.5)
10900 FORMAT(//9X,' K',8X,'LV',8X,' T',8X,'K*CM',5X,                    &
     &       '2*S+1  L   2J   CF',4X,A2,3X,'(EK-E1)/RY     E1/RY =',    &
     &       F15.8,5X,A10,I5,4X,A8)
10910 FORMAT(/' LIST OF CONFIGS WITH A WEIGHTED MEAN OVER THE LEVEL ',  &
     &       'STRUCTURE'/9X,'I',8X,' C',8X,'K*CM',7X,'W   CF',20X,      &
     &       '(EI-E1)/RY     E1/RY =',F14.6)
10920 FORMAT(I11,2I10,F13.0,I7,3I5,A4,F15.8,27X,F15.8,2X,F15.8)
10930 FORMAT(2I10,F13.0,I7,I5,A4,8X,F18.6)
10940 FORMAT(I11,2I10,F13.0,I7,3I5,A4,F15.8,I10)
10950 FORMAT(' ',98X,'LEVEL ENERGY CORRECTION')
10960 FORMAT(//9X,'INCLUD =',I5,9X,'FUNCTIONAL F =',1PE14.7,9X,         &
     &       'IC.JPRINT=',I2//)
10970 FORMAT(9X,'THE ENERGY FUNCTIONAL IS THE ARITHMETIC MEAN OF THE ', &
     &       'CONFIGURATION WEIGHTED-MEAN ENERGIES'//)
10980 FORMAT(80A1)
10990 FORMAT('SR.DIAGFS: ALLOCATION INCREASES NO. OF BORN INTERACTIONS',&
     &       'IXBIF=',I10,' .GT. MXBIF=',I10)
11000 FORMAT('*** SR.DIAGFS: COULD ACCESS MEMORY FASTER IF MXD30=',I7)
11010 FORMAT(/25X,' Q.E.D. CONTRIBUTIONS /2RY'/8X,'  GAM    N    L',3X, &
     &       'VACUUM POLARIZ.',6X,'SELF ENERGY',9X,'TOTAL')
11020 FORMAT(8X,3I5,3(2X,F15.7),2F10.5)
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!-----------------------------------------------------------------------
      FUNCTION IROW(ILI,ILF,IONE1,NENG)
!
      INTEGER(SP) ILI,ILF,IONE1,NENG,IROW
!
      IROW=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE1))/2
!
      END FUNCTION IROW
!-----------------------------------------------------------------------
!
      END SUBROUTINE DIAGFS
!
!                             *******************
!
      SUBROUTINE DIAGON(DECORE,DF)
!
!-----------------------------------------------------------------------
!
!            N.R. BADNELL  D.A.M.T.P.  CAMBRIDGE
!
!  SR.DIAGON CALCULATES TERM ENERGIES AND DATA FOR ELECTRIC RADIATIVE
!  TRANSITIONS.
!  IT ALSO CALCULATES LS COUPLING AUTOIONIZATION RATES AND PHOTO-
!  IONIZATION CROSS SECTIONS - SEE ALSO NOTES IN SR.RADCON.
!
!  IT IS CALLED BY:
!    SR.CALCFX
!    SR.MINIM
!
!  IT CALLS:
!    SR.BRNINT
!    FN.CELMNT
!    SR.DATE_AND_TIME (SYSTEM)
!    SR.DIMUSE
!    SR.DISKTF
!    SR.HDIAG
!    SR.HPSRTI
!    SR.LAGINT
!    SR.NRB_TIME
!    SR.RKINT
!    SR.SLATR
!    SR.WEDDLE
!
!  IT CONTAINS:
!    FN.ICOL
!    FN.IROW
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam                            !par
!
      USE COMMON_ALGEB,  ONLY: BFANO
      USE COMMON_ALGEB,  ONLY: BFOT
      USE COMMON_ALGEB,  ONLY: KUTDSK
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CACC,   ONLY: ACC
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_CMESH,  ONLY: MHF,MRAD,MSTEP,IXTRA,xmax
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL,NAD,n8
      USE COMMON_DXRL,   ONLY: IRK,IRK0,IOS,IOS0
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCL0=>INCLUD,JPRINT,JEND
      USE COMMON_INTS,   ONLY: DRL,DOSC,IGAUGE,IXD09,IXD28,IXD29
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR
      USE COMMON_MINIM,  ONLY: MPNCH,KUTCAS,BPRINT
      USE COMMON_MINIM,  ONLY: ECOR1,ECOR2,ECORR,ECORRJ,ESKPL,ESKPH     &
     &                        ,BECOR
      USE COMMON_MINIM,  ONLY: CMXLSA,CMXLSR,CMXICA,CMXICR,STOLB,XMIX   &
     &                        ,bnobv
      USE COMMON_MINIM,  ONLY: TOLTCC,KTCC,MTCC,NTCC,NENERG
      USE COMMON_MINIM,  ONLY: EIONPOT,EIMXLS,EIMXIC                    &
     &                        ,WLG1,WLG2,IWGHT,IWGHT0,IOPTIM            &
     &                        ,JUPMX,JUPMN,JLOWMX,JLOWMN                &
     &                        ,LUPMX,LUPMN,LLOWMX,LLOWMN                &
     &                        ,NMETAR,NMETARJ,NMETAP,NMETAPJ,NRSLMX
      USE COMMON_MISC,   ONLY: BEIVEC,IDIAG
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
      USE COMMON_QTG,    ONLY: MTGD,NXLL,NTT,NTG,JTGD,QTGS,QTGL,QTGD    &
     &                        ,NFI,NFK,NFQ
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
      USE COMMON_REL,    ONLY: DMASS,DCD,D2LL
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
      USE COMMON_TFU,    ONLY: TFU
      USE COMMON_TRANLS, ONLY: NADRU,NAI,IEORD
      USE COMMON_WEIGHT, ONLY: WGHT,INDEXW
!
      use common_misc,   only: ione1,ione0
      use common_misc,   only: iw,iwp,btime,btimex
      use common_misc,   only: badas
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL2, ONLY: MDEL,MXORBR,MPOL00,MPOL0,MPOLE,MPOLX,CODE
      USE COMMON_NRBAL2, ONLY: MAXLAM0,MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBCAV, ONLY: ECAVX,ECAV,AJUSTX,ICAV
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBDR,  ONLY: IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR
      USE COMMON_NRBDEL, ONLY: ISHFTLS,ISHFTIC,NOBS,NOBSJ,MDELE,MULTS   &
     &                        ,DELELS,DELEIC,DELECF,EFLG0,EFLGJ0        &
     &                        ,TOLB,TOLE
      USE COMMON_NRBDW,  ONLY: IDW,btop
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBEKP, ONLY: NED
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBIAD, ONLY: IADD
      USE COMMON_NRBINT, ONLY: DRLI,DYY,IYY,NRLI,MENG,NREL,NLAG,NLAGP   &
     &                        ,BLAG,BBC2
      USE COMMON_NRBLIM, ONLY: ECNTRB,ITANAL,BANAL
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,NAST                          &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBNF2, ONLY: DETA,DXSI,DZL,DXTWO
      USE COMMON_NRBNFI, ONLY: DZLI,DXTWOI,DETAI,FRI,GRI
      USE COMMON_NRBOLP, ONLY: OVLPGR,OVLPCF,IPAIR
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX                     &
     &                        ,MXBORB,MXVORB,MXFORB,NGRP
      USE COMMON_NRBORN, ONLY: BL,OBO,TM2
      USE COMMON_NRBPOT, ONLY: ALFD,RCUT,ALAV,RCAV,IPOLFN
      USE COMMON_NRBQED, ONLY: VPINT,SLFINT,QED
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBRN1, ONLY: SBL,DBL                                  &
     &                        ,MB3,MB4,INDX,INDL,INDK,IXD33
      USE COMMON_NRBRN2, ONLY: BINDB,MENGB
      USE COMMON_NRBRN3, ONLY: V0,V1,XB,XS,DB0,DB1,OMEGAB               &
     &                        ,MV0,MV1,MINFB,MXNXB,MXNXB1,NLAGB         &
     &                        ,IEXP,XMANT
      USE COMMON_NRBSHF, ONLY: DSHIFT,MSHIFT,KSHIFT,MKMAX,MXEP
      USE COMMON_NRBTAR, ONLY: IGAPE
      USE COMMON_NRBTS1, ONLY: DFOT,DFOSS,PMIN,NFOSS,IPIG,IGAG
      USE COMMON_NRBVAL, ONLY: FACT,IVAL,NNEW,NNOLD,BJUMP,BJUMP2,BRAD   &
     &                        ,BAUGER
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (MXLIT=62)
      PARAMETER (MXSTRG=32)           !MAX STRING WRITE, MOD(MXSTRG,4)=0
      PARAMETER (MSTRGH=16)         !SHORT STRING WRITE, MOD(MSTRGH,4)=0
      PARAMETER (MXLAB1=29)                                    !0:MXLAB1
      PARAMETER (MXLAB2=29)                                    !0:MXLAB2
      PARAMETER (MXLEN=200)                                 !CARD LENGTH
      parameter (mxlenx=200)                                !card length
!
      PARAMETER (DKON=1.653656E+17_WP)   !DEIGHT/HBAR
      PARAMETER (C1=DFSC**3/HBAR)
      PARAMETER (C2=2.567895E-18_WP)     !DFOUR*XPI*A0_BOHR**2*DFSC
!      PARAMETER (C3=C2/DTHREE)
!
      PARAMETER (EINF=D1P6)
!
      INTEGER QLB,LIT     !HISTORIC DEFAULT KIND TO SYNC WITH POST PROCS
!
      REAL(RP) OMEGA
!
      CHARACTER(LEN=1) BIGL,NUMB,STRING,CLIT,CMBLK1,CEV,CUL
!HAR  X,LIT,MBLK1  !USE OF CHAR REQUIRES CHANGES TO PP'S FOR UNFORM I/O
      CHARACTER(LEN=2) CELMNT,ELEM
      CHARACTER(LEN=4) MBCOR,MCOR,MSCOR,MBLK,MYRGE,LAB4,CARD4,MOUT
      CHARACTER(LEN=8) DATE
      character(len=9) orbfmt
      CHARACTER(LEN=24) MOBS
      character(len=32) ceiss,cstan
      CHARACTER(LEN=17) F762
      CHARACTER(LEN=29) F713,F761
      character(len=51) f542,f543
      character(len=mxlenx) cardx
      CHARACTER(LEN=MXLEN) CARD
!
!      ALLOCATABLE :: DU(:,:)
!
      ALLOCATABLE :: NPOS(:,:),DUI(:,:),DVI(:,:),DDY(:)                 &
     &              ,DVP(:),OMR(:),OMC(:),OMEGA(:,:)                    &
     &              ,DE(:),IDY(:),DVU(:),NVEC(:)                        &
     &              ,DVECF(:,:)                                         &
     &              ,ITMP(:)                                            &
     &              ,nadlu(:)                                           &
     &              ,ncf(:),iwrkb(:,:,:),kmap(:),iwrkn(:),iwrkg0(:)     &
     &              ,isorb(:),iwrk1(:),decorn(:)
!
!bu      allocatable :: iflagb(:)                            !born usage
!
      ALLOCATABLE :: IHARRY(:),E1BCF(:),SUMA(:)                         &
     &              ,JCP(:),JTP(:),JRP(:),JWRN(:),JWRD(:),ERN(:),ERD(:) &
     &              ,SUMRN(:),SUMRD(:)                                  &
     &              ,SUMPN(:,:),SUMPD(:,:)
!
      ALLOCATABLE :: LMX(:),QSB(:,:),QLB(:,:),ICF(:),DG(:)
!
      ALLOCATABLE :: NCFBIG(:,:),NX1(:),LX1(:)
!
      ALLOCATABLE :: DENERG(:),ID(:),IORIG(:)                           &
     &              ,DVECL(:),DVECV(:),DVECA(:)                         &
     &              ,DWRK(:)                                            &
     &              ,IWRK2(:),IWRK3(:),IWRK4(:),IWRK5(:),IWRK6(:)
!
      ALLOCATABLE :: DSTRNG(:,:)
      SAVE DSTRNG                                     !LOCAL, BUT FOR DR
!
      allocatable :: ncc0(:),iorb(:),iwrkg(:,:),isxdi(:)
!
      ALLOCATABLE :: DPA(:) !,DP(:)
!
      DIMENSION BIGL(0:MXLAB1),NUMB(0:MXLAB2)                           &
     &         ,STRING(MXSTRG),CLIT(MXLIT),LIT(MXLIT)
!
      DATA CMBLK1/' '/,MBLK/'    '/,MCOR/' COR'/,MSCOR/'*COR'/          &
     &    ,MOUT/'  X '/,BSCRO/.FALSE./
!
      DATA CLIT( 1),CLIT( 2),CLIT( 3),CLIT( 4)  /'1','2','3','4'/,      &
     &     CLIT( 5),CLIT( 6),CLIT( 7),CLIT( 8)  /'5','6','7','8'/,      &
     &     CLIT( 9),CLIT(10),CLIT(11),CLIT(12)  /'9','A','B','C'/,      &
     &     CLIT(13),CLIT(14),CLIT(15),CLIT(16)  /'D','E','F','G'/,      &
     &     CLIT(17),CLIT(18),CLIT(19),CLIT(20)  /'H','I','J','K'/,      &
     &     CLIT(21),CLIT(22),CLIT(23),CLIT(24)  /'L','M','N','O'/,      &
     &     CLIT(25),CLIT(26),CLIT(27),CLIT(28)  /'P','Q','R','S'/,      &
     &     CLIT(29),CLIT(30),CLIT(31),CLIT(32)  /'T','U','V','W'/,      &
     &     CLIT(33),CLIT(34),CLIT(35),CLIT(36)  /'X','Y','Z','a'/,      &
     &     CLIT(37),CLIT(38),CLIT(39),CLIT(40)  /'b','c','d','e'/,      &
     &     CLIT(41),CLIT(42),CLIT(43),CLIT(44)  /'f','g','h','i'/,      &
     &     CLIT(45),CLIT(46),CLIT(47),CLIT(48)  /'j','k','l','m'/,      &
     &     CLIT(49),CLIT(50),CLIT(51),CLIT(52)  /'n','o','p','q'/,      &
     &     CLIT(53),CLIT(54),CLIT(55),CLIT(56)  /'r','s','t','u'/,      &
     &     CLIT(57),CLIT(58),CLIT(59),CLIT(60)  /'v','w','x','y'/,      &
     &     CLIT(61),CLIT(62)  /'z','*'/
      DATA (BIGL(I),I=0,MXLAB1)/'S','P','D','F','G','H','I','K','L','M' &
     &                         ,'N','O','P','Q','R','S','T','U','V','W' &
     &                         ,'X','Y','Z','a','b','c','d','e','f','*'/
      DATA (NUMB(I),I=0,MXLAB2)/'0','1','2','3','4','5','6','7','8','9' &
     &                         ,'A','B','C','D','E','F','G','H','I','J' &
     &                         ,'K','L','M','N','O','P','Q','R','S','*'/
!
!-----------------------------------------------------------------------
!      ICOL(ILI,ILF,IONE1)=((ILF-1)*(ILF-2*IONE1))/2+ILI
!      IROW(ILI,ILF,IONE1,NENG)=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE1))/2
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!
      BKUTLS=KUTLS.LT.0                           !.T. FOR SINGLE CF MIX
      BKUTDSK=KUTDSK.LT.0                         !.T. FOR E-VEC TO DISK
!
! LOCAL
      ALLOCATE(DPA(MAXRS),STAT=IERR)                !,DP(MAXRS)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DIAGON: ALLOCATION FAILS FOR DPA' !,DP'
        NF=0
        GO TO 2200
      ENDIF
!
      IF(IEQ(0).NE.0)THEN
        ALLOCATE(ITMP(2*MXORB),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGON: ALLOCATION FAILS FOR ITMP'
          NF=0
          GO TO 2200
        ENDIF
      ENDIF
!
! local
      if(bkutls)then
        allocate(iwrkn(kmax),stat=ierr)
        if(ierr.ne.0)then
          write(mw0,*)'diagon: allocation fails for iwrkn'
          nf=0
          go to 2200
        endif
!      endif
      else
        if(bkutdsk.and.bfot)then
          allocate(iwrkg(mxorb,nsl0),stat=ierr)
          if(ierr.ne.0)then
            write(mw0,*)'diagon: allocation fails for iwrkg'
            nf=0
            go to 2200
          endif
        endif
      endif
!
! local, as recalculating from sr.algeb2 (ex-common/nrbtmp/)
! for some non-bkutls usage (as per algeb2)
      allocate(ncc0(mxorb),iorb(0:mxorb),isxdi(0:nsl0),stat=ierr)
      if(ierr.ne.0)then
        write(mw0,*)'diagon: allocation fails for ncc0,iorb,isxdi'
        nf=0
        go to 2200
      endif
!      endif
!
!-----------------------------------------------------------------------
!
      BACC=ALLOCATED(ACC)
      BVEL=IXD29.EQ.IXD28*2
      BMVDR=ALLOCATED(DCD)
      B2LL=ALLOCATED(D2LL)
!
!-----------------------------------------------------------------------
!
! FIX FOR FORTRAN 90 COMPILERS THAT DON'T ALLOW ASSIGNMENT OF CHARACTERS
! TO INTEGER VARIABLES, REQUIRED FOR HISTORIC BACKWARDS COMPATIBILITY
!
      OPEN(80,STATUS='SCRATCH',FORM='FORMATTED')
      WRITE(80,10820)CMBLK1,(CLIT(I),I=1,MXLIT)
      BACKSPACE(80)
      READ(80,10820)MBLK1,(LIT(I),I=1,MXLIT)
      CLOSE(80)
!
!-----------------------------------------------------------------------
!
! INITIALIZE LOGICALS ETC
!
      if(btime)then
        btimet=.true.                            !.t. gives more details
        timefh=dzero
        timeh=dzero
        timea=dzero
        timea1=dzero
        timea2=dzero
        timer1=dzero
        timer2=dzero
      else
        btimet=.false.
      endif
!
      BCONT=MODE.EQ.2.OR.MODE.EQ.3                  !FOR BOUND-CONTINUUM
!
      bposu=.false.             !.T. uses new e-evec dui pos, old is sym
      bmyrge=.false.        !do not try and merge degenerate bound TERMS
!
      BREL2=ABS(IREL).EQ.2                           !SMALL CPT PRESENT
      BDR=IDR.NE.0                                         !RYDBERG LOOP
      BBORN=MENGB.GE.0                                         !PWB DATA
!
      BKUTOO=KUTOO.NE.0
!
      BFOTJ=.NOT.BFOT.OR..NOT.BLAG                         !JUMP OVER PI
      IF(.NOT.BFOTJ.AND.PMIN.GT.DZERO)IPIG=1
      BELONG=IGAUGE.EQ.0                           !AEK/SEK LENGTH GAUGE
!
!                               !RESTRICT CAPTURES AND BUNDLE AUGER LOSS
      BUNA=EIMXLS.ne.DZERO.OR.NMETAP.GT.0
!
      IF(NMETAR.LT.0)THEN                             !RESOLVE BY CONFIG
        MMM=KMAX
      ELSE                                                   !UNRESOLVED
        MMM=0
      ENDIF
!
      BUNR=NRSLMX.LT.0.OR.NRSLMX.GE.0.AND.NNEW.GT.NRSLMX
                                                  !BUNDLE LOWER RAD RATE
!
      BUNPA=.NOT.BFOTJ.AND.BUNA                   !BUNDLE PI ELECTN CONT
      BUNPR=.NOT.BFOTJ.AND.(BUNR.OR.NMETAP.GT.0)  !BUNDLE PI PHOTON CONT
!
      BDOWN=NMETAP.LE.0                  !SO BUNDLED PI IS WEIGTHED DOWN
!
      NPRNT5=MOD(NPRINT,IFIVE)
      BPRNT0=BPRINT
      IF(BPRINT)BPRNT0=JPRINT.NE.-3
      BCPRNT=(MOD(MPNCH,ITWO).NE.0)                         !PRINT TCC'S
!
      BRADAT=BPRINT.OR.JPRINT.EQ.3.AND.INCL0.EQ.0       !ORIGINAL INCLUD
      IF(.NOT.BPRINT)BRADAT=JPRINT.LT.0.AND.NPRNT5.GT.-2 !EVAL G FUNCTNL
      BRADAT=BRADAT.AND.NPRNT5.NE.-2                   !AND HAVE ALGEBRA
!
      BTFU=BRADAT.OR.ISHFTLS.NE.0.OR.ITANAL.NE.0
                                                !ONLY PRINT CONTROL HERE
!
!OLD      BNJO=NJO.LE.0.AND.ISHFTLS.EQ.1    !ALLOWED PRIOR SHIFT IF TECS
!
      BORT=MORT.LT.0                              !FOR EXPECTATION PRINT
      TOLB2=TOLB/DTWO                                         !RYD->A.U.
!
      nmeta0=nmeta
!
! RESET INCLUD IF IC OPTIMIZATION
!
      INCLUD=MOD(INCL0,I1000000)
      IF(NJO.GT.0)INCLUD=0
      BINCF=IWGHT.LT.0                    !.T. INCLUD BY CF, .F. BY TERM
!
!-----------------------------------------------------------------------
!
! FLAG LAPACK IN USE (COULD SELECTIVELY MIX LAPACK AND NON-LAPACK...)
!
      LAPAK=1                                                    !LAPACK
!
      IF(BEIVEC.AND.(IDW.NE.0.OR.BTFU.OR.BAUGER.OR.INCLUD.NE.0.OR.      &
     &   BPRNT0.OR.IUNIT(MRW14).GT.0))THEN
        CEV='V'                           !WE NEED E-VECTORS
      ELSE
        CEV='N'                           !WE DON'T
      ENDIF
!
      CUL='U'                             !H TRIANGLE STORED IS UPPER
!
!-----------------------------------------------------------------------
!
! DETERMINE DIMENSIONS REQUIRED TO ALLOCATE
! (SEE ALGEB2 SET-UP, NOTE IAXUC IS REDUCED IF NO RAD OR DW.)
!
!-----------------------------------------------------------------------
!
      ISXDI(0)=0
      IAXDI=0
      IXAAI=0
      IAXUC=0
      NCI=0
      NCTOT=0
!
      IF(IDW.NE.0.OR.BTFU.and..not.bkutdsk)THEN
        IFLAG=1                 !STORE E-VECTORS FOR ALL SYMMETRIES
      ELSE                      !IF(BAUGER.OR.BPRNT0)  !TFU IN USE STILL
        IFLAG=-1                !STORE E-VECTORS ON A PER SYMMETRY BASIS
      ENDIF
!
      DO KGROUP=1,NSL0
!
        NC=NSL(KGROUP)
        IAXDI=MAX(IAXDI,NC)
!
        isxdi0=0
!
        N0=0
        NCC=0
!
        if(bkutls)then
!
          do k=1,kmax
            iwrkn(k)=0
          enddo
!
          DO J=1,NC
            I=NCI+J
            K=ABS(NFK(I))
            II=QCG(NF,K)
            ii=ieq(ii)
            IF(IYY(II).GT.0)then
              NCC=NCC+1
!          else
!            N0=N0+1
            endif
            iwrkn(k)=iwrkn(k)+1
          ENDDO
!
          ncft0=0
          ncft=0
          do k=1,kmax
            ncf0=iwrkn(k)
            isxdi0=max(isxdi0,ncf0)
            ncft=ncft+ncf0*ncf0
            if(.not.bfot)then
              II=QCG(NF,K)
              ii=ieq(ii)
              if(iyy(ii).lt.0)ncft0=ncft0+ncf0*ncf0
            endif
          enddo
!
          if(mode.eq.2)then
            if(.not.bkutdsk)then
              if(bfot)then                      !need c-c e-vectors
                nctot=nctot+ncft
              else                              !only b-b
                in4=nctot+ncft
                iaxuc=max(iaxuc,int(in4,sp))    !but need buffer
                nctot=nctot+ncft0               !so can overwite c-c
              endif
            else
              iaxuc=max(iaxuc,int(ncft,sp))
            endif
          else                                  !need full block
            if(mode.eq.4)then                   !bound only
              ncc=0
            endif
            nctot=nctot+ncft
          endif
!
        else
!
          do i=1,mxorb
            ncc0(i)=0
          enddo
          mx0=mxorb+1
!
          DO J=1,NC
            I=NCI+J
            K=ABS(NFK(I))
            II=QCG(NF,K)
            ii=ieq(ii)
            IF(IYY(II).GT.0)then
              NCC=NCC+1
              ncc0(ii)=ncc0(ii)+1
              mx0=min(mx0,ii)
            else
              N0=N0+1
            endif
          ENDDO
!
          if(mode.eq.2)then
            isxdi0=max(isxdi0,n0)
            iorb(mx0-1)=n0*n0
            do i=mx0,mxorb
              n=ncc0(i)
              iorb(i)=iorb(i-1)+n*n
              isxdi0=max(isxdi0,n)
            enddo
!
            if(.not.bkutdsk)then
              if(bfot)then                      !need c-c e-vectors
                nctot=nctot+iorb(mxorb)
              else                              !only need b-b
                in4=nctot+iorb(mxorb)
                iaxuc=max(iaxuc,int(in4,sp))    !but need c-c buffer
                nctot=nctot+n0*n0               !so can overwite c-c
              endif
            else
              iaxuc=max(iaxuc,int(iorb(mxorb),sp))
            endif
          else                                  !need full block
            if(mode.eq.4)then                   !bound only
              ncc=0
            endif
            isxdi0=iaxdi
            NCTOT=NCTOT+NC*NC
          endif
!
        endif
!
        isxdi(kgroup)=isxdi0
        isxdi(0)=max(isxdi(0),isxdi0)            !global
!
        IXAAI=MAX(IXAAI,NCC*(NC-NCC))
        NCI=NCI+NC
!
      ENDDO
!
      ISXDI0=ISXDI(0)
!
      IF(.NOT.BAUGER)IXAAI=0
!
!      write(mw0,*)ixaai,iaxuc
!      write(mw0,*)isxdi0,iaxdi
!
      IF(IFLAG.LT.0)THEN
        if(mode.ne.2)IAXUC=IAXDI*IAXDI
      ELSE
        if(mode.ne.2.or.bfot)IAXUC=NCTOT
      ENDIF
!      write(mw0,*)nctot,iaxuc
!
      CALL DIMUSE('MAXUC',IAXUC)
      CALL DIMUSE('MAXDI',IAXDI)
      CALL DIMUSE('MXAAI',IXAAI)
!
! LOCAL
!     NVEC ONLY IF BCONT OR BKUTLS, IWRK6 ONLY IF BUNA...
      IDMVEC=1
      IF(BCONT.OR.BKUTLS)IDMVEC=IAXDI
      IDIM6=1
      IF(BUNA)IDIM6=IAXDI
!
      BALLH=.FALSE.
      BALLA=.FALSE.
      ALLOCATE(DVU(IAXDI),DE(IAXDI),IDY(IAXDI),NVEC(IAXDI),IWRK6(IDIM6),&
     &         STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DIAGON: ALLOCATION FAILS FOR DVU,DE,IDY,NVEC'
        NF=0
        GO TO 2200
      ENDIF
      BALLH=.TRUE.
!
!      ALLOCATE(DU(ISXDI0,ISXDI0),STAT=IERR)         !NEED NOT BE GLOBAL
!      IF(IERR.NE.0)THEN
!        WRITE(MW0,*)'DIAGON: ALLOCATION FAILS FOR DU'
!        NF=0
!        GO TO ibid
!      ENDIF
!
      IF(BPRNT0)THEN
        IM=(IAXDI*(IAXDI+1))/2
        ALLOCATE(DVP(IM),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGON: ALLOCATION FAILS FOR DVP'
          NF=0
          GO TO 1500
        ENDIF
      ENDIF
!
! EX-COMMON/TRANS/                   !MAYBE PASSED TO DIAGFS
      ALLOCATE(TFU(IAXUC),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DIAGON: ALLOCATION FAILS FOR TFU'
        NF=0
        GO TO 1500                                               !RETURN
      ENDIF
      IAXUC=IFLAG*IAXUC
!
      IF(MENG*IXAAI.GT.0)THEN
!        ALLOCATE(DUI(MENG,IXAAI),DVI(MENG,IAXDI),STAT=IERR)
        ALLOCATE(DUI(IXAAI,MENG),DVI(IAXDI,MENG),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGON: ALLOCATION FAILS FOR DUI,DVI'
          NF=0
          GO TO 1500
        ENDIF
        BALLA=.TRUE.
        IF(BLAG)THEN
          ALLOCATE(DDY(MENG))
        ELSE
          ALLOCATE(DDY(1))
          DDY(1)=DONE
          NP1=1
          NP2=1
        ENDIF
      ENDIF
!
! LOCAL (SMALL-ISH)
!
      MXVORB0=10                                  !FOR HISTORIC PP READS
      DO K=1,KMAX
        LM=0
        DO J=1,MXORB
          IF(NEL(J,K).GT.0)LM=LM+1
        ENDDO
        MXVORB0=MAX(MXVORB0,LM)
      ENDDO
!
      ALLOCATE(LMX(KMAX),QSB(MXVORB0,KMAX),QLB(MXVORB0,KMAX),ICF(0:KMAX)&
     &         ,STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DIAGON: ALLOCATION FAILS FOR LMX,QSB,QLB,ICF'
        NF=0
        GO TO 1500                                               !RETURN
      ENDIF
!
      ALLOCATE(IHARRY(KMAX),E1BCF(KMAX),SUMA(0:MMM),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DIAGON: ALLOCATION FAILS FOR IHARRY,E1BC,SUMA'
        NF=0
        GO TO 1500                                               !RETURN
      ENDIF
!
      NC1=NCI+1
      ALLOCATE(DENERG(NC1),IWRK2(NC1),ID(NCI),IORIG(NCI),DVECL(NCI),    &
     &         DVECV(NCI),DVECA(NCI),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DIAGON: ALLOCATION FAILS FOR DENERG ETC'
        NF=0
        GO TO 1500                                               !RETURN
      ENDIF
!
! EX-COMMON/TRANLS/                   !MAYBE PASSED TO DIAGFS
      ALLOCATE(NADRU(NCI),NAI(NCI),IEORD(NCI),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DIAGON: ALLOCATION FAILS FOR NADRU,NAI,IEORD'
        NF=0
        GO TO 1500                                               !RETURN
      ENDIF
!
      ALLOCATE(DWRK(NCI),IWRK3(NCI),IWRK4(NCI),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DIAGON: ALLOCATION FAILS FOR DWRK,IWK'
        NF=0
        GO TO 1500                                               !RETURN
      ENDIF
!
      allocate(iwrkg0(0:nsl0))
!
      if(bauger)allocate(nadlu(iaxdi))                           !bcont
!
      if(bkutls)then
        allocate(ncf(kmax),kmap(kmax),iwrk1(kmax))
        if(bradat)allocate(iwrkb(2,kmax,nsl0)) !not used if no radiation
      elseif(bcont)then                                  !not yet bauger
        allocate(iwrkn(mxorb))
      endif
!!p
!p      ngrp=1
!p      mxborb=0
!p      if(irlx.lt.0)then
!p        ngrp=-irlx/100000             !until /nrborb/ in a module
!p        mxborb=-irlx-100000*ngrp
!p      endif
!
      ngrp1=1
      if(irlx.lt.0)ngrp1=ngrp
!
      allocate(decorn(ngrp1))
!
! SET-UP TCC'S
!
      MTCC=0
      NTCC=0
      IF(BCPRNT.AND.MPNCH.LT.0)THEN                         !AND TO DISC
        IF(KTCC.LT.0)THEN
          IF(IUNIT(MW1).LT.0)THEN
            WRITE(MW6,*)"TRYING TO RE-OPEN FILE='TCC.DAT'..."
            WRITE(MW0,*)'TRYING TO RE-OPEN UNIT=MW1'
            GO TO 2300
          ENDIF
          IUNIT(MW1)=1
          OPEN(MW1,FILE='TCC.DAT',STATUS='REPLACE')             !JAJOM
        ELSE
          IF(IUNIT(MW4).LT.0)THEN
            WRITE(MW6,*)"TRYING TO RE-OPEN FILE='TCCDW.DAT'..."
            WRITE(MW0,*)'TRYING TO RE-OPEN UNIT=MW4'
            GO TO 2300
          ENDIF
          IUNIT(MW4)=1
          OPEN(MW4,FILE='TCCDW.DAT',STATUS='REPLACE')           !STGICF
        ENDIF
      ENDIF
!
! SET CHARGES ETC.
!
      NZA=NZION-MION+1
      DZA2=NZA*NZA
      DZA=-NZA
!      DZM=-NZION
      DZ2=NZION-MION
      IF(NZION.EQ.MION)DZ2=DONE
      DZ2=DZ2*DZ2
      TSHFT=MSHIFT+MSHIFT
!
! RE-SCALE ONE-BODY TERMS INVOLVING RYDBERG ORBITAL IN DR OPERATION
!
      DSHFT0=DZERO
      IF(BJUMP2)THEN
        DO K=1,MXORB                    !1/N**3 SCALING
          IF(DEY(K).EQ.DZERO)GO TO 50
!         IF(K.LE.ABS(MPSEUD))GO TO 115
          IF(IVAL(K).NE.0)THEN
            TM=NNEW
            IF(KSHIFT.LE.0)TM=TM-SCREEN(K)                  !NEEDS Q.D.
            TN=DZA/TM
            TN=TN*TN                    !COULOMB
            IF(BREL)THEN
              T=DTWO*TM/(QL(K)+1)-DTHREE/DFOUR
              TMV=T*TN*TN               !M-V
              IF(QL(K).EQ.QZERO)THEN    !DARWIN
                TT=dza/TM               !DZM->dza since large n
                TT=TT*TT
                TD=-TT*TT*TM
              ELSE
                TD=DZERO
              ENDIF
              T=(TMV+TD)*DFSC*DFSC
              if(tn+t.lt.dzero)t=dzero  !use non.rel.
              TN=TN+T
            ENDIF
            DSHIFT(K)=TN/DTWO
            DSHFT0=MAX(DSHFT0,DSHIFT(K))
            TN=NNOLD
            IF(KSHIFT.LE.0)TN=TN-SCREEN(K)                  !NEEDS Q.D.
            TN=TN/TM
            FACT(K)=TN**3
            IN=ICOL(K,K,IZERO)
            DUY(IN)=DUY(IN)*FACT(K)
            DEY(K)=DUY(IN)-DSHIFT(K)
            IF(KSHIFT.GT.0)DSHIFT(K)=DZERO
            IF(QED.LT.QZERO.AND.IYY(K).LT.0)THEN
              VPINT(K)=FACT(K)*VPINT(K)
              SLFINT(K)=FACT(K)*SLFINT(K)
            ENDIF
            FACT(K)=SQRT(FACT(K))
          ENDIF
          IF(K.EQ.1)GO TO 50
          I=K-1
          DO J=1,I
            IN=ICOL(J,K,IZERO)
            DUY(IN)=DUY(IN)*FACT(K)*FACT(J)
          ENDDO
          IF(BMVD)THEN                              !ELSE DONE IN DIAGFS
            DO J=1,K
              IF(DEY(J).NE.DZERO.AND.QL(K).EQ.QL(J))THEN
                IN=ICOL(J,K,IZERO)
                DD=FACT(J)*FACT(K)
                IF(BMVDR)DMASS(IN)=DMASS(IN)*DD
                IF(BMVDR)DCD(IN)=DCD(IN)*DD
                IF(B2LL)D2LL(IN)=D2LL(IN)*DD
                IF(KUTOO.EQ.98)DXSI(IN)=DXSI(IN)*DD
              ENDIF
            ENDDO
          ENDIF
   50   ENDDO
        GO TO 200
      ELSEIF(NNEW.GE.NSW)THEN
        DO K=1,MXORB
          IF(IVAL(K).NE.0)DSHFT0=MAX(DSHFT0,DSHIFT(K))
        ENDDO
      ENDIF
!
! DETERMINE CONFIGURATION OVERLAP MATRIX
! (FOR USE WITH RELAXED ORBITALS, IRLX=2 ONLY.)
!
      IF(IRLX.EQ.2)THEN      !DETERMINE OVERLAPS BETWEEN CF'S
!
        ALLOCATE(IWRK5(NF))
!
        KK=0
        DO KF=2,KMAX
          DO KG=1,KF-1
            KK=KK+1
            DO I=1,NF
              IWRK5(I)=QCG(I,KG)
            ENDDO
            K=0
            OVL=DONE
            DO I=1,NF
              DO L=1,NF
                IF(IEQ(IWRK5(L)).EQ.IEQ(QCG(I,KF)))THEN
                  IWRK5(L)=0
                  I1=MIN(QCG(I,KF),QCG(L,KG))
                  I2=MAX(QCG(I,KF),QCG(L,KG))
                  II=((I2-1)*(I2-2))/2+I1
                  OVL=OVL*OVLPGR(II)
                  GO TO 60
                ENDIF
              ENDDO
              K=K+1
              IPAIR(KK)=K
              IF(K.GT.2)GO TO 80
   60       ENDDO
            OVLPCF(KK)=OVL
   80     ENDDO
        ENDDO
!
        DEALLOCATE(IWRK5)
!
        IF(BPRINT)THEN
          WRITE(MW6,10500)(K,K=1,KMAX-1)
          K2=0
          DO KF=2,KMAX
            K1=K2+1
            K2=K2+KF-1
            WRITE(MW6,10490)KF,(OVLPCF(K),K=K1,K2)
          ENDDO
        ENDIF
!
! MULTIPLY ONE-BODY INTEGRALS BY OVERLAPS
!
        DO J=2,MXORB
          KF=IGRCF(J)
          IF(DEY(J).EQ.DZERO.OR.KF.EQ.0)GO TO 150
          DO I=1,J-1
            KG=IGRCF(I)
            IF(DEY(I).EQ.DZERO.OR.KG.EQ.0)GO TO 100
            IF(BJUMP.AND.IVAL(I)+IVAL(J).EQ.0)GO TO 100
            IF(QL(I).NE.QL(J))GO TO 100
            IF(KF.NE.KG)THEN
              K1=MIN(KF,KG)
              K2=MAX(KF,KG)
              KK=((K2-1)*(K2-2))/2+K1
              IF(IPAIR(KK).EQ.1)THEN
                IN=ICOL(I,J,IZERO)
                OVL=OVLPCF(KK)
                DUY(IN)=DUY(IN)*OVL
!                DUY(J,I)=DUY(J,I)*OVL         !NEEDED?
                IF(BMVD.OR.NJO.GT.0)THEN
                  IF(BMVDR)DMASS(IN)=DMASS(IN)*OVL
                  IF(BMVDR)DCD(IN)=DCD(IN)*OVL
                  IF(B2LL)D2LL(IN)=D2LL(IN)*OVL
                ENDIF
              ENDIF
            ENDIF
  100     ENDDO
  150   ENDDO
!
      ENDIF
!
! GENERATE AND PRINT SOME EXPECTATION VALUES
! (NOT USED SUBSEQUENTLY, SO CAN SKIP IF PRINTING SUPPRESSED.)
!
  200 IF(.NOT.BPRNT0)GO TO 400
!
      IF(MGRP.GE.0)WRITE(MW6,10050)MAXRS
      IF(MGRP.LT.0)WRITE(MW6,10060)MAXRS
      L=MAXRS-2
!
      IF(.NOT.ALLOCATED(DSTRNG))THEN
        ALLOCATE(DSTRNG(6,MXORB),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGON: ALLOCATION FAILS FOR DSTRNG'
          NF=0
          GO TO 1500
        ENDIF
      ENDIF
!
      DO K=1,MXORB
!
        IF(DEY(K).EQ.DZERO)GO TO 300
!       IF(K.LE.ABS(MPSEUD))GO TO 816
        K17=K
        N1=QL(K)/2
        N3=N1
        IF(BORT)N3=K-1
        IF(BJUMP.AND.IVAL(K).EQ.0)GO TO 250
        DO J=1,6
          DSTRNG(J,K)=DZERO
        ENDDO
        IN=ICOL(K,K,IZERO)
        DSTRNG(3,K)=-DUY(IN)
        DSTRNG(1,K)=(DEY(K)+DSTRNG(3,K))*DTWO
        IF(.NOT.BDR)DSTRNG(1,K)=DSTRNG(1,K)+DTWO*DSHIFT(K)
        IF(MODE.LT.6.AND.QN(K).LT.0)GO TO 250    !MODE=1-4, CURRENTLY...
!
        DO J=2,6
          M=J-3
          IF(M.NE.0)THEN
            IF(BREL2)THEN
              DO I=1,MAXRS
                DD=DPNL(I,K)*DPNL(I,K)+DQNL(I,K)*DQNL(I,K)
                DPA(I)=DD*DX(I)**M
              ENDDO
            ELSE
              DO I=1,MAXRS
                DPA(I)=DPNL(I,K)*DPNL(I,K)*DX(I)**M
              ENDDO
            ENDIF
            CALL WEDDLE(DZERO,DPA,DC,MNH,DHNS,MJH,MAXRS)
            DSTRNG(J,K)=DC
!            write(mw0,*)m,dc
          ENDIF
        ENDDO
!
  250   N2=JEND(N3+1)
        IF(N2.EQ.0)N2=MAXRS
!
        WRITE(MW6,10070)K,QN(K),N1,MION,NZION,SCREEN(K),                &
     &                  (DSTRNG(J,K),J=1,6),DADJUS(N3+1),DX(N2),        &
     &                  (DPNL(I,K)*FACT(K),I=L,MAXRS)
!
  300 ENDDO
!
      WRITE(MW6,10020)(DX(I),I=L,MAXRS)
!
      IF(JND.LT.0)THEN                              !THIS WAS THE LAST N
        DEALLOCATE(DSTRNG,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGON: DE-ALLOCATION FAILS FOR DSTRNG'
          NF=0
          GO TO 1500
        ENDIF
      ENDIF
!
!  DETAILED PRINTOUT OF MASS-VELOCITY PLUS DARWIN INTEGRALS
! (SKIPPED IF PRINTING SUPPRESSED.)
!
      IF(BMVD.AND.BPRNT0)THEN
        WRITE(MW6,10570)JPRINT
        DD1=DZERO
        DD2=DZERO
        DD3=DZERO
        DO K=1,MXORB
          IF(DEY(K).NE.DZERO)THEN
            IN=ICOL(K,K,IZERO)
            IF(BMVDR)DD1=DMASS(IN)
            IF(BMVDR)DD2=DCD(IN)
            DD=DD1+DD2
            IF(B2LL)DD3=D2LL(IN)
            L=QL(K)/2
            WRITE(MW6,10590)K,QN(K),L,DEY(K),DD1,DD2,DD,DD3
          ENDIF
        ENDDO
!
        WRITE(MW6,10600)
        DO L=1,IRL
          IF(QRL(5,L).EQ.-1)THEN
            L1=QRL(1,L)
            L2=QRL(3,L)
            IN=ICOL(L2,L1,IZERO)
            IF(BMVDR)DD1=DMASS(IN)
            IF(BMVDR)DD2=DCD(IN)
            IF(B2LL)DD3=D2LL(IN)
            WRITE(MW6,10610)L,L1,L2,DD1,DD2,DD3
          ENDIF
        ENDDO
      ENDIF
!
!  DETAILED PRINTOUT OF ONE-BODY INTEGRALS I(A,C)
!
      IF(IRL.LT.0)THEN            !.LT.0 SUPRESSES PRINTOUT
        WRITE(MW6,10390)
        K0=0
        DO K=1,K17
          I=K
          IF(DEY(K).EQ.DZERO)I=10000
          WRITE(MW6,10400)I,(DUY(K0+J),J=1,K)
          K0=K0+K
        ENDDO
      ENDIF
!
! DETAILED PRINTOUT OF ANY QED CONTRIBUTIONS
!
      IF(QED.LT.QZERO.AND.BPRNT0)THEN
        WRITE(MW6,10900)
        DO K=1,MXORB
          IF(DEY(K).NE.DZERO)THEN
            IF(IYY(K).GT.0)GO TO 400                !WE ARE DONE
            DD=VPINT(K)+SLFINT(K)
            WRITE(MW6,10910)K,QN(K),QL(K)/2,VPINT(K),SLFINT(K),DD
          ENDIF
        ENDDO
      ENDIF
!
  400 CONTINUE
!----------------------------------------------------------
!  *** CALCULATE SLATER INTEGRALS:  DRL(L)  (AND 2-NFS) ***
!----------------------------------------------------------
!
      if(btimet)call nrb_time(timei)
!
      IF(IRL.GT.0)THEN
!
        CALL SLATR(BPRNT0)
!
        IF(NF.LE.0)GO TO 2300
      ENDIF
!
!
      IF(BPRNT0.AND.MAXLAM.NE.MAXLAM0)WRITE(MW6,10080)2*MAXLAM
!
      IF(.NOT.BRADAT)GO TO 500
      IF(BJUMP.AND..NOT.BRAD)GO TO 500
!
!-----------------------------------------------------
! *** CALCULATE R^K MULTIPOLE INTERGALS (INC BORN) ***
!-----------------------------------------------------
!
      CALL RKINT(BPRNT0)
!
      IF(NF.LE.0)GO TO 2300
!
  500 CONTINUE
!
      if(btimet)then
        call nrb_time(timef)
        times=timef-timei
!par        if(iam.ge.0)then                                        !par
!par          write(iwp,*)'proc',iam,' for diagon:'                 !par
!par          write(iwp,*)'    integral time=',nint(times),'sec'    !par
!par          call flush(iwp)                                       !par
!par        else                                                    !par
        write(iw,*)'integral time=',nint(times),'sec'
!par        endif                                                   !par
      endif
!
!***********************************************************************
!
!  CONSTRUCT AND DIAGONALIZE ENERGY (SUB-)MATRICES.
!
!***********************************************************************
!
!
      IF(.NOT.BREL)GO TO 600                               !NPRINT.GT.-5
!
      if(brel)go to 600                                    !allow LSR
!
      IF(BPRNT0)WRITE(MW6,10790)NPRINT
      DF=DZERO
      DECORE=DZERO
      NC0=0
      DO K=1,NSL0
        NC=NSL(K)
        NC0=NC0+(NC*(NC+1))/2
      ENDDO
      NCOR=NC0                                       !HISTORIC MAX MAXUC
!
! N.B. MDEL.GE.0 FIXED NOW BACK IN SR.MINIM.
!
      IF(MDELE.EQ.0)GO TO 900
      IF(MDELE.LT.0)THEN
        IF(BDR)THEN
          WRITE(MW6,10800)
!
!  IF REQUIRE THIS THEN NEED TO SET UP DISTINCT FILES FOR TFU AND THE
!  INTERPOLATION ORBITALS OF SR.RADCON.
!
          NF=-1
          GO TO 900
        ENDIF
        GO TO 900
      ENDIF
      ISHFTLS=0
      GO TO 900
!
  600 DO I=1,KMAX
        IHARRY(I)=0
      ENDDO
!
!  CALCULATE ENERGY CONTRIBUTION DECORE OF THE NW CORE ELECTRONS
!  (MAYBE GROUP DEPENDENT)
!
      do n=1,ngrp1
!
        n1=n-1
        decor0=dzero
!
! 1-BODY (INC. NFS IF LSM/ICM)
!
        DC1=DZERO                                    ! 1-BODY
        DO L=1,NW
          J=NNL(L,1)
          if(irlx.lt.0)j=j+mxborb*n1
          DC1=DC1+DEY(J)
          IF(BMVD)THEN
            IN=ICOL(J,J,IZERO)
            IF(BMVDR)DC1=DC1+DCD(IN)+DMASS(IN)
            IF(QED.LT.QZERO)THEN        !SPLIT FOR CASE NOT-ALLOC...
              DC1=DC1+VPINT(J)+SLFINT(J)
            ENDIF
            IF(KUTOO.EQ.98)DC1=DC1+DXSI(IN)
          ENDIF
        ENDDO
!
! 2-BODY (INC. NFS IF LSM/ICM)
!
        DC2=DZERO                                    ! 2-BODY
        DO I=1,NAD(0)
          J=INT(NRK(I),SP)+n1
          DC2=DC2+DRL(J)*DRK(I)
          IF(BKUTOO.AND.BMVD)THEN
            IF(BFALL(I))THEN
              DC2=DC2-DRK(I)*DZL(J)
            ELSE
              DC2=DC2+DRK(I)*DZL(J)
            ENDIF
            DC2=DC2+DRK(I)*DXTWO(J)+DEK(I)*DETA(J)
!                                -              (MINUS) JONES
          ENDIF
        ENDDO
!
        DECORE=DC1+DC2                      ! 1-BODY + 2-BODY
!
        IF(BPRNT0)THEN
          WRITE(MW6,10090)DC2,DC1
          IF(BAUGER)THEN
            WRITE(MW6,10140)
            IF(ISHFTLS.NE.0)WRITE(MW6,10190)
          ENDIF
        ENDIF
!
        decorn(n)=decore
        decor0=min(decor0,decore)
!
      enddo
!
      decore=decor0
!
      do n=1,ngrp1
        decorn(n)=decorn(n)-decore
      enddo
!
!  CALCULATE 1-BODY CF ENERGY CONTRIBUTION OF THE NF VALENCE ELECTRONS
!
      M2=0
      DO M1=1,KMAX
        E1BCF(M1)=DZERO
        DO L=1,NF
          IF(QCG(L,M1).NE.M2)THEN
            M2=QCG(L,M1)
            DD=DEY(M2)
            IF(BMVDR.AND.BMVD)THEN
              IN=ICOL(M2,M2,IZERO)
              DD=DD+DCD(IN)+DMASS(IN)
            ENDIF
            IF(QED.LT.QZERO)THEN            !SPLIT FOR CASE NOT-ALLOC...
              IF(QN(M2).GT.0)DD=DD+VPINT(M2)+SLFINT(M2)
            ENDIF
          ENDIF
          E1BCF(M1)=E1BCF(M1)+DD
        ENDDO
        IF(ICAV.NE.0)E1BCF(M1)=E1BCF(M1)+ECAVX(M1)-ECAV(M1) !CA CORRECTN
      ENDDO
!
!  COLLAPSE BACK RELAXED ORBITAL LIST
!
      IF(IEQ(0).LT.0)THEN
!p        MXBORB=-IEQ(0)
        KF=MB+MXBORB
        DO K=1,KF
          K2=2*K
          ITMP(K2-1)=QN(K)
          ITMP(K2)=QL(K)/2
          IORB(K)=K2
        ENDDO
        KP=2*KF
        KF=MB+MXBORB*KMAX
        IF(BDR)THEN
          DO K=1,KMAX
            KF=KF+1
            IF(IGRCF(KF).GT.0.AND.KF.EQ.IEQ(KF))THEN         !FIRST OCC.
              KP=KP+1
              ITMP(KP)=QN(KF)
              KP=KP+1
              ITMP(KP)=QL(KF)/2
              IORB(KF)=KP
            ENDIF
          ENDDO
        ENDIF
        IF(BCONT)THEN
          DO K=1,KMAX
            KF=KF+1
            IF(IGRCF(KF).GT.0.AND.KF.EQ.IEQ(KF))THEN         !FIRST OCC.
              KP=KP+1
              ITMP(KP)=QN(KF)
              KP=KP+1
              ITMP(KP)=QL(KF)/2
              IORB(KF)=KP
            ENDIF
          ENDDO
        ENDIF
      ELSEIF(IEQ(0).GT.0)THEN
        KP=0
        DO K=1,MXORB
          IF(K.EQ.IEQ(K))THEN                                !FIRST OCC.
            KP=KP+1
            ITMP(KP)=QN(K)
            KP=KP+1
            ITMP(KP)=QL(K)/2
            IORB(K)=KP
          ENDIF
        ENDDO
      ENDIF
!
      IF(MODE.GT.0)THEN
        EIONMN=DZERO
        IF(IEQ(0).EQ.0)THEN
          KF=MIN(MXLIT,MXORB)
          IF(BPRNT0)WRITE(MW7,10170)KMAX,NZION,MION,                    &
     &                              (ABS(QN(K)),QL(K)/2,K=1,KF)
          IF(.NOT.BPRNT0)WRITE(MW27)int(KMAX),int(NZION),int(MION),     &
     &                              (int(ABS(QN(K))),int(QL(K)/2),K=1,  &
     &                              KF)
        ELSE
          KF=MIN(KP,ITWO*MXLIT)
          IF(BPRNT0)WRITE(MW7,10170)KMAX,NZION,MION,                    &
     &                              (ABS(ITMP(K)),ITMP(K+1),K=1,KF,2)
          IF(.NOT.BPRNT0)WRITE(MW27)int(KMAX),int(NZION),int(MION),     &
     &                              (int(ABS(ITMP(K))),int(ITMP(K+1)),  &
     &                              K=1,KF,2)
        ENDIF
      ENDIF
!
      DO K=1,KMAX
        LM=0
!
        DO J=1,MXORB
          IF(NEL(J,K).GT.0)THEN
            LM=LM+1
            QSB(LM,K)=INT(NEL(J,K),QP)
            IF(LM.GT.1)QSB(LM,K)=QSB(LM,K)+Q50
            IF(IEQ(0).NE.0)THEN
              JQ=IEQ(J)
              JM=MIN(IORB(JQ)/2,MXLIT)
            ELSE
              JQ=J
              JM=MIN(J,MXLIT)
            ENDIF
            QLB(LM,K)=LIT(JM)
!HAR        QLB(LM,K)=ICHAR(CLIT(JM))
            NCC0(LM)=JQ
          ENDIF
        ENDDO
        LMX(K)=LM
!
        IF(LM.LT.MXVORB0)THEN
          LP=LM+1
          DO J=LP,MXVORB0
            QSB(J,K)=0
            QLB(J,K)=MBLK1
!HAR        QLB(J,K)=ICHAR(CMBLK1)
          ENDDO
        ENDIF
        M2=QCG(NF,K)
        KW=K
        MST=MSTAT(K)
        IF(IYY(M2).GT.0)THEN
          M1=QL(M2)+1
          KW=-K
          MST=MSTAT(K)/(M1+M1)
        ENDIF
        IF(MODE.GT.0)THEN
          IF(BPRNT0)WRITE(MW7,10270)KW,MST,MA,MB,                       &
     &                              (QSB(L,K),QLB(L,K),L=1,LM)
!HAR  X            ,CHAR(QLB(L,K)),L=1,LM)
          IF(.NOT.BPRNT0)WRITE(MW27)int(KW),int(MST),int(MA),int(MB),   &
     &                              (int(QSB(L,K)),int(QLB(L,K)),L=1,   &
     &                              MXVORB0)
        ENDIF
        DO L=1,LM
          QLB(L,K)=NCC0(L)
        ENDDO
      ENDDO
!
      IF(NMETAR.LT.0)THEN                        !MAP SUM OVER CHANNEL L
        ICF(0)=0
        DO K=1,KMAX
          I=QCG(NF,K)
          IF(IYY(I).GT.0)THEN
            ICF(K)=K
            K1=K-1
            IF(ICF(K1).NE.0)THEN                 !CHECK LAST FOR A MATCH
              IF(LMX(K).NE.LMX(K1))GO TO 650
              DO L=LMX(K)-1,1,-1
                IF(QLB(L,K).NE.QLB(L,K1))GO TO 650
                IF(QSB(L,K).NE.QSB(L,K1))GO TO 650
              ENDDO
              ICF(K)=ICF(K1)
            ENDIF
          ELSE
            ICF(K)=0
          ENDIF
  650   ENDDO
      ENDIF
!
      IF(MODE.GT.0)THEN
        IF(BPRNT0)WRITE(MW7,10150)NZION,MION
        IF(.NOT.BPRNT0)WRITE(MW27)int(NZION),int(MION)
      ENDIF
!
!
!*********************************************************************
!
!  THE FOLLOWING KGROUP LOOP RUNS THROUGH ALL THE NSL0 (SL,P) GROUPS
!  C.F. THE CORRESPONDING LOOP IN SR.ALGEB2.
!
!*********************************************************************
!
!
      NENERG=0
      NCOR=0
!      MC=0
      NCI=0
      LUMAX=0
      NCUT=KCUT
      IF(KCUT.LE.0)NCUT=10000
      NCTOT=0
      BINT=IAXUC.GT.0
      DMIN=D1P20
      DMAX=-D1P20
      ITMIN=0
      NSKP=0
      BAUX=JPRINT.EQ.1.OR.JPRINT.GT.4      !.NOT.BAUX IGNORE CORRELATION
      NEIG=NEIGEN                                !USER SETS NO. E-STATES
      IF(ECORR.LT.DZERO)THEN
        EEIG=ECORR/DTWO-DECORE                    !AS ECORR ABSOLUTE RYD
        if(eeig.ge.dzero)stop 'diagon, eigg reset .ge. zero...'
      ELSE
        EEIG=DZERO
      ENDIF
!
      dionmn=dzero
      etest=eimxls
!
! - no longer in use (unless uncommented for testing)
      TOLA=CMXLSA*D1M4                           !MAX B-F MATRIX ELEMENT
      IF(NNEW.GT.1)THEN
        T=NNEW
        T=T/DTWO
        TOLA=TOLA/(T*SQRT(T))
      ENDIF
      tola1=tola
      tola2=tola1/100
!
      IF(WLG1.LT.DZERO)THEN                      !MAX AUGER RATE
        WLG=D1M2
      ELSE
        WLG=DZERO
      ENDIF
      WLG=MAX(WLG,WLG1)
!
      if(bkutls)then                   !map configs: all bound then cont
        kb=0
        do k=1,kmax
          if(iyy(qcg(nf,k)).lt.0)then
            kb=kb+1
            kmap(kb)=k
          endif
        enddo
        kc=kb
        do k=1,kmax
          if(iyy(qcg(nf,k)).gt.0)then
            kc=kc+1
            kmap(kc)=k
          endif
        enddo
        kmax0=kb
        if(kc.gt.kb)then
          kmax1=kmap(kmax0+1)
        else
          kmax1=-1                        !should not be used as no cont
        endif
      endif
!
      iwrkg0(0)=0
!
! START SLP LOOP
!
      DO KGROUP=1,NSL0
!
        NC=NSL(KGROUP)
!
        IF(BKUTDSK)THEN
          ILEN=ISXDI(KGROUP)
          CALL DISKTF(-KGROUP,IVEC,ILEN,TFU,IZERO)
          IF(ILEN.LT.0)THEN
            NF=0
            GO TO 1500
          ENDIF
        ENDIF
!
        IF(.NOT.BINT)NCTOT=0
!
        NGRPI(KGROUP)=NCI
        NCI=NCI+NC
!
        LL=NENERG
!
        MPW=QPI(KGROUP)/2
        MSW=QSI(KGROUP)+1
        MLW=QLI(KGROUP)/2
        MWJ=MSW*(QLI(KGROUP)+1)
!
        IF(NAST.GT.0)THEN                         !MAY RESTRICT E-STATES
          LSP=10000*MSW+10*MLW+MPW
          DO N=1,NAST
            IF(LSPI(N).EQ.LSP)THEN                !WE HAVE A WINNER
              IF(NLSPI(N).GT.0)NEIG=NLSPI(N)      !THEN USER SET
              GO TO 660
            ENDIF
          ENDDO
          NEIG=NEIGEN                             !SHOULDN'T GET HERE
  660     CONTINUE
        ENDIF
!
! INDEX E-VECTORS AND, MAYBE, BOUND-CONT INTERACTIONS
!                                     !don't use parallel flag "par"!!
        if(bkutls)then                !Partition by config (scf)
!
          do k=1,kmax
            ncf(k)=0
          enddo
!
          n0=0
          DO I=1,NC
            II=I+LL                   !+NENERG
            M1=NFK(II)
            M1=ABS(M1)
            M2=QCG(NF,M1)
            M2=IEQ(M2)
            IDY(I)=M2
            IF(IYY(M2).LT.0)then
              IDY(I)=-IDY(I)
              n0=n0+1                 !total bound still for B-C
            ELSE
              NFK(II)=-M1
            ENDIF
            ncf(m1)=ncf(m1)+1
            NAI(II)=ncf(m1)           !REL POSITION OF ABS TERM IN GROUP
          ENDDO
!
          iwrkg0(kgroup)=iwrkg0(kgroup-1)+n0
!
          k1=kmap(1)
          iwrk1(k1)=0
          iwrkn(k1)=0
          k0=k1
!
          if(bradat)then
            iwrkb(1,k1,kgroup)=0
            iwrkb(2,k1,kgroup)=ncf(k1)
!      write(mw6,*)'kgroup=',kgroup
!      write(mw6,*)'1',k1,ncf(k1),iwrkb(2,k1,kgroup)
          endif
!
          do k=2,kmax
            k1=kmap(k)
            nn=ncf(k0)
            iwrk1(k1)=iwrk1(k0)+nn*nn
            iwrkn(k1)=iwrkn(k0)+nn
            if(bradat)then
              iwrkb(1,k1,kgroup)=iwrkb(1,k0,kgroup)+nn
              iwrkb(2,k1,kgroup)=ncf(k1)
!      write(mw6,*)k,k1,ncf(k1),iwrkb(2,k1,kgroup)
            endif
            k0=k1
          enddo
!
          DO I=1,NC
            II=I+LL                   !+NENERG
            M1=NFK(II)
            M1=ABS(M1)
            nadru(ii)=nctot+iwrk1(m1)+ncf(m1)*(nai(ii)-1)
          ENDDO
!
          if(bfot)then                       !need c-c e-vectors
            k=kmap(kmax)
          elseif(kmax0.gt.0)then             !only b-b, so overwrite c-c
            k=kmap(kmax0)
          else
            k=0
          endif
          if(k.gt.0)nctot=nctot+iwrk1(k)+ncf(k)*ncf(k)
!
        elseif(mode.eq.2)then         !NEED B-C PARTITIONING
!
          do i=1,mxorb
            ncc0(i)=0
          enddo
          mx0=mxorb !+1
!
          n0=0
          DO I=1,NC
            II=I+LL                   !+NENERG
            M1=NFK(II)
            M1=ABS(M1)
            M2=QCG(NF,M1)
            M2=IEQ(M2)
            IDY(I)=M2
            IF(IYY(M2).LT.0)then      !BOUND
              IDY(I)=-IDY(I)
              n0=n0+1
              NAI(II)=n0              !REL POSITION OF ABS TERM IN GROUP
            ELSE                      !CONTINUUM
              NFK(II)=-M1
              ncc0(m2)=ncc0(m2)+1
              NAI(II)=ncc0(m2)        !REL POSITION OF ABS TERM IN GROUP
              mx0=min(mx0,m2)
            ENDIF
          ENDDO
!
          iwrkg0(kgroup)=iwrkg0(kgroup-1)+n0
          iorb(mx0)=n0*n0
          iwrkn(mx0)=0                !only need index cont
!
          do i=mx0+1,mxorb
            nn=ncc0(i-1)              !maybe zero
            iorb(i)=iorb(i-1)+nn*nn
            iwrkn(i)=iwrkn(i-1)+nn
          enddo
!
          if(allocated(iwrkg))then
            do i=mx0,mxorb            !so only need allocate mx0:mxorb
              iwrkg(i,kgroup)=ncc0(i)
            enddo
          endif
!
          DO I=1,NC
            II=I+LL                   !+NENERG
            IF(IDY(I).GT.0)THEN
              m2=idy(i)
              nadru(ii)=nctot+iorb(m2)+ncc0(m2)*(nai(ii)-1)
            else
              nadru(ii)=nctot+n0*(nai(ii)-1)
            ENDIF
          ENDDO
!
          if(bfot)then                          !need c-c e-vectors
            nctot=nctot+iorb(mxorb)+ncc0(mxorb)*ncc0(mxorb)
          else                                  !only b-b
            nctot=nctot+n0*n0                   !so can overwrite c-c
          endif
!
        ELSE                          !B-B
!
          n0=0
          DO I=1,NC
            II=I+LL                   !+NENERG
            NAI(II)=I
            M1=NFK(II)
            M1=ABS(M1)
            M2=QCG(NF,M1)
            M2=IEQ(M2)
            IDY(I)=M2
            IF(IYY(M2).LT.0)THEN
              IDY(I)=-IDY(I)
              n0=n0+1
            ELSE
              NFK(II)=-M1
            ENDIF
            NADRU(II)=NCTOT               !END POSITION OF E-VECTOR II-1
            NCTOT=NCTOT+NC
          ENDDO
!
          iwrkg0(kgroup)=iwrkg0(kgroup-1)+nc      !=ngrpi(kgroup)?
!
        ENDIF
!
        IF(BPRNT0)THEN                    !INITIALIZE FOR PRINTING
          IM=(NC*(NC+1))/2
          DO IP=1,IM
            DVP(IP)=DZERO
          ENDDO
        ENDIF
!
        if(btimet)call nrb_time(timei)
!
! SET-UP BOUND-CONTINUUM (AUGER) PROBLEM
!
        IF(BAUGER)THEN                    !BCONT
!
          NHOLD=NCOR
!                                         !CHECK B-C INDEXING
          LU=0
          DO L=1,NC
            IF(IDY(L).GT.0)THEN
              nadlu(l)=lu                 !old pos, not used by new
              lu=lu+n0
            ENDIF
          ENDDO
!
          IF(LU.GT.LUMAX)LUMAX=LU
          IF(LU.GT.IXAAI)THEN             !SHOULD NOT HAPPEN NOW
            WRITE(MW6,10560)LU
            WRITE(MW0,*)'***INCREASE MXAAI'
            GO TO 2300
          ENDIF
          LUX=LU
!
! STORE BOUND-CONTINUUM (SLATER & NFS)
!
          DO I=1,NC
!
            DO J=1,I
!
              if(bkutls)then
                btest=idy(i)*idy(j).gt.0.and.nfk(i+ll).ne.nfk(j+ll)
                if(btest)go to 665
              else
                btest=idy(i).gt.0.and.idy(j).gt.0.and.idy(i).ne.idy(j)
                if(btest)go to 665
              endif
!
              NCOR=NCOR+1
!
              IF(IDY(I)*IDY(J).GT.0)GO TO 665
!
! INDEX AND INITIALIZE
!
              if(idy(i).gt.0)then
                lc=i
                lb=j
              else
                lc=j
                lb=i
              endif
              llb=ll+lb
              llc=ll+lc
              if(bposu)then                             !new pos
                m1=nai(llc)
                if(bkutls)then
                  m2=-nfk(llc)
                  m1=m1-iwrkn(kmax1)
                else
                  m2=idy(lc)
                endif
                lu=(iwrkn(m2)+m1-1)*n0+nai(llb)
              else                                      !old pos
                lu=nadlu(lc)+nai(llb)
              endif
              if(bkutls)then
                m2=nfk(llb)
                lu=lu+iwrkn(m2)
              endif
!
              DO M=1,MENG
!                DUI(M,LU)=DZERO
                DUI(LU,M)=DZERO
              ENDDO
!
              N1=NAD(NCOR-1)+1
              N2=NAD(NCOR)
!
              DO L=N1,N2
                M1=INT(NRK(L),SP)
                KK=NRLI(M1)
                IF(KK.GT.0)THEN
! SLATER
                  DO M=1,MENG
!                     DUI(M,LU)=DUI(M,LU)+DRLI(M,KK)*DRK(L)
                    DUI(LU,M)=DUI(LU,M)+DRLI(M,KK)*DRK(L)
                  ENDDO
! NFS
                  IF(BKUTOO.AND.BMVD)THEN
                    DO M=1,MENG
                      DS=DZLI(M,KK)*DRK(L)
                      IF(BFALL(L))DS=-DS
                      DS=DS+DXTWOI(M,KK)*DRK(L)+DETAI(M,KK)*DEK(L)
                                                                  !-JONS
!                      DUI(M,LU)=DUI(M,LU)+DS
                      DUI(LU,M)=DUI(LU,M)+DS
                    ENDDO
                  ENDIF
!
                ENDIF
              ENDDO
!
              IF(BPRNT0)THEN
                IP=ICOL(J,I,IZERO)           !GLOBAL
!                DVP(IP)=DUI(NREL,LU)         !STORE FOR PRINTING
                DVP(IP)=DUI(LU,NREL)         !STORE FOR PRINTING
              ENDIF
!
  665         CONTINUE
!
            ENDDO
!
          ENDDO
!
          NCOR=NHOLD
!
        ENDIF
!
! FORM H-MATRIX FOR DIAGONALIZATION
!
        ICB=0
        ICC=0
!
        DO I=1,NC                                         !START SL LOOP
!
          II=I+LL                    !+NENERG
          NN=NADRU(II)
!
          M1=NFK(II)
          M1=ABS(M1)
!
          DE(I)=E1BCF(M1)
!OLD        IF(BNJO)DE(I)=DELELS(II,1)       !NO SHIFT PRIOR TO DIAG NOW
!ADD  DE(I)=DE(I)+DC1
!
          if(irlx.lt.0)then
            n=icfgp(m1)
            de(i)=de(i)+decorn(n)
          endif
!
          M2=QCG(NF,M1)
          if(bkutls)then
            IF(IYY(M2).GT.0)DE(I)=DE(I)+ECOR1
          else
            IF(IYY(M2).LT.0)THEN
              ICB=ICB+1
            ELSE
              DE(I)=DE(I)+ECOR1
              M2=IEQ(M2)
              DO M=1,ICC
                IF(M2.EQ.IORB(M))GO TO 680
              ENDDO
              ICC=ICC+1
              IORB(ICC)=M2
            ENDIF
          endif
!
  680     CONTINUE
!
! LOOP OVER SECOND INDEX OF H-MATRIX
!
          DO J=1,I                           !START SL LOOP
!
            DD=DZERO
!
            JJ=J+LL
!
            if(bcont)then
              if(idy(i)*idy(j).lt.0)then     !b-c, already formed
                if(mode.eq.2)then            !else mode.eq.3
                  if(bauger)ncor=ncor+1
                  go to 700
                endif
              endif
              if(bkutls)then
                btest=idy(i)*idy(j).gt.0.and.nfk(ii).ne.nfk(jj)
                if(btest)go to 700
              else
                btest=idy(i).gt.0.and.idy(j).gt.0.and.idy(i).ne.idy(j)
                if(btest)go to 700
              endif
            else
              if(bkutls.and.nfk(ii).ne.nfk(jj))go to 700
            endif
!
            if(bnobv.and.idy(i).lt.0.and.idy(j).lt.0)then
              ivi=abs(idy(i))
              ivj=abs(idy(j))
              if(ival(ivi).ne.ival(ivj))then           !zero ryd-N+1 int
                ncor=ncor+1
                go to 690
              endif
            endif
!
            N1=NAD(NCOR)+1
            NCOR=NCOR+1
            N2=NAD(NCOR)
!
! check for bkutls (just zero-out usual multi-config interactions)
            if(.not.bkutls.and.nfk(ii).ne.nfk(jj))then
              if(abs(nfk(ii)).gt.kutls)go to 690
              if(abs(nfk(jj)).gt.kutls)go to 690
            endif
!
! 2-BODY NON-REL (SLATER)
!
            DO L=N1,N2
              M1=INT(NRK(L),SP)
              DD=DD+DRL(M1)*DRK(L)
            ENDDO
!ADD      DD=DE(I)
!
! CASE LSM/ICM; ADD-IN 1- AND 2-BODY NFS
!
            IF(BMVD)THEN
              DO L=N1,N2
                M1=INT(NRK(L),SP)
! 1-BODY
                IF(QRL(5,M1).LT.0)THEN
                                      !DZL(KX)=DXTWO(KX)=DETA(KX)=0 HERE
                  DS=DZERO
                  L1=QRL(1,M1)        !FALLING ORDER L1.GE.L2
                  L2=QRL(3,M1)
                  IN=ICOL(L2,L1,IZERO)
                  IF(BMVDR)DS=DCD(IN)+DMASS(IN)
                  IF(KUTOO.EQ.98)DS=DS+DXSI(IN)
                  DS=DS*DRK(L)
                  DD=DD+DS
                ENDIF
! 2-BODY
                IF(BKUTOO)THEN
                  DS=DZL(M1)*DRK(L)
                  IF(BFALL(L))DS=-DS
                  DS=DS+DXTWO(M1)*DRK(L)+DETA(M1)*DEK(L)  !- JONES
                  DD=DD+DS
                ENDIF
              ENDDO
            ENDIF
!
! STORE H-MATRIX FOR DIAGONALIZATION
!
  690       NI=NAI(JJ)
!
!      write(mw6,*)ii,jj,ni,nn,dd
!          if(abs(dd).lt.d1m10)dd=dzero
!
            TFU(NI+NN)=DD
!
            IF(BPRNT0)THEN
              IP=ICOL(J,I,IZERO)                   !GLOBAL
              DVP(IP)=DD                           !STORE H FOR PRINTING
            ENDIF
!
  700       CONTINUE
!
          ENDDO                              !END SL LOOP
!
          TFU(NI+NN)=TFU(NI+NN)+DE(I)                   !ADD DIAG E HERE
!
        ENDDO                                               !END SL LOOP
!
        if(btimet)then
          call nrb_time(timef)
          timefh=timefh+timef-timei
        endif
!
!*****************************************************************
!
!     DIAGONALIZE HAMILTONIAN
!
!*****************************************************************
!
        if(btime)call nrb_time(timei)
!
        INFO=0
!
        IF((MODE.NE.2.OR.ICC.LE.0).and..NOT.BKUTLS)THEN
!
!***RETAIN (COMMENTED-OUT) FOR CASE OF TFU *4 THEN DIAG WITH *8 STILL.
!   AND COMMENT-OUT HDIAG(...,TFU,...) (!)
!          NN=NADRU(LL+1)
!          DO J=1,NC
!            DO I=1,J                        !NAI(I+LL)=J HERE (ALL B-B)
!              DU(I,J)=TFU(NN+I)             !TFU IS UPPER H COLUMNWISE
!            ENDDO
!            NN=NN+NC
!          ENDDO
!!
!          CALL HDIAG(CEV,CUL,NC,NEIG,EEIG,DU,ISXDI0,DVU,DVECV,NF,INFO)
!!
!          NN=NADRU(LL+1)                   !RE-INITIALIZE
!          DO J=1,NC
!            DO I=1,NC
!              TFU(NN+I)=DU(I,J)
!            ENDDO
!            NN=NN+NC
!          ENDDO
!***END RETAIN
!
          NN=NADRU(LL+1)
!
          CALL HDIAG(CEV,CUL,NC,NEIG,EEIG,TFU(NN+1),NC,DVU,DVECV,NF,    &
     &               INFO)
!
          IF(NC*NF.LE.0.OR.INFO.GT.0)GO TO 2300
!
          IF(MODE.GE.4)THEN
            icc=0
            NN=NADRU(LL+1)                  !RE-INITIALIZE FOR SAFETY *4
            DO J=1,NC
              DO I=1,NC
                IF(IDY(I)*IDY(J).LT.0)TFU(NN+I)=DZERO
              ENDDO
              NN=NN+NC
            ENDDO
          ENDIF
!
          IF(BKUTDSK)THEN                         !WRITE TFU TO DISK
            NN=NADRU(LL+1)                     !RE-INITIALIZE FOR SAFETY
            DO J=1,NC
!
              CALL DISKTF(KGROUP,J,NC,TFU(NN+1),-IONE)
!
              NN=NN+NC
            ENDDO
          ENDIF
!
        ELSE
!
! DIAGONALIZE SEPARATELY THE ICC C-C BLOCKS PLUS THE B-B BLOCK
!
          IF(BKUTLS)THEN
            icb=0
            icc=0
            m0=1
            m1=kmax
          ELSE
            IF(ICB.GT.0)THEN
              M0=0
              IORB(0)=-1000
            ELSE
              M0=1
            ENDIF
            M1=ICC
          ENDIF
!
          NSUB0=0                                   !GLOBAL
          DO M=M0,M1
!
            iflagc=0
!
            NSUB=0
            DO M7=1,NC
!
              IF(BKUTLS)THEN
                if(abs(nfk(m7+ll)).eq.m)then
                  if(idy(m7).lt.0)then
                    icb=icb+1               !just flags global existence
                  else
                    icc=icc+1               !just flags global existence
                    if(.not.bfot)iflagc=1          !flag cont for kutdsk
                  endif
                else
                  go to 710
                endif
              ELSE
                IF(IORB(M).LT.0.AND.IDY(M7).LT.0)GO TO 705
                IF(IORB(M).NE.IDY(M7))GO TO 710
              ENDIF
!
  705         NSUB=NSUB+1
              NVEC(NSUB0+NSUB)=M7
!
  710       ENDDO
!
            if(bkutls)then
              if(nsub.eq.0)go to 730            !only if bkutls=.t.
            else
! could remove, but you never know...
              if(m.gt.0)then
                if(nsub.ne.ncc0(iorb(m)))then
                  write(mw0,*)'icc=',m,'iorb=',iorb(m),'ncc0=',         &
     &                        ncc0(iorb(m)),'nsub=',nsub
                  stop 'cont orb index error...'
                endif
                if(.not.bfot)iflagc=1          !flag cont for kutdsk
              else
                if(nsub.ne.n0)stop 'bound orb index error...'
              endif
            endif
! HOLD
            NSUBH=NSUB
            IDIAGH=IDIAG
!
  720       CONTINUE
 7000     CONTINUE                                               !LAPACK
!
!***RETAIN (COMMENTED-OUT) FOR CASE OF TFU *4 THEN DIAG WITH *8 STILL.
!   AND COMMENT-OUT HDIAG(...,TFU,...) (!)
!            N1=NVEC(NSUB0+1)+LL
!            NN=NADRU(N1)
!            DO IS=1,NSUB
!              DO JS=1,IS
!                DU(JS,IS)=TFU(NN+JS)
!              ENDDO
!              NN=NN+NSUB
!            ENDDO
!!
!            CALL HDIAG(CEV,CUL,NSUB,NEIG,EEIG,DU,ISXDI0,DVECL,DVECV,NF,
!     &                 INFO)
!!
!            N1=NVEC(NSUB0+1)+LL                          !RE-INITIALIZE
!            NN=NADRU(N1)
!            DO IS=1,NSUB
!              NI=NVEC(NSUB0+IS)
!              DVU(NI)=DVECL(IS)         !STORE E-ENERGIES IN SYMM ORDER
!              DO JS=1,NSUB
!                TFU(NN+JS)=DU(JS,IS)
!              ENDDO
!              NN=NN+NSUB
!            ENDDO
!***END RETAIN
!
            N1=NVEC(NSUB0+1)+LL                !RE-INITIALIZE FOR SAFETY
            NN=NADRU(N1)
!
            CALL HDIAG(CEV,CUL,NSUB,NEIG,EEIG,TFU(NN+1),NSUB,DVECL,     &
     &                 DVECV,NF,INFO)
!
            IF(NF.LE.0)GO TO 2300
!
          IF(INFO.GT.0)THEN   ! LAPACK FAILURE, SO TRY DIAG      !LAPACK
            WRITE(MW6,*)                                                &!LAPACK
     &              ' RE-RUNNING THIS MATRIX ONLY WITH SR.DIAG'  !LAPACK
            GO TO 7000                                           !LAPACK
          ENDIF                                                  !LAPACK
!
            IF(NSUB.EQ.0)THEN   ! DIAG FAILURE, SO RELOAD AND USE JACORD
              WRITE(MW6,*)' RE-RUNNING THIS MATRIX ONLY WITH SR.JACORD'
              NSUB=NSUBH
              IDIAG=1
              GO TO 720
            ENDIF
!
            IDIAG=IDIAGH
!
! STORE E-ENERGIES IN DVU IN ORIGINAL SYMMETRY ORDER (4 EASE OF WRITING)
! ELSE COULD REPLACE DVECL WITH DVU DIRECTLY, AS PER TFU.
!
            DO IS=1,NSUB
              NI=NVEC(NSUB0+IS)
              DVU(NI)=DVECL(IS)
            ENDDO
!
            IF(BKUTDSK.and.iflagc.eq.0)THEN
!
              N1=NVEC(NSUB0+1)+LL                         !RE-INITIALIZE
              NN=NADRU(N1)
              DO IS=1,NSUB
!
                IVEC=NSUB0+IS
!
                CALL DISKTF(KGROUP,IVEC,NSUB,TFU(NN+1),-IONE)
!
                NN=NN+NSUB
!
              ENDDO
!
              NSUB0=NSUB0+NSUB
!
            ENDIF
!
  730       continue           !re-entry point for kutls=.t. case nsub=0
!
          ENDDO                              !END LOOP OVER H SUB-BLOCKS
!
        ENDIF
!
        if(btime)then
          call nrb_time(timef)
          timeh=timeh+timef-timei
        endif
!
!*****************************************************************
!
! PRINT TERM ENERGIES, TRANSFORMATION MATRICES AND H-SUBMATRICES.
!
!*****************************************************************
!
! test set corr-corr mixing to zero.
! No real time saving, better not to generate it in the first place.
!
!      do i=1,nc
!        ii=i+ll
!        dry=2*dvu(i)
!        nn=abs(nfk(ii))
!        if(idiag.ge.0.and.nn.gt.ncut.or.dry*ecorr.gt.ecorr*ecorr
!     &                .or.dry.gt.eskpl.and.dry.lt.eskph)then
!          iwrk3(ii)=-1
!        else
!          iwrk3(ii)=1
!        endif
!      enddo
!      do i=1,nc
!        ii=i+ll
!        if(iwrk3(ii).lt.0)then
!          do j=1,nc
!            jj=j+ll
!            if(iwrk3(jj).lt.0.and.idy(i)*idy(j).gt.0)then
!              if(idy(i).lt.0.or.idy(i).eq.idy(j))then
!                nn=nadru(ii)
!                ni=nai(jj)
!                tfu(nn+ni)=dzero
!              endif
!            endif
!          enddo
!        endif
!      enddo
!
        M2=0
!
        DO I=1,NC
!
!     J IS THE ARRAY INDEX OF THE WHOLE H-MATRIX, WHEREAS I IS THE
!     POSITION IN THE APPROPRIATE SUBMATRIX
!
          J=I+LL                                  !+NENERG
          IWRK3(J)=0
          M=NFK(J)
          JJ=ABS(M)
!        IF(IDY(I).GT.0)NFK(J)=-JJ
!
          DD=DVU(I)
          IF(DD.NE.DZERO)THEN                     !E-STATE EXISTS
!
!OLD        IF(BNJO)DD=DD-DELELS(J,1)             !AS NO PRIOR SHIFT NOW
!
! REMOVE ENERGY OF CONTINUUM ELECTRON FROM ENERGY TERM LIST
            IF(IDY(I).GT.0)THEN
              IF(MODE.LT.3)DD=DD-DYY(NREL)
              DD=MOD(DD,TSHFT)
              dionmn=min(dionmn,dd)
            ENDIF
!
! POST SHIFT FOR AUGERS
            IF(ISHFTLS.EQ.1)THEN
              DD=DD+DELELS(J,1)                   !CORRECTION
            ELSEIF(ISHFTLS.NE.0)THEN
              if(eflg0*delels(j,2).lt.dzero)then
                DD=delels(j,2)+eflg0-decore       !absolute
              else
                dd=dd+delecf(jj,1)                !correction
              endif
            ENDIF
!
            IF(DD.LT.DMIN)THEN
              DMIN=DD
              ITMIN=J
            ENDIF
            IF(DD.GT.DMAX)DMAX=DD
!
            IF(IDIAG.GE.0.AND.JJ.GT.NCUT)THEN    !CORRELATION
              IWRK4(J)=-J
            ELSE
              IWRK4(J)=J
            ENDIF
          ELSE                                   !E-STATE DOES NOT EXIST
            IWRK4(J)=0
          ENDIF
!
          DENERG(J)=DD
!
          IF(IDY(I).GT.0)THEN
            DD=DD+DECORE
            DD=DD+DD
            IF(DD.LT.EIONMN)EIONMN=DD
          ENDIF
!
!          IF(BTFU)THEN
!
          IF(BPRNT0)THEN
            IHARRY(JJ)=IHARRY(JJ)+1
            NN=NADRU(J)
            IF((MODE.NE.2.OR.ICC.LE.0).AND..NOT.BKUTLS)THEN
              DO L=1,NC
                DVECL(L)=TFU(NN+L)
              ENDDO
            ELSE
              DO L=1,NC
                DVECL(L)=DZERO
                if(idy(i)*idy(l).gt.0)then
                  btest1=nfk(j).eq.nfk(l+ll)
                  btest2=idy(i).lt.0.or.idy(i).eq.idy(l)
                  if(bkutls.and.btest1.or..not.bkutls.and.btest2)then
                    ni=nai(l+ll)
                    dvecl(l)=tfu(nn+ni)
                  endif
                endif
              ENDDO
            ENDIF
            M1=M2
            M2=M1+I
            M12=M1
            M1=M1+1
            L2=MIN(NC,ITEN)
            M12=M12+MIN(I,10-L2)
            WRITE(MW6,10030)J,MSW,MLW,MPW,DE(I),DVU(I),NFK(J),IHARRY(JJ)&
     &                      ,I,(DVECL(L),L=1,L2),(DVP(L),L=M1,M12)
            IF(M2.GT.M12)WRITE(MW6,10040)(DVECL(L),L=L2+1,NC),          &
     &                                   (DVP(L),L=M12+1,M2)
          ENDIF
!
!          ENDIF
!
        ENDDO
!
        if(eimxls.gt.0)etest=eimxls+2*(dionmn+decore)    !rel. to ground
!
        NENERG=NENERG+NC
!
! RE-SET ABSOLUTE GROUND STATE BY MODIFYING CORE ENERGY (VIA SHFTLS)
!
!      IF(ISHFTLS.LT.0.AND.EFLG0.LT.DZERO)DECORE=EFLG0-DMIN
!
!
!********************************************
!
!     ***COMPUTE AUTOIONIZATION RATES***
!
!     EVALUATE <ic!tc><tc!H!tb><tb!ib>
!                               __
!           I.E. DV(I,J)*H(J,K)*DV(K,L)
!
!********************************************
!
!
        IF(ICC.EQ.0)GO TO 850           !BAIL OUT TO NEXT SYMMETRY GROUP
!
        IF(BUNA)THEN                       !INDEX CONTINUUM ENERGY ORDER
!
          I1=LL+1
          CALL HPSRTI(NC,DENERG(I1),IWRK2)
!
          M=0
          DECMIN=-D1P20
!
          DO J=1,NC
            IWRK6(J)=0
            I=IWRK2(J)
            II=I+LL
            IF(IDY(I).GT.0)THEN
              DRY=DENERG(II)+DECORE
              DRY=DRY+DRY
              IF(DRY.LE.etest.and.iwrk4(ii).ne.0)THEN          !RESOLVED
                IF(DENERG(II).GT.(DECMIN+TOLB2))THEN               !A.U.
                  M=M+1
                  DE(M)=DENERG(II)
                ENDIF
                IF(IWRK6(M).GT.0)THEN
                  NSKP=NSKP+1
                  IWRK3(II)=-M
!              ELSEIF(IDIAG.GE.0.AND.-NFK(II).GT.NCUT)THEN  !CORR FOR AA
                ELSEIF(IWRK4(II).LE.0)THEN                  !CORR FOR AA
                  NSKP=NSKP+1
                  IWRK3(II)=-M
                ELSE
                  IWRK6(M)=II
                  IWRK3(II)=M
                ENDIF
                DECMIN=DENERG(II)              !ALLOW FOR ANY DRIFT<TOLB
              ELSE
                NSKP=NSKP+1
                IWRK3(II)=-1
              ENDIF
            ELSE
!            IF(IDIAG.GE.0.AND.NFK(II).GT.NCUT)THEN    !ONLY CORR FOR AA
              IF(IWRK4(II).LE.0)THEN                   !ONLY CORR FOR AA
                NSKP=NSKP+1
                IWRK3(II)=-1 !will not write term info to rate file
              ELSE
                IWRK3(II)=0  !dummy
              ENDIF
            ENDIF
            IWRK2(J)=1                         !keep all for now...
          ENDDO
!
          MSUM=M
        ELSE
          MSUM=0
        ENDIF
!
        IF(ICB.EQ.0)GO TO 800           !BAIL OUT TO NEXT SYMMETRY GROUP
        IF(.NOT.BAUGER)GO TO 800
!
! LOOP OVER INITIAL AUTOIONIZING TERMS
!
        if(btime)call nrb_time(timei)
!
        n00=n0
        DO J=1,NC
!
          IF(IDY(J).GT.0)GO TO 750
!
          JJ=J+LL
          if(denerg(jj).lt.dionmn)go to 750                 !true bound!
!        IF(IDIAG.GE.0.AND.NFK(JJ).GT.NCUT)GO TO 603        !CORRELATION
          IF(.NOT.BAUX.AND.IWRK4(JJ).LE.0)GO TO 750         !CORRELATION
!
          DO M=0,MMM                            !=0 IF NMETAR .GE. 0
            SUMA(M)=DZERO
          ENDDO
          DO M=1,MSUM                           !=0 IF .NOT. BUNA
            DVU(M)=DZERO
          ENDDO
!
          if(bkutls)then
            m2=nfk(jj)
            luj=iwrkn(m2)
            n00=ncf(m2)
          endif
!
! FIND MAX INTERP ENERGY NEEDED FOR THIS INITIAL STATE
!
          IF(BLAG)THEN
!
            DM0=DENERG(JJ)+DSHFT0-dionmn
            DM=-DM0                            ! - AS DON'T NEED COEFFS
!
            CALL LAGINT(DM,DDY,NP1JJ,NP2JJ)
!
          ELSE
!
            NP2JJ=MENG                         !=1 THEN
!
          ENDIF
!
          if(btimet)call nrb_time(timeia)
!
! APPLY INITIAL STATE MIXING FOR EACH UNMIXED FINAL CONTINUUM STATE
!
          J0=NADRU(JJ)
!
          DO I=1,NC
            IF(IDY(I).GT.0)THEN
!
              ii=i+ll
              m1=nai(ii)
              if(bkutls)then
                m2=-nfk(ii)
                m1=m1-iwrkn(kmax1)
              else
                m2=idy(i)
              endif
              ig=iwrkn(m2)+m1                   !old ig=i
!
!!orr            bcorr=idiag.ge.0.and.-nfk(i+ll).gt.ncut)          !corr
!!orr            if(.not.bcorr)then                                !corr
!
              if(bposu)then                     !new pos
                lu=(ig-1)*n0
              else
                lu=nadlu(i)                     !old pos
              endif
              if(bkutls)lu=lu+luj
!
            IF(LAPAK.GT.0)THEN                                   !LAPACK
              DO L1=1,NP2JJ                                      !LAPACK
                DVI(IG,L1)=                                             &!LAPACK
     &            DDOT(N00,TFU(J0+1),IONE,DUI(LU+1,L1),IONE)     !LAPACK
              ENDDO                                              !LAPACK
            ELSE                                                 !LAPACK
              DO L1=1,NP2JJ
                DD=DZERO
                DO M=1,N00
!                  if(abs(TFU(J0+m)*dui(lu+m,1)).gt.tola1)then      !old
!!                    if(abs(TFU(J0+m)).gt.cmxlsa)then             !orig
                  DD=DD+TFU(J0+M)*DUI(LU+M,L1)
!                  endif
                ENDDO
                DVI(IG,L1)=DD
              ENDDO
            ENDIF                                                !LAPACK
!!orr            endif                                             !corr
            ENDIF
          ENDDO
!
          if(btimet)then
            call nrb_time(timefa)
            timea1=timea1+timefa-timeia
            timeia=timefa
          endif
!
! LOOP OVER FINAL CONTINUUM TERMS
!
          DO I=1,NC
!
            IF(IDY(I).LT.0)GO TO 740
            II=I+LL
!          IF(IDIAG.GE.0.AND.-NFK(II).GT.NCUT)GO TO 605     !CORRELATION
            IF(.NOT.BAUX.AND.IWRK4(II).LE.0)GO TO 740       !CORRELATION
!
            IF(ABS(DENERG(II)+DYY(NREL)-DENERG(JJ)).GT.ACE)GO TO 740
!
            DRY=DENERG(II)
            DS=DENERG(JJ)-DRY
!
            IF(DS.LT.DZERO)GO TO 740          !NOT ENERGETICALLY ALLOWED
!                       .AND.BLAG
!
! SET-UP INTERPOLATION
!
            IF(BLAG)THEN
!
!            if(ds.lt.dyy(1).or.ds.gt.dyy(meng))then
!              write(mw6,*)'***extrapolating augers1'
!              write(mw6,*)2*dyy(1),2*ds,2*dyy(meng)
!              if(ds.lt.d0pt9*dyy(1).or.ds.gt.d1pt1*dyy(meng))
!     &        stop '***extrapolating augers1'
!            endif
!
              IF(IGAPE.GT.0)THEN
                IF(DS.LT.DYY(IGAPE).AND.DS.GT.DYY(IGAPE-1))THEN
                  WRITE(MW6,*)                                          &
     &                  'SR.DIAGON: ***EXTRAPOLATING AUGER2 LS ENERGIES'
                  WRITE(MW6,*)IGAPE,2*DYY(IGAPE-1),2*DS,2*DYY(IGAPE)
                  IF(DS.LT.D0PT9*DYY(IGAPE).AND.DS.GT.D1PT1*DYY(IGAPE-1)&
     &               )THEN
                    WRITE(MW0,*)                                        &
     &                  'SR.DIAGON: ***EXTRAPOLATING AUGER2 LS ENERGIES'
!                  GO TO 2400
                  ENDIF
                ENDIF
              ENDIF
!
              M2=-IDY(J)
              DM=DS+DSHIFT(M2)
!
              CALL LAGINT(DM,DDY,NP1,NP2)
!
              if(np2.gt.np2jj)then
                write(mw0,*)j,np2jj,i,np2,dm0,dm
!            dm0=denerg(jj)+dshft0-dionmn
!             dm=denerg(jj)-denerg(ii)+dshift(m2)
                write(mw0,*)denerg(jj),dshft0,dionmn,denerg(ii),        &
     &                      dshift(m2)
                stop 'diagon np2jj error'
              endif
!
            ENDIF
!
! APPLY FINAL-STATE MIXING TO INTERPOLATED MATRIX ELEMENTS
!
            IF(BKUTLS)THEN
              M2=-NFK(I+LL)
              M0=NCF(M2)
              L1=IWRKN(M2)-iwrkn(kmax1)
            ELSE
              M2=IDY(I)
              M0=NCC0(M2)
              L1=IWRKN(M2)
            ENDIF
!
            I0=NADRU(II)
            DAS=DZERO
!
            DO N=NP1,NP2
            IF(LAPAK.GT.0)THEN                                   !LAPACK
              DD=DDOT(M0,TFU(I0+1),IONE,DVI(L1+1,N),IONE)        !LAPACK
            ELSE                                                 !LAPACK
              DD=DZERO
              DO M=1,M0
!                if(abs(tfu(i0+m)*dvi(l1+m,np1)).gt.tola2)then      !old
!!                if(abs(tfu(i0+m)).gt.cmxlsa)then                 !orig
                DD=DD+TFU(I0+M)*DVI(L1+M,N)
!                endif
              ENDDO
            ENDIF                                                !LAPACK
              DAS=DAS+DDY(N)*DD
            ENDDO
!
! FORM AUTOIONIZATION RATE
!
            DAS=ABS(DAS)*DAS*DKON
            IF(ABS(DAS).GT.WLG)THEN
              IF(BPRNT0)WRITE(MW6,10120)MWJ,II,JJ,DAS,DS,DRY
              DS=DS+DS
              DRY=DRY+DECORE
              DRY=DRY+DRY
!              IF(DRY.LT.EIONMN)EIONMN=DRY
!
              IF(BUNA)THEN                                 !BUNDLE CONT
                IF(DRY.LE.etest)THEN                       !RESOLVED
                  M=IWRK3(II)
                  M=ABS(M)
                  DVU(M)=DVU(M)+ABS(DAS)
                ELSE                                       !BUNDLED
                  M=0
                  IF(NMETAR.LT.0)M=ICF(-NFK(II))           !BY TARGET CF
                  SUMA(M)=SUMA(M)+ABS(DAS)
                ENDIF
              ELSE
                IF(BPRNT0)WRITE(MW7,10160)NFK(JJ),JJ,MWJ,NFK(II),II,DAS,&
     &                                    DS,DRY
                IF(.NOT.BPRNT0)WRITE(MW27)int(NFK(JJ)),int(JJ),int(MWJ),&
     &                                    int(NFK(II)),int(II),DAS,DS,  &
     &                                    DRY
              ENDIF
            ENDIF
!
  740     ENDDO                  !END LOOP OVER FINAL TERMS
!
          IF(BUNA)THEN
            DO M=1,MSUM
              IF(DVU(M).GT.WLG)THEN
                IWRK2(M)=1                                  !FLAG EXISTS
                DS=DENERG(JJ)-DE(M)
                DS=DS+DS
                DRY=DE(M)+DECORE
                DRY=DRY+DRY
                II=IWRK6(M)
                IF(BPRNT0)WRITE(MW7,10160)NFK(JJ),JJ,MWJ,NFK(II),II,    &
     &                                    DVU(M),DS,DRY
                IF(.NOT.BPRNT0)WRITE(MW27)int(NFK(JJ)),int(JJ),int(MWJ),&
     &                                    int(NFK(II)),int(II),DVU(M),  &
     &                                    DS,DRY
              ENDIF
            ENDDO
            IF(SUMA(0).GT.WLG)THEN
              IF(BPRNT0)WRITE(MW7,10160)NFK(JJ),JJ,MWJ,IZERO,IZERO,     &
     &                                  SUMA(0),EINF,DZERO
              IF(.NOT.BPRNT0)WRITE(MW27)int(NFK(JJ)),int(JJ),int(MWJ),  &
     &                                  int(IZERO),int(IZERO),SUMA(0),  &
     &                                  EINF,DZERO
            ENDIF
            DO M=1,MMM
              IF(SUMA(M).GT.WLG)THEN
                IF(BPRNT0)WRITE(MW7,10160)NFK(JJ),JJ,MWJ,-M,IZERO,      &
     &                                    SUMA(M),EINF,DZERO
                IF(.NOT.BPRNT0)WRITE(MW27)int(NFK(JJ)),int(JJ),int(MWJ),&
     &                                    int(-M),int(IZERO),SUMA(M),   &
     &                                    EINF,DZERO
              ENDIF
            ENDDO
          ENDIF
!
          if(btimet)then
            call nrb_time(timefa)
            timea2=timea2+timefa-timeia
          endif
!
  750   ENDDO                   !END LOOP OVER INIITAL TERMS
!
        IF(BAUGER.AND.BPRNT0)WRITE(MW6,10540)LUX
!
        if(btime)then
          call nrb_time(timef)
          timea=timea+timef-timei
        endif
!
  800   CONTINUE
!
        IF(BUNPA)THEN           !RE-INDEX FOR PI CONT SUM
          IF(BUNPR)THEN
            DO I=1,NC
              IF(IDY(I).GT.0)THEN
                II=I+LL
                MM=IWRK3(II)
                M=ABS(MM)
                IF(IWRK6(M).GT.0)IWRK3(II)=SIGN(IWRK6(M),MM)
              ENDIF
            ENDDO
          ELSE                  !NO CONT SUM SO CAN NO LONGER DROP TERMS
            DO I=1,NC
              IF(IDY(I).GT.0)THEN
                II=I+LL
                IF(IWRK3(II).LT.0)THEN
                  IWRK3(II)=-IWRK3(II)
                  NSKP=NSKP-1
                ENDIF
              ENDIF
            ENDDO
          ENDIF
        ELSE                            !CAN DROP UNUSED TERMS
          DO M=1,MSUM                   !MSUM=0 IF .NOT.BUNA
            IF(IWRK2(M).EQ.0)THEN
              II=IWRK6(M)
              IWRK3(II)=-IWRK3(II)
              NSKP=NSKP+1
            ENDIF
          ENDDO
        ENDIF
!
  850   IF(BKUTDSK)THEN     !NOW SAFE TO UPDATE NADRU TO DISK RECORD
!
          IF((MODE.NE.2.OR.ICC.LE.0).and..NOT.BKUTLS)THEN
!
            DO N=1,NC
              NADRU(LL+N)=N
            ENDDO
!
          ELSE
!
            DO N=1,NSUB0
!
              NN=LL+NVEC(N)
              NADRU(NN)=N
!
            ENDDO
!
          ENDIF
!
        ENDIF
!
      ENDDO                                                !END SLP LOOP
!
! ******* END LOOP OVER SYMMTERY BLOCKS FOR H DIAGONALIZATION AND AUGERS
!
  900 NC0=NCOR
!
      if(btime)then
!par        if(iam.ge.0)then                                        !par
!par          write(iwp,*)'proc',iam,' for diagon:'                 !par
!par          write(iwp,*)'    H diag time=',nint(timeh),'sec'      !par
!par          if(mode.eq.2)write(iwp,*)                             !par&
!par     &                '    auger time=',nint(timea),'sec'       !par
!par          call flush(iwp)                                       !par
!par        else                                                    !par
        if(btimet)write(iw,*)'H form time=',nint(timefh),'sec'
        write(iw,*)'H diag time=',nint(timeh),'sec'
        if(btimet.and.mode.eq.2)then
          write(iw,*)'auger timea1=',nint(timea1),'sec'
          write(iw,*)'auger timea2=',nint(timea2),'sec'
        endif
        if(mode.eq.2)write(iw,*)'auger time=',nint(timea),'sec'
!par        endif                                                   !par
      endif
!
      IF(IADD.NE.NC0)THEN
        WRITE(MW6,*)'SR.DIAGON GLOBAL INDEX ERROR:',IADD,NC0
        GO TO 2300                                 !RETURN
      ENDIF
!
      lupe=nenerg
      if(idw.eq.0)lupe=min(lupe,lupmx)
!
      DG0=DECORE+DMIN                !GROUND ENERGY (A.U.)
!
      i0=0
      if(ishftls.lt.0.or.ishftls.gt.1)i0=2
      ishftls=abs(ishftls)
!
      IF(i0.ne.0.and.nobs.gt.0)THEN                !DETERMINE TEC
        DO I=1,NENERG
          IF(DELELS(I,2).GE.DZERO.and.iwrk4(i).ne.0)THEN     !.ne.
            T=DELELS(I,2)-DENERG(I)+DMIN
            DENERG(I)=DELELS(I,2)+DMIN
            DELELS(I,1)=T
          ENDIF
        ENDDO
      ENDIF
!
! SORT ENERGIES: IORIG(I) MAPS ENERGY ORDER BACK TO SYMMETRY ORDER
!
      IF(DMAX.GT.DZERO)THEN                       !e.g.LPS
        DO L=1,NENERG
          DENERG(L)=DENERG(L)-DMAX
        ENDDO
      ENDIF
!
!
      CALL HPSRTI(NENERG,DENERG,IORIG)
!
!
      IF(DMAX.GT.DZERO)THEN                       !e.g.LPS
        DO L=1,NENERG
          DENERG(L)=DENERG(L)+DMAX
        ENDDO
      ENDIF
!
! shift whole config based-on lowest level energy
!
      IF(i0.ne.0.and.nobs.lt.0)then             !need to convert from cf
!
        do k=1,kmax
          iharry(k)=1
        enddo
        do l=1,nenerg                           !find lowest term of cf
          i=iorig(l)
          k=nfk(i)
          k=abs(k)
          btest1=iharry(k).gt.0
          btest2=delecf(k,2).ge.dzero
          btest3=iwrk4(i).ne.0
          if(btest1.and.btest2.and.btest3)then
            t=delecf(k,2)-denerg(i)+dmin
            delecf(k,1)=t
            iharry(k)=0                         !flag cf found
          endif
        enddo
!
        do i=1,nenerg
          k=nfk(i)
          k=abs(k)
          t=delecf(k,1)
          if(t.ne.dzero.and.iwrk4(i).ne.0)then
            denerg(i)=denerg(i)+t
            delels(i,2)=denerg(i)-dmin
            delels(i,1)=t
          endif
        enddo
!
        if(dmax.gt.dzero)then                   !unlikely
          do l=1,nenerg
            denerg(l)=denerg(l)-dmax
          enddo
        endif
!
        call hpsrti(nenerg,denerg,iorig)        !re-sort
!
        if(dmax.gt.dzero)then                   !unlikely
          do l=1,nenerg
            denerg(l)=denerg(l)+dmax
          enddo
        endif
!
      endif
!
      DO K=1,KMAX
        IHARRY(K)=ABS(QN(QCG(NF,K)))
      ENDDO
!                                                  !SUMMED AND NO B-B
      IF(BUNA.AND.BUNR.AND.(JRAD.EQ.2.OR.JRAD.EQ.3.OR.JRAD.EQ.5))THEN
        ITESTN=ABS(NRSLMX)
        DO L=1,NENERG
          I=IORIG(L)
          IF(IWRK4(I).NE.0)THEN
            DRY=DENERG(I)+DECORE
            DRY=DRY+DRY
            IF(DRY.LT.EIONMN)THEN                  !BOUND
              K=NFK(I)
              IF(NRSLMX.GE.0)THEN      !N-VALUE
                ITESTH=IHARRY(K)
              ELSE                     !CFG NO.
                ITESTH=K
              ENDIF
              IF(L.GT.LLOWMX.OR.ITESTH.GT.ITESTN)THEN
                                                     !UNRESOLVED
                IF(IWRK3(I).GE.0)THEN
                  NSKP=NSKP+1
                  IWRK3(I)=-1
!                else
!                  write(mw6,*)'correlation, already flagged'
                ENDIF
              ENDIF
            ELSE
              GO TO 1000                           !WE ARE DONE
            ENDIF
!          else
!            write(mw6,*)'iwrk3, already flagged'
          ENDIF
        ENDDO
      ENDIF
!
! PRELIMINARY WRITES
!
 1000 IF(.NOT.BFOTJ)THEN
        IF(BPRNT0)THEN
          WRITE(MW17,10240)MENG,NZION,MION,EIONMN
          WRITE(MW17,10250)(DTWO*DYY(M8),M8=1,MENG)
          IF(BDOWN.and.BUNPR)THEN
            WRITE(MW17,10230)NZION,MION
          ELSE
            WRITE(MW17,10260)NZION,MION
          ENDIF
        ELSE
          WRITE(MW29)int(MENG),int(NZION),int(MION),EIONMN
          WRITE(MW29)(DTWO*DYY(M8),M8=1,MENG)
          WRITE(MW29)int(NZION),int(MION)
          WRITE(MW29)MBLK
        ENDIF
      ENDIF
      IF(MODE.GT.0)THEN
        IF(BPRNT0)THEN
          WRITE(MW7,10130)EIONMN
        ELSE
          WRITE(MW27)int(IZERO),int(IZERO),int(IZERO),int(IZERO),       &
     &               int(IZERO),DZERO,DZERO,EIONMN
        ENDIF
      ENDIF
!
      IF(BPRNT0)WRITE(MW6,10580)DC1,DECORE
      IF(BAUGER.AND.BPRNT0)WRITE(MW6,10550)LUMAX,MXAAI
      if(lumax.ne.ixaai)write(mw0,*)'lumax,ixaai:',lumax,ixaai
      IF(.NOT.BRAD.AND.BJUMP)GO TO 1500
!
      IF(MODE.GT.0)THEN
        IF(BPRNT0)THEN
          WRITE(MW7,10200)NENERG-NSKP,2*DG0
        ELSE
          WRITE(MW27)int(NENERG-NSKP),2*DG0
          WRITE(MW27)MBLK
        ENDIF
      ENDIF
!                                    !FOR TECS
      JTCC=1
      IF(ISHFTLS.EQ.0)JTCC=0
      IF(ISHFTLS.GT.1.OR.IOPTIM.EQ.1)JTCC=2
!
      IF(BINCF)THEN
        IF(INCLUD.GT.KMAX)INCLUD=KMAX         !INCLUD IS CONFIG RESOLVED
      ELSE
        IF(INCLUD.GT.NENERG)INCLUD=NENERG       !INCLUD IS TERM RESOLVED
      ENDIF
!
      BAUX=JPRINT.GE.4.OR.BPRINT
      IF(BAUX.AND.BPRNT0)THEN
        WRITE(MW6,10750)INCLUD,(DADJUS(I),I=1,NPARAM)
        IF(IPOLFN.LT.0)THEN
          NP0=-IPOLFN
          DO N=1,NP0
            N0=N*NPARAM
            WRITE(MW6,10810)N,(DADJUS(N0+I)-DONE,I=1,NPARAM)
                                                           !DADJUS(N0+I)
          ENDDO
        ENDIF
!
        WRITE(MW6,10730)2*DG0
!
        IF(ISHFTLS.NE.0.OR.IOPTIM.EQ.1)THEN
          IF(JTCC.EQ.2)THEN
            IF(IOPTIM.EQ.0)THEN
              MOBS='CORRECTION      OBSERVED'
            ELSE
              MOBS='DIFFERENCE      OBSERVED'
            ENDIF
          ELSE
            MOBS='CORRECTION'
          ENDIF
          WRITE(MW6,10690)MOBS
        ENDIF
      ENDIF
      IF(MODE.EQ.1.AND.IUNIT(MRW14).GT.0)WRITE(MRW14,10620)
!
      IF(IUNIT(MW21).GT.0)WRITE(MW21,10340)      !NENERG need NSPECE now
!
      IF(MENGB.GE.-1)THEN
        ELEM=CELMNT(NZION)
        NZAM=NZA-1
        FIP=ADASIP(ELEM,NZAM)
        if(badas)then
          lab4='    '
        else
          lab4='(0Y)'
        endif
        WRITE(MRW25,10360)ELEM,NZAM,NZION,NZA,FIP,lab4
        ISMX=0
        DO K=1,KMAX                             !CHECK MAX STRING LENGTH
          IS=4*LMX(K)
          ISMX=MAX(ISMX,IS)
        ENDDO
        IF(ISMX.GT.MXSTRG)THEN                   !THIS IS A FORMAT ISSUE
          WRITE(MW6,*)                                                  &
     &             '*** SR.DIAGON: adf04 CONFIGURATION STRING TRUNCATED'
          WRITE(MW0,*)                                                  &
     &              '***SR.DIAGON: adf04 CONFIGURATION STRING TRUNCATED'
        ENDIF                                !NOT A DIMENSION ONE PER SE
        MSTRG4=MXSTRG/4                       !MXSTRG IS A MULTIPLE OF 4
      ENDIF
!
!********************************************
!
! WRITE ENERGY-ORDERED TERM LIST
!
!********************************************
!
      DF=DZERO                             !INITIALIZE FUNCTIONAL ENERGY
      DS=DZERO                             !INITIALIZE FUNCTIONAL WEIGHT
      IF(IOPTIM.NE.0)DS=DONE
      LL=-INCLUD
      TIMXLS=etest-2*DG0                           !RYD REL. TO GROUND
!
      IF(IOPTIM.EQ.1)THEN
        DFC=DZERO
        J=ITMIN
        IF(DELELS(J,2).NE.DZERO)THEN                       !NOT GROUND
          DO J=1,NENERG
            IF(DELELS(J,2).EQ.DZERO)GO TO 1020
          ENDDO
          WRITE(MW6,*)'***SR.DIAGON: GROUND TERM NOT FOUND IN SHFTLS'
          WRITE(MW0,*)'***SR.DIAGON: GROUND TERM NOT FOUND IN SHFTLS'
          GO TO 2300
 1020     WRITE(MW6,*)'***SR.DIAGON: GROUND TERM MIS-MATCH:',J,ITMIN
          WRITE(MW0,*)'***SR.DIAGON: GROUND TERM MIS-MATCH'
          GO TO 2300
        ENDIF
        IF(DG0.GT.EFLG0)DFC=DG0-EFLG0                              !A.U.
      ENDIF
!
! LIST DEGENERATE TERMS BY ASCENDING T INDEX
! (NEEDED FOR BUNDLED PI CONTINUUM SUM WITHIN SYMMETRY GROUP,
!  SINCE RADIATIVE LOOP IS EO NOT SO. ELSE COSMETIC)
!
      IF(BCONT.AND.(BPRNT0.OR.BUNPA))THEN
        J0=1
        m1p=0
        DECMIN=-D1P20
 1050   MSUM=1
        DO J=J0,NENERG
          I=IORIG(J)                                               !A.U.
          IF(NFK(I).lt.0.and.DENERG(I).lt.DECMIN+TOLB2.and.m1p.lt.0)THEN
            MSUM=MSUM+1
            m1p=nfk(i)
          ELSE
            m1p=nfk(i)
            IF(MSUM.GT.1)GO TO 1100
          ENDIF
          DECMIN=DENERG(I)
        ENDDO
        J=NENERG+1
!
 1100   DECMIN=DENERG(I)
        if(bunpa)t=denerg(iorig(j-msum))       !-msum = first; -1 = last
        DO M=MSUM,1,-1
          I=IORIG(J-M)
          DWRK(M)=I
          if(bunpa)denerg(i)=t
        ENDDO
!
        CALL HPSRTI(MSUM,DWRK,IWRK2)
!
        DO M=1,MSUM
          I=IWRK2(M)
          I=NINT(DWRK(I),SP)
          IORIG(J-M)=I
        ENDDO
        IF(J.LT.NENERG)THEN
          J0=J+1
          GO TO 1050
        ENDIF
      ENDIF
!
! BEGIN TERM ENERGY LOOP
!
      IPP=0
      ISP=0
      LSP=0
      IE0=0
      NSPECE=0
      EMIN=EIONPOT
      IF(EMIN.GT.DZERO)THEN
        IAUTO=0
      ELSE
        IAUTO=-1
      ENDIF
      DECMIN=-D1P20
      m1p=0
      NMM=0
      IKOW=0                !NEED TO COUNT SPEC TERMS FOR INCLUD
!
      DO K=1,KMAX
        E1BCF(K)=DZERO      !HOLD STAT.WEIGHTED MEAN ENERGY, I.E. A "CA"
      ENDDO
!
      DO J=1,NENERG
!
        I=IORIG(J)                              !J=EO -> I=SO
        IEORD(I)=J                              !I=SO -> J=EO
!
        IF(NFK(I).GT.0)NMM=NMM+1
        MWJ=ABS(NFK(I))
!
        IF(IWRK3(I).LT.0)THEN
          MWR=-I
        ELSE
          MWR=I
        ENDIF
!
        DAU=DENERG(I)
        DENERG(I)=DENERG(I)-DMIN
        DRY=DENERG(I)*DTWO
!
!        IF(IDIAG.GE.0.AND.ABS(NFK(I)).GT.NCUT              !CORRELATION
        IF(IWRK4(I).LE.0.OR.BECOR.AND.                                  &
     &     (DRY*ECORR.GT.ECORR*ECORR.OR.DRY.GT.ESKPL.AND.DRY.LT.ESKPH)) &
     &     THEN                                             !CORRELATION
          IORIG(J)=-I
          IF(IWRK4(I).EQ.0)THEN
            MBCOR=MSCOR
          ELSE
            MBCOR=MCOR
          ENDIF
        ELSE
          IORIG(J)=I
          MBCOR=MBLK
          if(j.le.lupe)NSPECE=NSPECE+1
          IKOW=IKOW+1
        ENDIF
!
        JJ=NFQ(I)
        ISS=QSI(JJ)+1
        IP2=QPI(JJ)/2
!
        E1BCF(MWJ)=E1BCF(MWJ)+ISS*(QLI(JJ)+1)*DAU           !"CA" ENERGY
!
        DO K=1,J
          IK=NFQ(ABS(IORIG(K)))
          IF(QSI(IK).EQ.QSI(JJ).AND.QLI(IK).EQ.QLI(JJ).AND.QPI(IK)      &
     &       .EQ.QPI(JJ))THEN                   !OVERWRITE IWRK4(I) WITH
            IWRK4(I)=K   !ENERGY ORDER POSN OF FIRST OCCURRENCE OF SYM I
            GO TO 1150
          ENDIF
        ENDDO
!
 1150   DD=DZERO
        DDW=DD
!
! LL=-INCLUD
        IF(LL.EQ.0)GO TO 1250
!
        IF(LL.GT.0)THEN
          IF(BINCF)THEN
            IMATCH=NFK(I)
          ELSE
            IMATCH=I
          ENDIF
          DO K=1,LL
            IF(INDEXW(K).EQ.IMATCH)THEN
              DD=WGHT(K)
              DDW=DD
              GO TO 1200    !WILL INCLUDE CORRELATION IF USER FLAGS SUCH
            ENDIF
          ENDDO
          IF(IOPTIM.EQ.0)GO TO 1250
        ENDIF
!
        IF(BINCF)IKOW=NFK(I)
        IF(IKOW.GT.INCLUD.AND.IOPTIM.EQ.0)GO TO 1250            !IKOW<-J
!
        IF(IORIG(J).LT.0)GO TO 1250     !OMIT CORR. FROM DF FOR INCLUD>0
!
! WEIGHT ENERGY FOR FUNCTIONAL:
!(N.B.IWGHT.LT.0 FORMS THE ARITHMETIC MEAN OF THE CONFIG WEIGHTED MEANS)
!
! STATISTICAL TERM-WEIGHTED MEAN
!
        IF(ABS(IWGHT).EQ.2)THEN
          DD=(QLI(JJ)+1)*ISS
          DDW=DD
          IF(IWGHT.LT.0)DD=DD/MSTAT(MWJ)            !/CF TOT STAT WEIGHT
        ENDIF
!
! EQUAL TERM-WEIGHTED (ARITHMETIC) MEAN
!
        IF(ABS(IWGHT).EQ.1)THEN
          DD=DONE
          DDW=DD
          IF(IWGHT.LT.0)DD=DD/(NTG(MWJ)-NTG(MWJ-1))    !/NO. TERMS IN CF
        ENDIF
!
! ADD TO ENERGY FUNCTIONAL (HERE, ANY AND ALL CORRELATION IS OMITTED)
!
 1200   IF(IOPTIM.EQ.0)THEN                        !STANDARD
          DF=DF+DAU*DD
          DS=DS+DD
        ELSE                                       !DIFF WITH OBS
          IF(IOPTIM.EQ.1)THEN                      !TERMS
            IF(DELELS(I,2).GT.DZERO)THEN
              DF0=(ABS(DELELS(I,2)-DENERG(I))+DFC)/DELELS(I,2)
              DF=DF+DF0*DD
            ELSEIF(DELELS(I,2).EQ.DZERO)THEN
              DDW=DZERO
            ENDIF
          ELSE
            DDW=DZERO
          ENDIF
        ENDIF
!
 1250   DEM=DRY*DKCM
        DWRK(I)=DEM
!       ENR(I)=DRY
!
        IWRK2(I)=0
        MYRGE=MBLK
        IF(NFK(I).LT.0)THEN
          IF(DRY.gt.DECMIN+TOLB.or.m1p.gt.0)IE0=IE0+1    !.or.prev bound
          IF(DRY.LE.TIMXLS)JIMXLS=IE0
          IWRK2(I)=IE0                             !CONT ENERGY INDEX
        ELSEif(m1p.gt.0)then                             !both bound
          IF(DRY.LT.DECMIN+TOLB.and.bmyrge)THEN
            IF(LSP.EQ.QLI(JJ)/2.AND.IPP.EQ.IP2)THEN
              MYRGE='****'
              IF(IUNIT(MRW14).GT.0)BACKSPACE(MRW14)
              ISP=ISP+ISS-1
            ENDIF
          ENDIF
        ENDIF
        IF(MYRGE.EQ.MBLK)ISP=ISS
        IPP=IP2
        LSP=QLI(JJ)/2
        m1p=nfk(i)
        IF(MBCOR.EQ.MBLK)DECMIN=DRY
!
        IF(IAUTO.GE.0.AND.DENERG(I)-EMIN.LE.TOLE)IAUTO=J+1
        IF(NFK(I).LT.0.AND.IAUTO.LT.0)THEN
          IAUTO=J
          EMIN=DENERG(I)
        ENDIF
!
        IF(BCPRNT.AND.IORIG(J).GT.0)THEN        !CHECK SPEC/CORR DISTRIB
          NTCC=NTCC+1                                  !NO OF SPEC TERMS
          IF(J-1.EQ.MTCC)MTCC=J             !HIGHEST SPEC BELOW ALL CORR
        ENDIF
!
        IF(.NOT.BAUX)GO TO 1300
!
        II=(1-QPI(JJ))*ISS
        IF(BUNA.AND.IWRK2(I).GT.JIMXLS)II=0
        W=ISS*(QLI(JJ)+1)-1
        W=W/2
!
        IF(MODE.GT.0.AND.MWR.GT.0)THEN
          IF(BPRNT0)THEN
            if(nfk(i).gt.0)then
              WRITE(MW7,10210)J,IORIG(J),II,LSP,NFK(I),DRY
            else
              WRITE(MW7,10210)J,IORIG(J),II,LSP,NFK(I),DRY,iwrk2(i)
            endif
          ELSE
            WRITE(MW27)int(IORIG(J)),int(IZERO),int(II),int(LSP),       &
     &                 int(IZERO),int(NFK(I)),DRY,int(iwrk2(i))
          ENDIF
        ENDIF
!
        IF(BPRNT0)THEN
          if(nfk(i).gt.0)then
            WRITE(MW6,10710)J,I,DEM,II,LSP,NFK(I),MBCOR,DDW,DRY
          else
            WRITE(MW6,10710)J,I,DEM,II,LSP,NFK(I),MBCOR,DDW,DRY,iwrk2(i)
          endif                                                 !NO CORR
        ENDIF
        IF(MODE.EQ.1.AND.IORIG(J).GT.0.AND.IUNIT(MRW14).GT.0)           &
     &     WRITE(MRW14,10670)ISP,LSP,IPP,NFK(I),NFI(I)-NTG(NFK(I)-1),   &
     &                       DRY,MYRGE
!
        IF(MENGB.GE.-1.and.IORIG(J).GT.0.and.j.le.lupe)THEN     !NO CORR
          LSP=MIN(LSP,MXLAB2)
          ISS=MIN(ISS,MXLAB2)
          K=ABS(NFK(I))
          LMXK=LMX(K)
          IF(LMXK.LE.MSTRG4)THEN
            L1=1
          ELSE                    !TRUNCATE AS TOO LONG FOR ADF04 FORMAT
            L4=LMXK-MSTRG4
            L1=L4+1
          ENDIF
          L2=4*(L1-1)+1           !+2
          IS=0
          DO L=L1,LMXK
            JJK=ABS(QN(QLB(L,K)))
            IF(JJK.GT.999)THEN
              IS=IS+1
              J1000=JJK/1000
              STRING(IS)=NUMB(J1000)
              JJK=JJK-J1000*1000
            ENDIF
            IF(JJK.GT.99)THEN
              IS=IS+1
              J100=JJK/100
              STRING(IS)=NUMB(J100)
              JJK=JJK-J100*100
            ENDIF
            IS=IS+1
            IF(JJK.GT.9)THEN
              J10=JJK/10
              STRING(IS)=NUMB(J10)
              JJK=JJK-J10*10
            ELSE
              STRING(IS)=' '
            ENDIF
            IS=IS+1
            STRING(IS)=NUMB(JJK)
            IS=IS+1
            JJK=MIN(INT(QL(QLB(L,K))/2,SP),MXLAB1)
            STRING(IS)=BIGL(JJK)
            IS=IS+1
            N=MOD(INT(QSB(L,K),SP),I50)
            STRING(IS)=NUMB(N)
          ENDDO
          DO L=IS+1,MXSTRG
            STRING(L)=' '
          ENDDO
          if(badas)then                                      !adf04 only
            if(iunit(MRW25).gt.0)then
              cstan=' '
              ceiss=' '
              if(ismx.le.mstrgh)then
                f542="(i5,1a16,2x,' (',a1,')',a1,'(',f4.1,')',f21.4)"
                write(cstan(1:16),'(16a1)')(string(l),l=1,mstrgh)
                call xxcftr(ione,cstan,ceiss)
                IF(IUNIT(MRW25).GT.0)WRITE(MRW25,f542)nspece,ceiss(1:16)&
     &                                     ,numb(iss),numb(lsp),w,dem
              else
                f543="(i5,1a32,2x,' (',a1,')',a1,'(',f4.1,')',f21.4)"
                write(cstan(1:32),'(32a1)')(string(l),l=l2,mxstrg)
                call xxcftr(ione,cstan,ceiss)
                IF(IUNIT(MRW25).GT.0)WRITE(MRW25,f543)nspece,ceiss(1:32)&
     &                                     ,numb(iss),numb(lsp),w,dem
              endif
            endif
          else                                   !adf04 or adsex.in.form
            IF(ISMX.LE.MSTRGH)THEN
              F542="(I5,16(A1),2X,' (',A1,')',A1,'(',F4.1,')',F21.4)"
              IF(IUNIT(MW21).GT.0)WRITE(MW21,F542)NSPECE,               &
     &                                  (STRING(L),L=1,MSTRGH),NUMB(ISS)&
     &                                  ,NUMB(LSP),W,DEM
              IF(IUNIT(MRW25).GT.0)WRITE(MRW25,F542)NSPECE,             &
     &                                   (STRING(L),L=1,MSTRGH),        &
     &                                   NUMB(ISS),NUMB(LSP),W,DEM
            ELSE
              F543="(I5,32(A1),2X,' (',A1,')',A1,'(',F4.1,')',F21.4)"
              IF(IUNIT(MW21).GT.0)WRITE(MW21,F543)NSPECE,               &
     &                                  (STRING(L),L=L2,MXSTRG),        &
     &                                  NUMB(ISS),NUMB(LSP),W,DEM
              IF(IUNIT(MRW25).GT.0)WRITE(MRW25,F543)NSPECE,             &
     &                                   (STRING(L),L=L2,MXSTRG),       &
     &                                   NUMB(ISS),NUMB(LSP),W,DEM
            ENDIF
          endif
        ENDIF
!
        IF(JTCC.NE.0.AND.BPRNT0)THEN
          IF(IOPTIM.EQ.0.AND.DELELS(I,1).NE.DZERO)THEN
            DD=2*DELELS(I,1)*DKCM
            WRITE(MW6,10700)I,DD,(2*DELELS(I,L),L=1,JTCC)
          ELSEIF(IOPTIM.EQ.1.AND.DELELS(I,2).GE.DZERO)THEN
            T=DELELS(I,2)
            DD=DENERG(I)-T
            IF(J.EQ.1)THEN
              T=EFLG0
              DD=DD+DG0-T
            ENDIF
            DD=-DD*2
            DDD=DD*DKCM
            WRITE(MW6,10700)I,DDD,DD,2*T
          ENDIF
        ENDIF
!
 1300 ENDDO
!
      IF(IAUTO.LE.0)IAUTO=NENERG+1
!
!  *** END ENERGY WRITE LOOP
!
! WRITE SOME TERMINATORS
!
      IF(MODE.EQ.1.AND.IUNIT(MRW14).GT.0)WRITE(MRW14,10670)IZERO,IZERO, &
     &   IZERO,IZERO,IZERO,2*DG0
!
      IF(IUNIT(MW21).GT.0)WRITE(MW21,10350)
!
! FINALIZE "CA" ENERGY
!
      DMAX=-D1P20
      DO K=1,KMAX
        DD=DTWO*E1BCF(K)/MSTAT(K)
        IF(DD.GT.DMAX)DMAX=DD
        E1BCF(K)=DD
      ENDDO
!
! local
      if(allocated(iwrkn))then
        deallocate(iwrkn)
      endif
      allocate(iwrkn(kmax),stat=ierr)
      if(ierr.ne.0)then
        write(mw0,*)'diagon: allocation fails for iwrkn'
        nf=0
        go to 1500
      endif
!
      IF(DMAX.GT.DZERO)THEN                       !e.g.LPS
        DO K=1,KMAX
          E1BCF(K)=E1BCF(K)-DMAX
        ENDDO
      ENDIF
!
      CALL HPSRTI(KMAX,E1BCF,IWRKN)
!
      IF(DMAX.GT.DZERO)THEN                       !e.g.LPS
        DO K=1,KMAX
          E1BCF(K)=E1BCF(K)+DMAX
        ENDDO
      ENDIF
!
      DMIN=E1BCF(IWRKN(1))
!
! TBD WRITE TO ALT FILE,
!     ELSE JUST TO UNIT6 WHEN IWGHT.LT.0 (BUT ANY INCLUD)
!     FORM OR UNFORM, BUT NON-RYD ONLY - THIS COMBO MAY CHANGE.
!
!
      IF(IWGHT0.NE.0)THEN
        MRWXX=MRW14                !APPEND TO TERMS, NOT SAFE FOR SCRIPT
      ELSE
        MRWXX=-1                        !TO UNIT6 ONLY
      ENDIF
!
      IF(MRWXX.GT.0)THEN
        IF(IUNIT(MRWXX).LE.0)MRWXX=-1   !NEED A UNIT
        IF(IWGHT.GE.0)MRWXX=-1          !NEED "CA" FLAG
        IF(MODE.NE.1)MRWXX=-1           !NEED NON-RYD
      ENDIF
      IF(MRWXX.GT.0)WRITE(MRWXX,10630)
!
      BWGHT=IWGHT.LT.0.AND.(BPRNT0.OR.MOD(INCL0,I1000000).EQ.0)
      IF(BWGHT)WRITE(MW6,10740)DMIN+2*DECORE
!
      DO K=1,KMAX
        K0=IWRKN(K)                               !EO -> SO
        M2=QCG(NF,K0)
        KW=K0
        MST=MSTAT(K0)
        IF(IYY(M2).GT.0)THEN
          M1=QL(M2)+1
          KW=-K0
          MST=MSTAT(K0)/(M1+M1)
        ENDIF
        DRY=E1BCF(K0)-DMIN
        DEM=DRY*DKCM
        MBCOR=MBLK
        IF(IDIAG.GE.0.AND.K0.GT.NCUT)THEN
          MBCOR=MCOR
        ELSEIF(MRWXX.GT.0)THEN
          ISP=MSTAT(K0)
          IPP=QCP(K0)/2
          WRITE(MRWXX,10680)ISP,IPP,K0,DRY
        ENDIF
        IF(BWGHT)WRITE(MW6,10720)K,K0,DEM,MST,KW,MBCOR,DRY     !TO UNIT6
      ENDDO
!
      IF(MRWXX.GT.0)WRITE(MRWXX,10680)IZERO,IZERO,IZERO,DMIN+2*DECORE
!
! ALTERNATE FORM OF ENERGY FUNCTIONAL - ORIGINAL SS DIFFERENCE BETWEEN
! CALCULATED AND OBSERVED FS-AV TERM ENERGIES, RELATIVE TO GROUND IN CM,
! AND FLAGGED BY USER INPUT INDEXW .LT. 0, SO DS=0, ASSUMING IOPTIM=0.
!
      IF(DS.EQ.DZERO)THEN
        DS=DONE
        DECORE=DZERO
        DO I=1,LL
          II=-INDEXW(I)
          IF(II.EQ.0)THEN                   !ASSUME INPUT ENERGY ORDERED
            II=IORIG(I)
            INDEXW(I)=-II                            !SET SYMMETRY ORDER
          ENDIF
          DO J=1,I
            JJ=-INDEXW(J)
!            IF(JJ.EQ.0)JJ=IORIG(J)
            DF=(DWRK(II)-DWRK(JJ)-WGHT(I)+WGHT(J))**2+DF
          ENDDO
          IF(BAUX)WRITE(MW6,10010)I,DWRK(II),WGHT(I),DF
        ENDDO
      ENDIF
!
! FINALIZE ENERGY FUNCTIONAL DF
!
      DF=DF/DS
!
! WRITE INFO TO DW PASSING FILE
!
      IF(IDW.NE.0)THEN                                          !DW DUMP
        WRITE(MRW10)NMETA                                        !4ALGX0
        WRITE(MRW10)(NMETAG(I),I=1,NSL0)                         !4ALGX0
        NNN=NENERG                                               !4ALGX0
        IF(BECOR)NNN=-NNN                                        !4ALGX0
        WRITE(MRW10)NNN,KCUT                                     !4ALGX0
        WRITE(MRW10)(IORIG(I),I=1,NENERG)                        !4ALGX0
        WRITE(MRW10)(DENERG(abs(IORIG(I)))*DTWO,I=1,NENERG)      !4ALGX0
        WRITE(MRW10)NCTOT                                        !4DWXLS
        WRITE(MRW10)(TFU(I),I=1,NCTOT)                           !4DWXLS
      ENDIF
!
! GET ANY CF'S PARTITION ABOUT IONIZATION LIMIT (ENERGIES AND WEIGHTS)
!
      IF(NMETAP.GT.0)THEN
        NMM=MIN(NMM,NMETAP)
      ELSE
        NMM=MIN(-NRSLMX,KMAX)
      ENDIF
!
! NEW LOCAL ALLOCATE
!
      IF(NMM.GT.0)THEN
        ALLOCATE(JCP(NMM),JTP(NMM),JWRN(NMM),JWRD(NMM),ERN(NMM),ERD(NMM)&
     &           )
      ENDIF
!
      IF(NMETAP.GT.0)THEN
!
        ALLOCATE(JRP(NENERG))
!
        J=0
        DO J0=1,NENERG
          I=IORIG(J0)
          I=ABS(I)                                    !CASE CORR.
          IF(NFK(I).GT.0)THEN
            J=J+1
            JTP(J)=I
            JCP(J)=NFK(I)
            JJ=NFQ(I)
            JWRN(J)=(QSI(JJ)+1)*(QLI(JJ)+1)
            JWRD(J)=JWRN(J)
            ERN(J)=DENERG(I)+DG0
            ERN(J)=ERN(J)*2
            ERD(J)=ERN(J)
            NLASTP=J0
            IF(J.EQ.NMM)THEN                           !WE ARE DONE
              DO K=J0,NENERG
                JRP(K)=J
              ENDDO
              GO TO 1350
            ENDIF
          ENDIF
          JRP(J0)=J
        ENDDO
 1350   NMM=J                                          !ACTUAL FOUND
      ENDIF
!
      NMM0=NMM
!
      IF(NRSLMX.LT.0)THEN
        DO K=1,NMM
          JTP(K)=0
          JCP(K)=K
          ERN(K)=DZERO
          ERD(K)=DZERO
          JWRN(K)=0
          JWRD(K)=0
        ENDDO
        DO J=1,NENERG
          I=IORIG(J)
          I=ABS(I)                                    !CASE CORR.
          K=NFK(I)
          IF(K*K.LE.NMM*K)THEN                         !OMITS K<0: CONT
            JJ=NFQ(I)
            JW=(QSI(JJ)+1)*(QLI(JJ)+1)
            IF(DENERG(I).LT.EMIN)THEN
              ERN(K)=ERN(K)+DENERG(I)*JW
              JWRN(K)=JWRN(K)+JW
            ELSE
              ERD(K)=ERD(K)+DENERG(I)*JW
              JWRD(K)=JWRD(K)+JW
            ENDIF
          ENDIF
        ENDDO
        DO K=1,NMM
          IF(JWRN(K).GT.0)THEN
            ERN(K)=ERN(K)/JWRN(K)
            ERN(K)=ERN(K)+DG0
            ERN(K)=ERN(K)*2
          ENDIF
          IF(JWRD(K).GT.0)THEN
            ERD(K)=ERD(K)/JWRD(K)
            ERD(K)=ERD(K)+DG0
            ERD(K)=ERD(K)*2
          ENDIF
!          m=jwrn(k)+jwrd(k)
!          if(m.gt.0.and.k.le.ncut)then             !also needs nast=0
!            if(m.ne.mstat(k))then                     !checksum error
!              write(mw6,*)'cf=',k,' s.w. checksum error:',mstat(k),m
!              go to 2000
!            endif
!          endif
        ENDDO
      ENDIF
!
!   PRINT OUT DETAILED INFORMATION ABOUT CI FOR LOWEST ITANAL TERMS
!
      IF(ITANAL.NE.0)THEN
!
        IF(ITANAL.LT.0)WRITE(MW6,10870)ITANAL,ECNTRB
!
        ALLOCATE(NCFBIG(KMAX,2))
        ALLOCATE(NX1(NF),LX1(NF))
!
        NBIGC=0
        NCFBIG(1,1)=0
        DO J=1,NENERG
          L=NFI(J)
          ID(L)=-J
          DVECA(J)=DZERO
        ENDDO
        ITAN=ABS(ITANAL)
        ITAN=MIN(ITAN,NENERG)
        DO II=1,ITAN
          I=IORIG(II)
          IF(I.LT.0)GO TO 1400                    !CASE CORRELATION
          L=NFI(I)
          ID(L)=ABS(ID(L))
          LSG=NFQ(I)
          IJ=(QSI(LSG)+1)*(1-QPI(LSG))
          JJ=QLI(LSG)/2
          IF(ITANAL.GT.0)WRITE(MW6,10890)II,IJ,JJ,DWRK(I)
          K1=NGRPI(LSG)+1                         !=I-NAI(I)+1
          K2=K1+NSL(LSG)-1
!
          DO K=K1,K2
            N1=NADRU(I)+NAI(K)
            DD1=TFU(N1)
            DRY=DWRK(K)-DWRK(I)
            DD=DRY*DD1*DD1
            KK=NFK(K)
            KK=ABS(KK)                           !CASE CONTINUUM
            L=NFI(K)
!  Add this CF to list of those that contribute more than
!  ECNTRB wavenumbers to the energy of this state
            DDA=ABS(DD)
            IF(DDA.GT.ECNTRB)THEN
              ID(L)=ABS(ID(L))
              IF(ITANAL.GT.0)THEN
                DO IJ=1,NBIGC
                  IF(NCFBIG(IJ,1).EQ.KK)GO TO 1360
                ENDDO
                NBIGC=NBIGC+1
                NCFBIG(NBIGC,1)=KK
                NCFBIG(NBIGC,2)=QPI(LSG)
              ENDIF
            ELSE
              DVECA(L)=MAX(DDA,DVECA(L))
            ENDIF
 1360       IF(ITANAL.GT.0)THEN
              DO IJ=1,NF
                NN=QCG(IJ,KK)
                NX1(IJ)=QN(NN)
                LX1(IJ)=QL(NN)/2
              ENDDO
              WRITE(MW6,10880)K,KK,DD1,DRY,DD,(NX1(IJ),LX1(IJ),IJ=1,NF)
            ENDIF
          ENDDO
 1400   ENDDO
!
        IF(NBIGC.GT.0)WRITE(MW6,10850)ECNTRB
        DO K1=1,NBIGC
          KK=NCFBIG(K1,1)
          DO IJ=1,NF
            NN=QCG(IJ,KK)
            NX1(IJ)=QN(NN)
            LX1(IJ)=QL(NN)/2
          ENDDO
          WRITE(MW6,10840)K1,KK,NCFBIG(K1,2),(NX1(IJ),LX1(IJ),IJ=1,NF)
        ENDDO
!
        DO K=1,KMAX
          IF(BANAL(K))GO TO 1450                !WAS RESTRICTED IN ALGEB
          ID0=0
          N1=NTG(K-1)+1
          N2=NTG(K)
          DO I=N1,N2
            IF(ID(I).LT.0)ID0=ID0+1
          ENDDO
          IF(ID0.GT.0)THEN
            DO IJ=1,NF
              NN=QCG(IJ,K)
              NX1(IJ)=QN(NN)
              LX1(IJ)=QL(NN)/2
            ENDDO
            KK=K
            IF(K.GT.NCUT)KK=-KK
            NT1=NTG(K)-NTG(K-1)
            WRITE(MRW31,10320)ID0,NT1,KK,NF,(NX1(IJ),LX1(IJ),IJ=1,NF)
            I0=0
            DO I=N1,N2
              I0=I0+1
              IF(ID(I).LT.0)WRITE(MRW31,10330)I0,-ID(I),DVECA(I)
            ENDDO
          ENDIF
 1450   ENDDO
!
        DEALLOCATE(NCFBIG)
        DEALLOCATE(NX1,LX1)
!
      ENDIF
!
! WRITE LS PROLOGUE TO TCC FILES
!
      IF(BCPRNT.AND.KTCC.LT.0)THEN
!
! TCC.DAT JAJOM FORMAT
!   MTCC SPECTROSCOPIC TERMS LYING BELOW ALL CORRELATION
!
        WRITE(MW1,10290)MTCC,NENERG,KCUT
        DO J=1,MTCC
          I=IORIG(J)
          JJ=NFQ(I)
          WRITE(MW1,10280)J,QSI(JJ)+1,QLI(JJ)/2,QPI(JJ)/2,DENERG(I)*DTWO
        ENDDO
!
      ELSEIF(BCPRNT.AND.KTCC.GT.0)THEN
!
! TCCDW.DAT STGICF FORMAT
!   NTCC SPECTROSCOPIC TERMS WHICH MAYBE INTERSPERSED WITH CORRELATION
!   WRITE FULL TERM LIST AND FLAG CORRELATION FOR STGICF TO ELIMINATE
!   SAID COMPONENTS AND RE-ORTHOINORMALIZE THE TCCS.
!
        N0=NENERG
        IF(NTCC.NE.NENERG)N0=-N0
        LAB4=' C&S'
        IF(BFANO)LAB4='FANO'
        WRITE(MW4,10300)NTCC,N0,LAB4
        DO J=1,NENERG
          I0=IORIG(J)
          I=ABS(I0)
          JJ=NFQ(I)
          J0=J
          IF(I0.LT.0)J0=-J
          WRITE(MW4,10310)J0,QSI(JJ)+1,QLI(JJ)/2,QPI(JJ)/2,DENERG(I)    &
     &                    *DTWO,I
        ENDDO
      ENDIF
!
! DE-ALLOCATE
!
 1500 CONTINUE
!
! ex-common/nrbtmp/
      if(allocated(ncc0))then
        deallocate(ncc0,iorb,isxdi)
      endif
!
! DE-ALLOCATE OLD LOCAL
!
      IF(ALLOCATED(LMX))THEN
        DEALLOCATE(LMX,QSB,QLB,ICF)
      ENDIF
!
      if(allocated(nadlu))then
        deallocate(nadlu)
      endif
      if(allocated(iwrkn))then
        deallocate(iwrkn)
      endif
      if(allocated(ncf))then
        deallocate(ncf,kmap,iwrk1)
      endif
      if(allocated(decorn))then
        deallocate(decorn)
      endif
!
      IF(BALLH)THEN
        DEALLOCATE(DVU,DE,IDY,NVEC,IWRK6,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGON: DE-ALLOCATION FAILS FOR DVU,DE,IDY,NVEC'
          NF=MIN(NF,IZERO)
        ENDIF
        IF(BPRNT0.AND.ALLOCATED(DVP))THEN
          DEALLOCATE(DVP,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'DIAGON: DE-ALLOCATION FAILS FOR DVP'
            NF=MIN(NF,IZERO)
          ENDIF
        ENDIF
        BALLH=.FALSE.
      ENDIF
!
!      IF(ALLOCATED(DU))THEN
!        DEALLOCATE(DU,STAT=IERR)
!        IF(IERR.NE.0)THEN
!          WRITE(MW0,*)
!     &              'DIAGON: DE-ALLOCATION FAILS FOR DU'
!          NF=MIN(NF,IZERO)
!        ENDIF
!      ENDIF
!
      IF(BALLA)THEN
        DEALLOCATE(DUI,DVI,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGON: DE-ALLOCATION FAILS FOR DUI,DVI'
          NF=MIN(NF,IZERO)
        ENDIF
        DEALLOCATE(DDY)
        BALLA=.FALSE.
      ENDIF
!
      IF(NF.LE.0)GO TO 2200                                      !RETURN
!
!
!********************************************
!
!   ***COMPUTE MULTIPOLE RADIATIVE DATA***
!
!********************************************
!NRB: RE-WRITTEN FOR N^3 MULT. AND TO USE THE
! LOOP OVER ALG STORAGE AS ONE OF THESE LOOPS.
!********************************************
!
!
      IF(.NOT.BRAD.AND.BJUMP)GO TO 2200               !NO RE-CALCULATION
!
      NGF=0
      SGF=DZERO
      IF(.NOT.BRADAT)GO TO 2100
!
      IF(NCTOT.GT.ABS(IAXUC))GO TO 2500                   !SHOULD NOT BE
!
      IF(BKUTDSK)THEN              !TFU ONLY HOLDS TWO E-VECTORS, SO
!
        IF(ALLOCATED(TFU))THEN
          DEALLOCATE(TFU,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'DIAGON: DE-ALLOCATION FAILS FOR TFU'
            NF=MIN(NF,IZERO)
          ENDIF
        ENDIF
!
        ALLOCATE(TFU(2*IAXDI),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGON:    ALLOCATION FAILS FOR TFU'
          NF=0
          GO TO 2100
        ENDIF
!
      ENDIF
!
      NPOSX=(IOS-IRK)
      if(nposx.le.0)go to 2100
      BPOS=.TRUE.                                         !FORCE FOR NOW
      BOMRC=.FALSE.
!
      MXORB2=MXORBR*MXORBR                                        !FLAGX
!
      MX=MPOLX
      MX=MX-MPOL0                                                 !FLAGX
      MXPOL=MAX(IONE,MX/2+1)
!
      IF(BPOS)THEN                           !PRE-DECODE ADDRESS
!
        ALLOCATE(NPOS(4,NPOSX),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGON:    ALLOCATION FAILS FOR NPOS'
          NF=0
          GO TO 2200                                !RETURN
        ENDIF
!
        i1=mb+1                                                   !FLAGX
        i2=i1
        NPOS0=IRK
        MCI=0
        DO NC=1,NSL0
          MC=NSL(NC)
          DO ND=1,NC
            N1=NED(1,ND,MCI+1)
            IF(N1.GT.0)THEN
              DO MD1=1,MC
                ND1=MD1+MCI
                N1=NED(1,ND,ND1)
                N2=NED(2,ND,ND1)
                if(irlx.lt.0)then
                  kf=abs(nfk(nd1))
                  i1=icfgp(kf)*mb+1
                endif
                DO M=N1,N2
                  NS=M-NPOS0
                  n8=MXORB2*MXPOL
                  M1=INT(NRK(M)/n8,SP)
                  M2=M1+1
                  NPOS(1,NS)=M2                     !TERM
                  if(irlx.lt.0)then
                    kg=abs(nfk(m2))
                    i2=icfgp(kg)*mb+1
                  endif
                  n8=M1*n8
                  MX=INT((NRK(M)-n8)/MXORB2,SP)
                  MK=MX
                  MK=MK+MPOL0/2                                   !FLAGX
                  NPOS(2,NS)=MK                     !MULTIPOLE
                  n8=n8+MX*MXORB2
                  n8=NRK(M)-n8
                  M0=INT(n8/MXORBR,SP)
                  M1=M0+I1
                  MM=INT(n8-M0*MXORBR+I2,SP)
                  M2=MIN(M1,MM)
                  NPOS(3,NS)=M2                     !ORBITAL
                  M1=M1+MM-M2
                  IF(MM.NE.M1)M1=-M1
                  NPOS(4,NS)=M1                     !ORBITAL
!       write(mw6,*)mxorb2*mxpol,npos(1,ns),mxorb2,mx,mxorbr,m1,i1,mm,i2
                ENDDO
              ENDDO
            ENDIF
          ENDDO
          MCI=MCI+MC
        ENDDO
      ELSE
        NPOS0=0
        WRITE(MW6,10860)NPOSX
        WRITE(MW0,10860)NPOSX
      ENDIF
!
      IF(.NOT.BFOTJ)THEN
!        ALLOCATE(DVECF(MENG,NENERG),STAT=IERR)
        ALLOCATE(DVECF(NENERG,MENG),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGON:    ALLOCATION FAILS FOR DVECF'
          NF=0
          GO TO 2000
        ENDIF
      ENDIF
!
      ALLOCATE(IDY(IAXDI),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DIAGON:    ALLOCATION FAILS FOR IDY'
        NF=0
        GO TO 2000
      ENDIF
! LOCAL
      K0=MAX(IZERO,NMM)
      ALLOCATE(SUMRN(0:K0),SUMRD(0:K0))
!
      IF(BUNPR)THEN
        ALLOCATE(SUMPN(MENG,0:K0),SUMPD(MENG,0:K0))
      ENDIF
!
      BAUX=JPRINT.EQ.1.OR.JPRINT.GT.4      !.NOT.BAUX IGNORE CORRELATION
!
      BDEL=MDEL.GT.0
      IF(IDIAG.LT.0.AND.BDEL)WLG0=DTEN**MDEL
      DEM=2*DG0                               !GROUND ENERGY (RYD)
      IF(EIONMN.EQ.DZERO)EIONMN=etest         !ENABLE B-C SPLIT
      IF(NMETAP.GT.0)etest=dzero              !no rad bundle for upward
!
      IF(BPRNT0.AND.MODE.GT.0)WRITE(MW7,10180)NZION,MION
      IF(.NOT.BPRNT0.AND.MODE.GT.0)WRITE(MW27)int(NZION),int(MION)
!
      STOL=STOLB
      IF(MENGB.NE.1)STOL=100*STOL
      WLGO=100*STOL/DZA2
!
      IF(MENGB.GE.-1)THEN                     !INITIALIZE OMEGA BORN
!
        WRITE(MW6,10650)
        TOLO=D1M10
!
        if(nmeta.gt.0)then
          nmin=min(NMETA,NSPECE)
          ixr=irow(nmin,nspece,ione1,nspece)
          ixc=0
          if(idw.eq.0.and.ABS(MENGB).eq.1)ixc=icol(nmin,nspece,ione1)
          nomwrt=max(ixr,ixc)
        else
          NOMWRT=(NSPECE*(NSPECE+1-2*ione1))/2
        endif
!
        IF(ABS(MENGB).EQ.1)THEN              !INFINITE ENERGY ONLY
!
          BSCRO=.TRUE.       !(REMOVE "ELSE" TO USE INTERNAL - WASTEFUL)
!
          ALLOCATE(OMR(NOMWRT),OMC(NOMWRT),STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'DIAGON: ALLOCATION FAILS FOR OMR,OMC'
            NF=0
            GO TO 2000
          ENDIF
          BOMRC=.TRUE.
          NOMWRX=NOMWRT
!
          IF(NOMWRT.GT.NOMWRX)THEN            !NO LONGER POSSIBLE
            NNN=2*NOMWRT/MENG+1
            WRITE(MW6,10660)NNN
            WRITE(MW0,*)'*** WORKING ARRAYS TOO SMALL IN SR.DIAGON'
            GO TO 2400
          ENDIF
          DO I=1,NOMWRX
            OMR(I)=DZERO
            OMC(I)=DZERO
          ENDDO
!
        ELSE                                  !FINITE ENERGY
!
          BSCRO=.TRUE.      !.T. USE SCRATCH FILE, .F. STORE INTERNALLY
!
          IF(.NOT.BSCRO)THEN
            ALLOCATE(OMEGA(0:MXNXB1,NOMWRT),STAT=IERR)
            IF(IERR.NE.0)THEN
              BSCRO=.TRUE.
            ELSE
              BSCRO=.FALSE.
            ENDIF
          ENDIF
          NOMWRY=NOMWRT
!
!
          IF(BSCRO)THEN
!            WRITE(MW0,*)'DIAGON: USING SCRATCH FOR BORN MULTIPOLE SUM'
!            WRITE(MW6,*)'DIAGON: USING SCRATCH FOR BORN MULTIPOLE SUM'
          ELSE
            DO N=1,NOMWRT
              DO NX=0,MXNXB1
                OMEGA(NX,N)=0
              ENDDO
            ENDDO
          ENDIF
!
          DO NX=1,MXNXB
            XS(NX)=SQRT(DONE-DONE/XB(NX))
          ENDDO
!
        ENDIF
!
        MSC0=80
        MSC=MSC0-1
        IBOMX=0
!        ibifmx=0
!
      ENDIF
!                 INITIALIZE GEOMETRIC COEFFICIENTS
      ALLOCATE(DG(0:IXBLM))
!
      DG(0)=DZERO
      IF(MPOLE.LE.8)THEN
        IP=1
        DO I=2,MPOLE,2
          IP=IP*(I+1)*2
          IM=I/2
          DG(IM)=2*(I+1)*(IM+1)
          DG(IM)=DG(IM)/(IM*REAL(IP,WP)*REAL(IP,WP))
        ENDDO
      ELSE
        TIP=1
        DO I=2,MPOLE,2
          TIP=TIP*(I+1)*2
          IM=I/2
          DG(IM)=2*(I+1)*(IM+1)
          DG(IM)=DG(IM)/(IM*TIP*TIP)
!          write(mw0,*)im,tip,2*(i+1)*(im+1),im*tip*tip,dg(im)
        ENDDO
      ENDIF
!
! for born usage
!
!bu      ixd34=((ixd33+1)*ixd33)/2
!bu      allocate(iflagb(ixd34))
!
      if(btime)call nrb_time(timei)
!
! START MULTIPOLE LOOP OVER RADIATIVE TRANSITIONS
!
      MLAM=MPOL00-2
 1600 MLAM=MLAM+2
      NGROUP=MLAM/2
!
      BBORN=MENGB.GT.1.OR.(MENGB.EQ.1.AND.NGROUP.NE.1)
      BFOTJ=.NOT.BFOT.OR..NOT.BLAG
!      BFOTJ=BFOTJ.OR.NGROUP.NE.1            !UNCOMMENT TO WRITE E1 ONLY
      BFAST=.NOT.BBORN.and..NOT.BPRNT0.and.BELONG.and.includ.eq.0
!      bfast=.false.
!
      IF(BSCRO)THEN                                         !MENGB.GE.-1
        MSC=MSC0+NGROUP
        OPEN(MSC,STATUS='SCRATCH',FORM='UNFORMATTED')
      ENDIF
!
!bu      if(bborn)then       !initialize flag to count Born usage
!bu        do i=1,mb4(0)
!bu          iflagb(i)=-1
!bu        enddo
!bu      endif
!
      IF(NGROUP.EQ.1)THEN
        MP=0
        IF(BPRNT0)THEN
          WRITE(MW6,*)' '
          IF(.NOT.BELONG)WRITE(MW6,10380)
          WRITE(MW6,10370)NGROUP
        ENDIF
        IF(WLG1.LT.DZERO)THEN
          WLG=D1M2
          IF(IDIAG.LT.0.AND.BDEL)WLG=WLG0
        ELSE
          WLG=DZERO
        ENDIF
        WLG=MAX(WLG,WLG1)
        WLGS=DKON
        IF(NPRNT5.GE.0)WLGS=D1M20
      ELSE
        MP=5
        IF(BPRNT0)THEN
          WRITE(MW6,*)' '
          IF(.NOT.BELONG)WRITE(MW6,10530)
          IF(NGROUP.LT.10)THEN
            WRITE(MW6,10510)NGROUP,MP
          ELSE
            WRITE(MW6,10520)NGROUP,MP
          ENDIF
        ENDIF
        IF(WLG2.LT.DZERO)THEN
          WLG=D1M7
        ELSE
          WLG=DZERO
        ENDIF
        WLG=MAX(WLG,WLG2)
        WLGS=DKON
      ENDIF
      ISGNN=1-2*mod(abs(NGROUP),ITWO)                   !(-1)**NGROUP
!
      JOS=0
      KTRAN=0
      JPOLD=-1
      IIMN=1                                          !case jjmn.gt.jjmx
      ILF=ione1
      JJMN=1+ione1
      JJMX=NENERG
      IF(JRAD.GT.0)THEN
        IF(JRAD.EQ.2.OR.JRAD.EQ.3.OR.JRAD.EQ.5)JJMN=MAX(JJMN,IAUTO)
        IF(JRAD.EQ.1)JJMX=MIN(IAUTO-1,NENERG)
      ENDIF
      JJMN=MAX(JJMN,LUPMN)
      JJMX=MIN(JJMX,LUPMX)
!
!***********************************
! START LOOP OVER UPPER ENERGY TERMS
!***********************************
!
      DO JJ=JJMN,JJMX
!
        IF(.NOT.BAUX.AND.IORIG(JJ).LT.0)GO TO 1800          !CORRELATION
        IF(IORIG(JJ).GT.0)THEN
          ILF=ILF+1
        ELSE
          KTRAN=-KTRAN
        ENDIF
        J=ABS(IORIG(JJ))
!
        IF(NFK(J).LT.0)THEN                   !CONT
          IF(.NOT.BFOT)GO TO 1800             !BUT NO PI
          IF(BDOWN.AND.BUNPA.AND.IWRK2(J).GT.JIMXLS)GO TO 1800   !FOR RR
        ENDIF
!
        ND=NFQ(J)                             !INITIAL GROUP
        NCD=NGRPI(ND)                         !=J-NAI(J)
        NADRUU=NADRU(J)                       !SET UPPER
!
        if(btime)call nrb_time(timeir)
!
! flag if mixing coefficient exists
!
        if(mode.ne.2)then                     !b-b only
          if(bkutls)then
            do n=1,nsl(nd)
              i=ncd+n
              if(nfk(i).eq.nfk(j))then
                idy(n)=-1
              else
                idy(n)=0
              endif
            enddo
          else
            do n=1,nsl(nd)
              idy(n)=-1
            enddo
          endif
        elseif(nfk(j).gt.0)then               !j is bound
          do n=1,nsl(nd)
            i=ncd+n
            if(bkutls)then
              btest=nfk(i).eq.nfk(j)          !scf
            else
              btest=nfk(i).gt.0               !b-b
            endif
            if(btest)then
              idy(n)=-1
            else                              !b-c
              idy(n)=0
            endif
          enddo
        else                                  !j is continuum
          if(.not.bkutls)then
            m=-nfk(j)
            m=qcg(nf,m)
            ij=ieq(m)
          endif
          do n=1,nsl(nd)
            i=ncd+n
            if(nfk(i).gt.0)then               !c-b
              idy(n)=0
            else
              if(bkutls)then
                btest=nfk(i).eq.nfk(j)        !c-c
              else
                m=-nfk(i)
                m=qcg(nf,m)
                btest=ieq(m).eq.ij            !c-c
              endif
              if(btest)then
                idy(n)=1
              else                            !c-c'
                idy(n)=0
              endif
            endif
          enddo
        endif
!
        IIMN=1
        IIMX=JJ-ione1
        if(nmeta.gt.0)iimx=min(iimx,nmeta)
        IF(NMETAP.GT.0)IIMX=MIN(IIMX,NLASTP)
        IF(JRAD.GT.0)THEN
          IF(JRAD.EQ.3)IIMN=MAX(IONE,IAUTO)
          IF(JRAD.EQ.1.OR.JRAD.EQ.2.OR.JRAD.EQ.4)IIMX=MIN(IAUTO-1,IIMX)
        ENDIF
        IF(.NOT.BUNA)THEN               !OUTWITH DROPPED, NOT BUNDLED
          IIMN=MAX(IIMN,LLOWMN)
          IIMX=MIN(IIMX,LLOWMX)
        ENDIF
!
! LOAD E-VECTOR
!
        IF(BKUTDSK)THEN                         !GET E-VECTOR LENGTH
!
          if(bkutls)then
            m1=abs(nfk(j))
            m0=iwrkb(2,m1,ND)
!         write(mw6,*)ND,nfk(j),j,NADRUU,m0
          else
            if(nfk(j).gt.0)then                                  !bound
              l1=iwrkg0(nd-1)
              l2=iwrkg0(nd)
              m0=l2-l1
            else               !continuum (already skipped if .not.bfot)
              m1=-nfk(j)
              m2=qcg(nf,m1)
              m2=ieq(m2)
              m0=iwrkg(m2,ND)                     !need kgroup resolved
            endif
          endif
!
          CALL DISKTF(ND,NADRUU,M0,TFU(1),IONE)
!
          NADRUU=0
        ENDIF
!
! INITIALIZE/ZEROIZE
!
        DO I=1,NENERG
          IWRK4(I)=ABS(IWRK4(I))
          DVECL(I)=DZERO
          DVECV(I)=DZERO
          DVECA(I)=DZERO
        ENDDO
!
        IF(.NOT.BFOTJ.AND.NFK(J).LT.0)THEN
          DO I=1,NENERG
            DO M8=1,MENG
!            DVECF(M8,I)=DZERO
              DVECF(I,M8)=DZERO
            ENDDO
          ENDDO
        ENDIF
!
! PRE-DETERMINE (MAXIMAL) BORN USAGE (IXBIF):
!
        IF(BBORN)THEN
!
          IBO=0                            !INITIALIZE
          DO I=1,NENERG
            ID(I)=0
          ENDDO
!
          NCC=0
          DO NC=1,NSL0                     !BEGIN LOOP OVER FINAL GROUPS
!
            IF(QSI(ND).NE.QSI(NC))GO TO 1620
            IF(NMETAG(NC)+NMETAG(ND).GT.1)GO TO 1620
            ML=QPI(ND)+QPI(NC)
            IF(MOD(ML+MLAM,IFOUR).NE.0)GO TO 1620
            ML=QLI(ND)+QLI(NC)
            IF(ML.LT.MLAM)GO TO 1620
            ML=ABS(QLI(ND)-QLI(NC))
            IF(ML.GT.MLAM)GO TO 1620
!
            DO N=1,NSL(NC)
              I=NCC+N
              IF(IWRK4(I).LE.JJ-ione1.AND.IWRK4(I).LE.IIMX.AND.NFK(I)   &
     &           .GT.0)THEN
!     &     .AND.IWRKX(I).GE.IIMN       !IWRKX NOT SET-UP YET
                IWRK4(I)=-ABS(IWRK4(I))   !FLAG EXISTS
              ENDIF
            ENDDO
!
            BEQGRP=ND.EQ.NC
            BING=ND.LE.NC
            IF(BING)THEN
              NU=NC
              NL=ND
              NNN=NCC
            ELSE
              NU=ND
              NL=NC
              NNN=NCD
            ENDIF
!
            IF(NED(1,NL,NNN+1).EQ.0)GO TO 1620
!
            DO N=1,NSL(NU)                 !BEGIN LOOP OVER UPPER
!                                          !SYMMETRY ORDER TERMS
              I0=NNN+N
!
 1605         IF(BING)THEN
                I=I0
                IF(IWRK4(I).GT.0)GO TO 1615
              ELSE
                L=I0
                if(idy(l-ncd).eq.0)go to 1615
!          NI=NADRUU+NAI(L)
!          DD2=TFU(NI)
!          IF(ABS(DD2).LT.CMXLSR)GO TO ibid      !possibly safer to skip
              ENDIF
!
              N1=NED(1,NL,I0)-NPOS0
              N2=NED(2,NL,I0)-NPOS0
!
              DO M=N1,N2
!
                IF(BPOS)THEN
                  M2=NPOS(1,M)
                ELSE
                  n8=MXORB2*MXPOL
                  M1=INT(NRK(M)/n8,SP)
                  M2=M1+1
                ENDIF
!
                IF(BING)THEN
                  L=M2
                  if(idy(l-ncd).eq.0)go to 1610
!          NI=NADRUU+NAI(L)
!          DD2=TFU(NI)
!          IF(ABS(DD2).LT.CMXLSR)GO TO ibid      !possibly safer to skip
                ELSE
                  IF(I0.EQ.M2)GO TO 1610   !AVOID DOUBLE COUNTING
                  I=M2
                  IF(IWRK4(I).GT.0)GO TO 1610
                ENDIF
!
                IF(BPOS)THEN
                  MK=NPOS(2,M)
                  IF(MK.NE.NGROUP)GO TO 1610
                ELSE
                  n8=M1*n8
                  MX=INT((NRK(M)-n8)/MXORB2,SP)
                  MK=MX
                  MK=MK+MPOL0/2                                   !FLAGX
                  IF(MK.NE.NGROUP)GO TO 1610
                ENDIF
!
!OLD        IG=I                           !STORE IN ORIGINAL GROUP POSN
                ig=iwrkg0(nc-1)+nai(i)    !store in e-vector posn as tfu
                if(bkutls)ig=ig+iwrkb(1,nfk(i),nc)
!
                IF(ID(IG).EQ.0)THEN
                  IBO=IBO+1
                  ID(IG)=IBO
                ENDIF
!
 1610         ENDDO
!
 1615         IF(BEQGRP)THEN                     !PICK-UP OTHER HALF
                IF(BING)THEN
                  BING=.FALSE.
                  GO TO 1605
                ELSE
                  BING=.TRUE.
                ENDIF
              ENDIF
!
            ENDDO                                !END LOOP OVER TERMS
!
 1620       NCC=NCC+NSL(NC)
          ENDDO                                  !END LOOP OVER GROUPS
!
          IXBIF=IBO
!
          IF(IXBIF.GT.MXBIF)THEN
            IF(MXBIF.GT.0)WRITE(MW6,10830)IXBIF,MXBIF
          ENDIF
!        write(mw0,*)ixbif
!        ibifmx=max(ibifmx,ixbif)
!
          ALLOCATE(DBL(IXD33,IXBIF),STAT=IERR)  !MXBIF
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'DIAGON: ALLOCATION FAILS FOR DBL'
            NF=0
            GO TO 2000
          ENDIF
!                                                !RE-INITIALIZE
          IBO=0
          DO I=1,NENERG
            ID(I)=0
          ENDDO
!
        ENDIF
!
!*********************************************************************
! PRE-MULTIPLY MULTIPOLE MATRIX FOR ALL FINAL STATES (NC) BY
! INITIAL MIXING MATRIX (ND)
! (ALL, BECAUSE THE FINAL STATES ARE TO BE MIXED SUBSEQUENTLY)
!*********************************************************************
!
        NCC=0
        DO NC=1,NSL0                    !BEGIN LOOP OVER FINAL GROUPS
!
! FOR SPEED PRE-SELECT ACCORDING TO MULTIPLICITY, PARITY, TOTAL L:
!
          IF(QSI(ND).NE.QSI(NC))GO TO 1660
          IF(NMETAG(NC)+NMETAG(ND).GT.1)GO TO 1660
          ML=QPI(ND)+QPI(NC)
          IF(MOD(ML+MLAM,IFOUR).NE.0)GO TO 1660
          ML=QLI(ND)+QLI(NC)
          IF(ML.LT.MLAM)GO TO 1660
          ML=ABS(QLI(ND)-QLI(NC))
          IF(ML.GT.MLAM)GO TO 1660
          DS=1-MOD(ML,IFOUR)
          IF(BFANO)DS=DS*ISGNN
!
          DO N=1,NSL(NC)
            I=NCC+N
            IF(IWRK4(I).LE.JJ-ione1.AND.IWRK4(I).LE.IIMX.AND.NFK(I)     &
     &         .GT.0)THEN
!     &   .AND.IWRKX(I).GE.IIMN       !IWRKX NOT SET-UP YET
              IWRK4(I)=-ABS(IWRK4(I))   !FLAG EXISTS
            ENDIF
          ENDDO
!
          BEQGRP=ND.EQ.NC
          BING=ND.LE.NC
          IF(BING)THEN
            NU=NC
            NL=ND
            NNN=NCC
          ELSE
            NU=ND
            NL=NC
            NNN=NCD
          ENDIF
!
          IF(NED(1,NL,NNN+1).EQ.0)GO TO 1660
!
          DO N=1,NSL(NU)                 !BEGIN LOOP OVER UPPER
!                                        !SYMMETRY ORDER TERMS
            I0=NNN+N
!
 1630       IF(BING)THEN
              I=I0
              IF(IWRK4(I).GT.0)GO TO 1650
            ELSE
              L=I0
              if(idy(l-ncd).eq.0)go to 1650
              NI=NADRUU+NAI(L)
              DD2=TFU(NI)
              IF(ABS(DD2).LT.CMXLSR)GO TO 1650
            ENDIF
!
            N1=NED(1,NL,I0)-NPOS0
            N2=NED(2,NL,I0)-NPOS0
!
            DO M=N1,N2
!
              IF(BPOS)THEN
                M2=NPOS(1,M)
              ELSE
                n8=MXORB2*MXPOL
                M1=INT(NRK(M)/n8,SP)
                M2=M1+1
              ENDIF
!
              IF(BING)THEN
                L=M2
                if(idy(l-ncd).eq.0)go to 1640
                NI=NADRUU+NAI(L)
                DD2=TFU(NI)
                IF(ABS(DD2).LT.CMXLSR)GO TO 1640
              ELSE
                IF(I0.EQ.M2)GO TO 1640
                               !AVOID DOUBLE COUNTING
                I=M2
                IF(IWRK4(I).GT.0)GO TO 1640
              ENDIF
!
              IF(BPOS)THEN
                MK=NPOS(2,M)
                IF(MK.NE.NGROUP)GO TO 1640
                M2=NPOS(3,M)
                MM=NPOS(4,M)
                M1=ABS(MM)
              ELSE
                n8=M1*n8
                MX=INT((NRK(M)-n8)/MXORB2,SP)
                MK=MX
                MK=MK+MPOL0/2                                     !FLAGX
                IF(MK.NE.NGROUP)GO TO 1640
                n8=n8+MX*MXORB2
                n8=NRK(M)-n8
                I1=1
                I1=I1+MB                                          !FLAGX
                M0=INT(n8/MXORBR,SP)
                M1=M0+I1
                MM=INT(n8-M0*MXORBR+I1,SP)
                M2=MIN(M1,MM)
                M1=M1+MM-M2
              ENDIF
!
              IN=ICOL(M2,M1,IZERO)
              INV=IXD28+IN
!
              DB=DZERO
              IF(NGROUP.GT.0)DB=DOSC(IN,NGROUP/2)
!
              DRY=DD2*DRK(M+NPOS0)
              BINT=I.LE.L                 !DOWN TRUE
              IF(.NOT.BINT)DRY=DRY*DS     !UP->DOWN
!
!OLD      IG=I                             !STORE IN ORIGINAL GROUP POSN
              ig=iwrkg0(nc-1)+nai(i)      !store in e-vector posn as tfu
              if(bkutls)ig=ig+iwrkb(1,nfk(i),nc)
!
              DVECL(IG)=DVECL(IG)+DB*DRY  !LENGTH
!
              IF(BREL.AND.NFK(J).GT.0.AND.irtard.GT.0)THEN
                                                   !RETARD ALREADY ON PI
                DDD=DENERG(I)-DENERG(L)
                DDD=4*DDD*DDD*DRY
                DVECL(IG)=DVECL(IG)-DALF4*DDD*DOSC(IN,NGROUP/2+1)       &
     &                    /(4*NGROUP+6)
              ENDIF
!
              IF(.NOT.BFOTJ.AND.NFK(J).LT.0)THEN
                                          !PHOTO
                M7=NFOSS(ngroup/2,M1,M2)
                IF(M7.GT.0)THEN
                  ISYGN=1
                  IF(MM.NE.M1)ISYGN=-ISYGN
                  IF(.NOT.BINT)ISYGN=-ISYGN
                  IF(ISYGN.LT.0)THEN
                    DO M8=1,MENG
                      DB=DRY              !LENGTH/ACCELERATION
                      IF(IGAG(M8).EQ.0)DB=-DB
                                          !VELOCITY
!              DVECF(M8,IG)=DVECF(M8,IG)+DFOSS(M7,M8,1)*DB
                      DVECF(IG,M8)=DVECF(IG,M8)+DFOSS(M7,M8,1)*DB
                    ENDDO
                  ELSE
                    DO M8=1,MENG
!              DVECF(M8,IG)=DVECF(M8,IG)+DFOSS(M7,M8,1)*DRY
                      DVECF(IG,M8)=DVECF(IG,M8)+DFOSS(M7,M8,1)*DRY
                    ENDDO
                  ENDIF
                ENDIF
!
              ENDIF
!
              IF(BFAST)GO TO 1640
!
              IF(BVEL)THEN
                DB=DZERO
                IF(NGROUP.GT.0)DB=DOSC(INV,NGROUP/2)
                IF(MM.NE.M1)DB=-DB
                                  !CHANGE OF ORBITAL TO TERM ORDER (VEL)
                IF(.NOT.BINT)DB=-DB
                DVECV(IG)=DVECV(IG)+DB*DRY                     !VELOCITY
              ENDIF
!
              IF(BACC)DVECA(IG)=DVECA(IG)+DRY*ACC(IN)      !ACCELERATION
!
              IF(BBORN)THEN
                                                           !BORN
                IF(ID(IG).EQ.0)THEN
                  IBO=IBO+1
                  IF(IBO.LE.IXBIF)THEN
                    ID(IG)=IBO
                    DO IX=1,MB3(0)
                      DBL(IX,IBO)=DZERO
                    ENDDO
                  ELSE
                    ID(IG)=-IBO
                  ENDIF
                ENDIF
                IF(ID(IG).GT.0)THEN
                  IB=ID(IG)
                  IF(BINDB(IN,NGROUP/2))THEN
                    IX=INDX(IN)
                    DBL(IX,IB)=DBL(IX,IB)+DRY
                  ELSE
                    II=IEORD(I)
                    LL=IEORD(L)
                    WRITE(MW0,*)'DIAGON: BORN M1 M2 NOT FOUND'
                    WRITE(MW6,*)'DIAGON: BORN M1 M2 NOT FOUND:'
                    WRITE(MW6,*)JJ,LL,II,J,L,I,M,NGROUP,M2,M1
                    GO TO 2400
                  ENDIF
                ENDIF
!
              ENDIF
!
 1640       ENDDO
!
 1650       IF(BEQGRP)THEN                     !PICK-UP OTHER HALF
              IF(BING)THEN
                BING=.FALSE.
                GO TO 1630
              ELSE
                BING=.TRUE.
              ENDIF
            ENDIF
!
          ENDDO                                !END LOOP OVER TERMS
!
 1660     NCC=NCC+NSL(NC)
        ENDDO                                  !END LOOP OVER GROUPS
!
        IF(BBORN)THEN
          IBOMX=MAX(IBOMX,IBO)
          IF(IBO.GT.IXBIF)THEN                 !SHOULDN'T HAPPEN
            WRITE(MW6,*)'SR.DIAGON: DIMENSION ERROR, INCREASE MXBIF TO '&
     &                  ,IBO
            WRITE(MW0,*)'SR.DIAGON: DIMENSION ERROR, INCREASE MXBIF'
            GO TO 2400
          ENDIF
        ENDIF
!
        if(btime)then
          call nrb_time(timefr)
          timer1=timer1+timefr-timeir
          timeir=timefr
        endif
!
!***********************************
! START LOOP OVER LOWER ENERGY TERMS
!***********************************
!
        SUMRN(0)=DZERO
        SUMRD(0)=DZERO
        IF(NMM.GT.0)THEN
          NMM=NMM0
          IF(NMETAP.GT.0)NMM=MIN(NMM,JRP(IIMX))
          DO K=1,NMM
            SUMRN(K)=DZERO
            SUMRD(K)=DZERO
          ENDDO
        ENDIF
!
        IF(BUNPR.AND.NFK(J).LT.0)THEN
          I3P=ABS(IWRK3(J))
          IF(I3P.NE.JPOLD)THEN                 !NEW UPPER PI STATE
            DO M8=1,MENG
              SUMPN(M8,0)=DZERO
              SUMPD(M8,0)=DZERO
            ENDDO
            DO K=1,NMM
              DO M8=1,MENG
                SUMPN(M8,K)=DZERO
                SUMPD(M8,K)=DZERO
              ENDDO
            ENDDO
            IF(BUNA)JPOLD=I3P                  !SUM OVER NMETA CONT
          ENDIF
        ENDIF
!
        ILI=0
        DO II=IIMN,IIMX
!
          IF(.NOT.BAUX.AND.IORIG(II).LT.0)GO TO 1750
          IF(IORIG(II).GT.0)THEN
            ILI=ILI+1
            IF(KTRAN.GE.0)KTRAN=KTRAN+1
          ENDIF
          I=ABS(IORIG(II))
          IF(IWRK4(I).GT.0)GO TO 1750
          IF(ABS(MENGB).EQ.1.AND.MOD(NGROUP,ITWO).EQ.1)THEN
            IX=IROW(ILI,ILF,ione1,NSPECE)
            IF(OMR(IX).LT.-TOLO)GO TO 1750
                                         !DIPOLE ALREADY COMPUTED
          ENDIF
!      if(dvecl(i).eq.dzero)write(131,*)nfk(j),jj,j,' - ',nfk(i),ii,i
!
          IF(IDIAG.GE.0.AND.BDEL)THEN
            MRD=0
            I5=0
            M3=NFK(J)
            M3=ABS(M3)
            M4=NFK(I)
            DO I3=1,MXORB
              I4=NEL(I3,M3)-NEL(I3,M4)
              IF(I4.NE.0)THEN
                I5=I5+1
                MRDP=MRD
                MRD=ABS(QN(I3))
                ISGN=1-2*mod(abs(I5),ITWO)         !(-1)**I5
                IF(ISGN.GT.0.AND.ABS(MRD-MRDP).GE.MDEL)GO TO 1670
              ENDIF
            ENDDO
            GO TO 1750
 1670       CONTINUE
          ENDIF
!
! START LOOP (K1,K2) OVER LOWER ENERGY TERM MIXING
!
          DLEN=DZERO
          DVEL=DZERO
          DACC=DZERO
          IF(.NOT.BFOTJ.AND.NFK(J).LT.0)THEN     !PHOTO
            DO M8=1,MENG
              DFOT(M8)=DZERO
            ENDDO
          ENDIF
!
          NC=NFQ(I)
          ML=QLI(ND)-QLI(NC)
!
! e-vector storage posn
!
          if(bkutls)then                  !could do better...?
            k1=iwrkg0(nc-1)+iwrkb(1,nfk(i),nc)
            k2=k1+iwrkb(2,nfk(i),nc)
          else
            k1=iwrkg0(nc-1)
            k2=iwrkg0(nc)
          endif
          M0=K2-K1
!
          N1=NADRU(I)                            !START OF MIXING VECTOR
!
          IF(BKUTDSK)THEN
!
            CALL DISKTF(NC,N1,M0,TFU(IAXDI+1),IONE)
!
            N1=IAXDI
          ENDIF
!
          IF(BFAST)THEN
            IF(BFOTJ.OR.NFK(J).GT.0)THEN
          IF(LAPAK.GT.0)THEN                                     !LAPACK
            DLEN=DDOT(M0,TFU(N1+1),IONE,DVECL(K1+1),IONE)        !LAPACK
          ELSE                                                   !LAPACK
              DO M=1,M0
                DLEN=DLEN+TFU(N1+M)*DVECL(K1+M)
              ENDDO
          ENDIF                                                  !LAPACK
            ELSE
          IF(LAPAK.GT.0)THEN                                     !LAPACK
            DLEN=DDOT(M0,TFU(N1+1),IONE,DVECL(K1+1),IONE)        !LAPACK
            DO M8=1,MENG                                         !LAPACK
              DFOT(M8)=                                                 &!LAPACK
     &           DDOT(M0,TFU(N1+1),IONE,DVECF(K1+1,M8),IONE)     !LAPACK
            ENDDO                                                !LAPACK
          ELSE                                                   !LAPACK
              DO M=1,M0
                DLEN=DLEN+TFU(N1+M)*DVECL(K1+M)
              ENDDO
              DO M8=1,MENG
                DO M=1,M0
                  DFOT(M8)=DFOT(M8)+TFU(N1+M)*DVECF(K1+M,M8)
                ENDDO
              ENDDO
          ENDIF                                                  !LAPACK
            ENDIF
          ELSE
            IF(BBORN)THEN              !BORN
              DO K=1,MB3(0)
                SBL(K)=DZERO
              ENDDO
            ENDIF
            K1=K1+1
            DO K=K1,K2
              N1=N1+1                            !=NADRU(I)+NAI(K)
              DD1=TFU(N1)
              IF(ABS(DD1).LT.CMXLSR)GO TO 1680
              DLEN=DLEN+DD1*DVECL(K)
              DVEL=DVEL+DD1*DVECV(K)
              DACC=DACC+DD1*DVECA(K)
              IF(BBORN)THEN            !BORN
                IBO=ID(K)
                IF(IBO.GT.0)THEN
                  DO M=1,MB3(0)
                    SBL(M)=SBL(M)+DD1*DBL(M,IBO)
                  ENDDO
                ENDIF
              ENDIF
              IF(.NOT.BFOTJ.AND.NFK(J).LT.0)THEN
                DO M8=1,MENG
!              DFOT(M8)=DFOT(M8)+DD1*DVECF(M8,K)
                  DFOT(M8)=DFOT(M8)+DD1*DVECF(K,M8)
                ENDDO
              ENDIF
 1680       ENDDO
          ENDIF
!                                      END LOOP OVER LOWER ENERGY MIXING
!
!      if(dlen.eq.dzero)write(132,*)nfk(j),jj,j,' - ',nfk(i),ii,i
          OBOX=DZERO
          IF(MENGB.EQ.-1.AND.ABS(DLEN).GT.WLGO)OBOX=D1P30
          IF(NGROUP.EQ.0)DLEN=DZERO
          IF(NGROUP.GT.0.AND.DLEN.EQ.DZERO)GO TO 1750
!
! EXCLUDE TRANSITIONS INVOLVING ZERO-WEIGHT TERMS FROM FUNCTIONAL G
!
          MBCOR=MBLK
          IF(LL.GT.0)THEN          !-INCLUDE
            IF(BINCF)THEN
              IMATCHI=NFK(I)
              IMATCHJ=NFK(J)
            ELSE
              IMATCHI=I
              IMATCHJ=J
            ENDIF
            NN=-1
            DO K=1,LL
              IF(INDEXW(K).EQ.IMATCHI.OR.INDEXW(K).EQ.IMATCHJ)THEN
                NN=NN+1
                IF(NN.GT.0)GO TO 1700
              ENDIF
            ENDDO
            MBCOR=MOUT
          ENDIF
 1700     IF(IORIG(II).LT.0.OR.IORIG(JJ).LT.0)MBCOR=MCOR
!
! BORN MULTIPOLES
!
          IF(BBORN)THEN !BORN
            DO IE=1,MENGB
              OBO(IE)=DZERO
            ENDDO
            OMG1=DZERO
            DLAM=2*NGROUP+1
            NH=NGROUP/2
            DO N=1,MB4(0)
              L=INDL(N)
              K=INDK(N)
              SSB=SBL(K)*SBL(L)
              IF(ABS(SSB).GT.STOL)THEN
                DO IE=1,MENGB
                  DB=SSB*BL(IE,N,NH)
!bu              if(db.ne.dzero)iflagb(n)=abs(iflagb(n))!flag born usage
                  OBO(IE)=OBO(IE)+DB+DB
                  IF(L.EQ.K)OBO(IE)=OBO(IE)-DB
                ENDDO
                IF(NGROUP.EQ.1)THEN
                  DB=SSB*TM2(N)
                  OMG1=OMG1+DB+DB
                  IF(L.EQ.K)OMG1=OMG1-DB
                ENDIF
              ENDIF
            ENDDO
            DB=DEIGHT*DLAM*(QSI(ND)+1)
            DO IE=1,MENGB
              OBO(IE)=DB*OBO(IE)
            ENDDO
            OBOX=OBO(MINFB)
            OMG1=DB*OMG1
          ENDIF
!
! ELECTRIC MULTIPOLE
!
          JOS=JOS+1
          DRY=DENERG(J)-DENERG(I)
          IF(DRY.EQ.DZERO)then
            if(mengb.lt.-1)GO TO 1750                !CASE E2 DEGENERATE
            dry=d1m10
          endif
!
          IF(NFK(J).LT.0)DRY=DRY+DYY(NREL)
          GFA=DACC/(DRY*DRY)                     !GF_A
!      gfa=dacc                                  !if orb ener. used
          DRY=DRY+DRY
          MI=II
          MJ=JJ
!     IF(NFK(I).LT.0)MI=-MI
          IF(NFK(J).LT.0)MJ=-MJ
          MWJ=(QSI(ND)+1)*(QLI(ND)+1)
          MWI=(QSI(NC)+1)*(QLI(NC)+1)
          WLG=ABS(WLG)
          IF(NFK(J).LT.0)WLG=-WLG
!
          DB=DG(NGROUP)*(DRY*DFSC)**(MLAM-1)/DFSC
          if(db.eq.dzero)then                    !avoids overflow*zero
            dlen=dzero
            dvel=dzero
            gfa=dzero
          endif
          SEK=ABS(DLEN)*DLEN*(QSI(ND)+1)         !SEK_L
          GFL=DB*SEK                             !GF_L
          IF(NFK(J).GT.0)AEK=C1*GFL*DRY*DRY/MWJ  !AEK
          IF(NFK(J).LT.0)AEK=C2*GFL/MWI          !PI
!
!                Lt. for PI underflow at low-E (but not at high-E)
          IF(AEK*AEK.LT.ABS(AEK)*WLG.AND.OBOX.LT.WLGO.AND.              &
     &       GFL*GFL.LT.WLGS)GO TO 1750
!                so zero will be written if not caught be selection rule
!
          BINT=(BAUX.OR.MBCOR.NE.MCOR).AND.BPRNT0
!      ISGNL=1-2*mod(abs(ML/2),2)               !(-1)**(ML/2)
!      ISGN=ISGNL                                !SWITCH DOWN TO UP ON F
!      IF(BFANO)ISGN=ISGN*ISGNN
          ISGN=1                                 !ALL DOWN
          DB=ISGN*DB*(QSI(ND)+1)*DTEN**MP
          DVEL=DVEL/DRY                          !skip if orb ener. used
          GFV=DB*DVEL*ABS(DVEL)                  !GF_V
          GFLV=DB*DVEL*DLEN                      !SQRT(GF_L*GF_V)
          GFA=DB*GFA*ABS(GFA)                    !GF_A
          WLEN=D1P8/(DRY*DKCM)                   !WAVELENGTH(A)
          GFL=ISGN*GFL*DTEN**MP                  !GF_L STILL
          IF(.NOT.BELONG.AND.ABS(AEK).GT.WLG)THEN
                                                 !USE VEL AEK,SEK
            AEK=GFV*AEK/GFL
            SEK=GFV*SEK/GFL
          ENDIF
          FAB=GFL/MWI                            !F(UP)_L
          FEM=GFL/MWJ                            !F(DOWN)_L
!
          IF(NGROUP.EQ.1)THEN
            APOL=DFOUR*ABS(FAB)/(DRY*DRY)        !POLARIZABILITY (a_0^3)
            IF(.NOT.BELONG)APOL=APOL*ABS(GFV/GFL)
            OMG=DFOUR*GFL/DRY                    !MP=0, NGROUP=1
            IF(ABS(MENGB).EQ.1)THEN
              OMGINF=-ABS(OMG)
              OMG=OMG*LOG(EINF*DZ2)
              OMG=-ABS(OMG)                      !TAG DIPOLE NEGATIVE
              IF(OMG.GE.-TOLO)OMG=DZERO      !ZERO VANISHINGLY SMALL CPT
            ELSEIF(MENGB.GT.1)THEN
              OMG=-ABS(OMG)                      !4S/3
              if(nmeta.eq.0)nmeta=iimx           !pwb
            ENDIF
            if(idw.eq.0)then
              if(nmeta.eq.0)nmeta=nenerg         !for RM
            else
              if(nmeta.eq.0)nmeta=iimx
            endif
          ELSE
            APOL=OBOX                            !COPY BORN IN
            OMG=OBOX
            IF(OMG.LT.DZERO)OMG=D1M30            !keep non-negative
            OMGINF=OMG
          ENDIF
!
! DETERMINE BORN OMEGAS
!
          BPRNTO=.FALSE.
          IF(MPOL00.EQ.0.AND.MBCOR.EQ.MBLK)THEN
                                              !MPOL0 CATCHES E1
            IF(ABS(MENGB).EQ.1)THEN          !INFINITE ENERGY BORN ONLY
              BPRNTO=.TRUE.
              IXC=ICOL(ILI,ILF,ione1)
              IF(IXC.LE.NOMWRX)OMC(IXC)=OMC(IXC)+OMG
              IXR=IROW(ILI,ILF,ione1,NSPECE)
              IF(IXR.LE.NOMWRX)OMR(IXR)=OMR(IXR)+OMG
              OMEGAB(MXNXB1)=OMGINF
            ELSEIF(MENGB.GT.1.AND.abs(OBO(MINFB)).GT.WLGO)THEN
                                                            !FINITE BORN
              BPRNTO=.TRUE.
              CALL BRNINT(BPRNT0,NLAGB,MXNXB,MV0,MV1,DRY,V0,V1,XB,XS,   &
     &                    DB0,DB1,OMG1,OBO,OMEGAB)
              OMEGAB(MXNXB1)=OMG                   !INFINITE ENERGY
!          if(nlagb.lt.0)go to 3000                !brnint failure
            ENDIF
          ENDIF
!
! OUTPUT ELECTRIC MULTIPOLE DATA.
!
          IF(BINT)WRITE(MW6,10100)JOS,MBCOR,MJ,MI,AEK,SEK,GFL,FAB,FEM,  &
     &                            WLEN,GFV,GFLV,GFA,APOL
!
          IF(BPRNTO)THEN
            T=ABS(AEK)
            IF(BSCRO)THEN
              WRITE(MSC)MJ,MI,T,(OMEGAB(K),K=1,MXNXB1)
            ELSE
              OMEGA(0,KTRAN)=OMEGA(0,KTRAN)+REAL(T,RP)
              T=REAL(OMEGA(MXNXB1,KTRAN),WP)
              KMX=MXNXB1
              IF(MOD(NGROUP,ITWO).EQ.1.AND.T.LT.-TOLO)KMX=MXNXB
                                                             !OLD DIPOLE
              DO K=1,KMX
                OMEGA(K,KTRAN)=OMEGA(K,KTRAN)+REAL(OMEGAB(K),RP)
              ENDDO
            ENDIF
          ENDIF
!
          IF(MODE.LT.1)GO TO 1740
          DB=DENERG(I)+DENERG(I)+DEM
          IF(NFK(I)*NFK(J).LT.0)GO TO 1720
!
          IF(II.LE.LLOWMX.AND.DB.LE.etest.AND.IHARRY(NFK(I)).LE.NRSLMX) &
     &       THEN                                              !RESOLVED
            IF(BPRNT0)WRITE(MW7,10110)NFK(J),J,MWJ,NFK(I),I,MWI,AEK,DRY,&
     &                                DB
            IF(.NOT.BPRNT0)WRITE(MW27)int(NFK(J)),int(J),int(MWJ),      &
     &                                int(NFK(I)),int(I),int(MWI),AEK,  &
     &                                DRY,DB
          ELSEIF(BUNR)THEN                                      !BUNDLED
            T=ABS(AEK)
            IF(BDOWN)THEN                       !USED BY ADASDR & ADASPE
              M=0
              IF(NFK(I).LE.-NRSLMX)M=NFK(I)
            ELSE                                !NOT USED BY PP'S....
              T=T*MWJ
              T=T/MWI
              M=II
            ENDIF
            IF(DB.LT.EIONMN)THEN
              SUMRN(M)=SUMRN(M)+T
            ELSE
              SUMRD(M)=SUMRD(M)+T
            ENDIF
          ENDIF
          GO TO 1740
!
 1720     IF(BFOTJ)GO TO 1750
          IF(DFOT(MENG).EQ.DZERO)GO TO 1750
!
! N.B. SIGN OF REDUCED MATRIX ELEMENT IS STILL FOR DOWNWARD TRANSITION.
! TO GET SIGN FOR UPWARD TRANSITION, UNCOMMENT NEXT DO-LOOP.
!      DO  M8=1,MENG
!        DFOT(M8)=DFOT(M8)*ISGN
!      ENDDO
!
          DC0=C2*DG(NGROUP)/(REAL(QLI(NC)+1,WP)*DFSC)
          T=DENERG(J)-DENERG(I)
          DO M8=1,MENG
            DRY=T+DYY(M8)
            DRY=DRY+DRY
            T1=DRY*DFSC
            TT=T1**NGROUP
            TT=TT*DFOT(M8)
            DFOT(M8)=DC0*TT*ABS(TT)/T1
            IF(BPRNT0.AND.ABS(DFOT(M8)).LT.D1M99)DFOT(M8)=DZERO
          ENDDO
!
! AEK IS GIVEN BY RADIATIVE IGAUGE, DFOT IS GIVEN BY PI GAUGE.
!
          IF(II.LE.LLOWMX.AND.DB.LE.etest.AND.IWRK2(J).LE.JIMXLS.AND.   &
     &       IHARRY(NFK(I)).LE.-NMM)THEN                       !RESOLVED
            DRY=DENERG(J)+DENERG(J)+DEM
            IF(BPRNT0)THEN
              WRITE(MW17,10110)NFK(I),I,MWI,NFK(J),J,IWRK2(J),AEK,DB,DRY
              WRITE(MW17,10250)(DFOT(M8),M8=1,MENG)
            ELSE
              WRITE(MW29)int(NFK(I)),int(I),int(MWI),int(NFK(J)),int(J),&
     &                   int(IWRK2(J)),AEK,DB,DRY
              WRITE(MW29)(DFOT(M8),M8=1,MENG)
            ENDIF
          ELSEIF(BUNPR)THEN                                     !BUNDLED
            DO M8=1,MENG
              DFOT(M8)=ABS(DFOT(M8))
            ENDDO
            IF(BDOWN)THEN                          !AS RESOLVED PI IS UP
              M=0
              IF(NFK(I).LE.-NRSLMX)M=NFK(I)
              TW=MWI
              TWW=DALF4*TW/MWJ
              DO M8=1,MENG
                DRY=T+DYY(M8)
                DRY=DRY+DRY
                DFOT(M8)=DFOT(M8)*DRY*DRY*TWW
              ENDDO
            ELSE                                !AS ONLY CONT IS BUNDLED
              M=JRP(II)
            ENDIF
            IF(DB.LT.EIONMN)THEN
              DO M8=1,MENG
                SUMPN(M8,M)=SUMPN(M8,M)+DFOT(M8)
              ENDDO
            ELSE
              DO M8=1,MENG
                SUMPD(M8,M)=SUMPD(M8,M)+DFOT(M8)
              ENDDO
            ENDIF
          ENDIF
          GO TO 1750
!
! IN ELECTRIC DIPOLE CASE ADD CONTRIBUTION TO FUNCTIONAL G
!
 1740     IF(NGROUP.EQ.1.AND.INCLUD.NE.0.AND.MBCOR.EQ.MBLK)THEN
            NGF=NGF+1
            GFL=ABS(GFL)
            GFV=ABS(GFV)
            GFLV=ABS(GFLV)
            SGF=(GFL+GFV-2*GFLV)/(GFL+GFV+2*GFLV)+SGF
          ENDIF
!
!
 1750   ENDDO                                !END LOOP OVER LOWER TERMS
!
        IF(ALLOCATED(DBL))DEALLOCATE(DBL,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGON: DE-ALLOCATION FAILS FOR DBL'
          NF=0
          GO TO 2000
        ENDIF
!
        if(btime)then
          call nrb_time(timefr)
          timer2=timer2+timefr-timeir
        endif
!
!                                                           !UNRESOLVED
        WLG=ABS(WLG)
        IF(SUMRN(0).GT.WLG)THEN
          IF(BPRNT0)WRITE(MW7,10110)NFK(J),J,MWJ,IZERO,IZERO,IZERO,     &
     &                              SUMRN(0),DZERO,DEM
          IF(.NOT.BPRNT0)WRITE(MW27)int(NFK(J)),int(J),int(MWJ),        &
     &                              int(IZERO),int(IZERO),int(IZERO),   &
     &                              SUMRN(0),DZERO,DEM
        ENDIF
        IF(SUMRD(0).GT.WLG)THEN
          IF(BPRNT0)WRITE(MW7,10110)NFK(J),J,MWJ,IZERO,IZERO,IZERO,     &
     &                              SUMRD(0),DZERO,DZERO
          IF(.NOT.BPRNT0)WRITE(MW27)int(NFK(J)),int(J),int(MWJ),        &
     &                              int(IZERO),int(IZERO),int(IZERO),   &
     &                              SUMRD(0),DZERO,DZERO
        ENDIF
!                                                               !BUNDLED
        DO M=1,NMM
          IF(SUMRN(M).GT.WLG)THEN
            IF(BPRNT0)WRITE(MW7,10110)NFK(J),J,MWJ,JCP(M),JTP(M),JWRN(M)&
     &                                ,SUMRN(M),DZERO,ERN(M)
            IF(.NOT.BPRNT0)WRITE(MW27)int(NFK(J)),int(J),int(MWJ),      &
     &                                int(JCP(M)),int(JTP(M)),          &
     &                                int(JWRN(M)),SUMRN(M),DZERO,ERN(M)
          ENDIF
          IF(SUMRD(M).GT.WLG)THEN
            IF(BPRNT0)WRITE(MW7,10110)NFK(J),J,MWJ,JCP(M),JTP(M),JWRD(M)&
     &                                ,SUMRD(M),DZERO,ERD(M)
            IF(.NOT.BPRNT0)WRITE(MW27)int(NFK(J)),int(J),int(MWJ),      &
     &                                int(JCP(M)),int(JTP(M)),          &
     &                                int(JWRD(M)),SUMRD(M),DZERO,ERD(M)
          ENDIF
        ENDDO
!
        IF(.NOT.BUNPR.OR.NFK(J).GT.0)GO TO 1800
!
        IF(JPOLD.LE.0)THEN
          JP=J
        ELSE
          IF(JJ.LT.JJMX)THEN
            JP=ABS(IORIG(JJ+1))
            JPNEW=ABS(IWRK3(JP))
            IF(IWRK2(J).GT.JIMXLS)JPOLD=JPNEW
          ELSE
            JPNEW=-1
            IF(IWRK2(J).GT.JIMXLS)THEN
              JPOLD=NENERG+1
              NFK(JPOLD)=0                     !we now allocate nenerg+1
              IWRK2(JPOLD)=0
              DENERG(JPOLD)=DZERO
              DEM=DZERO
            ENDIF
          ENDIF
          IF(JPNEW.EQ.JPOLD)GO TO 1800         !SUM OVER CONT DEGENERACY
          JP=JPOLD
        ENDIF
!
        DRY=DENERG(JP)+DENERG(JP)+DEM
!                                                            !UNRESOLVED
        IF(SUMPN(1,0).GT.DZERO)THEN
          IF(BPRNT0)THEN
            WRITE(MW17,10110)IZERO,IZERO,IZERO,NFK(JP),JP,IWRK2(JP),    &
     &                       DZERO,DEM,DRY
            WRITE(MW17,10250)(SUMPN(M8,0),M8=1,MENG)
          ELSE
            WRITE(MW29)int(IZERO),int(IZERO),int(IZERO),int(NFK(JP)),   &
     &                 int(JP),int(IWRK2(JP)),DZERO,DEM,DRY
            WRITE(MW29)(SUMPN(M8,0),M8=1,MENG)
          ENDIF
        ENDIF
        IF(SUMPD(1,0).GT.DZERO)THEN
          IF(BPRNT0)THEN
            WRITE(MW17,10110)IZERO,IZERO,IZERO,NFK(JP),JP,IWRK2(JP),    &
     &                       DZERO,DZERO,DRY
            WRITE(MW17,10250)(SUMPD(M8,0),M8=1,MENG)
          ELSE
            WRITE(MW29)int(IZERO),int(IZERO),int(IZERO),int(NFK(JP)),   &
     &                 int(JP),int(IWRK2(JP)),DZERO,DZERO,DRY
            WRITE(MW29)(SUMPD(M8,0),M8=1,MENG)
          ENDIF
        ENDIF
!                                                               !BUNDLED
        DO M=1,NMM
          IF(SUMPN(1,M).GT.DZERO)THEN
            IF(BPRNT0)THEN
              WRITE(MW17,10110)JCP(M),JTP(M),JWRN(M),NFK(JP),JP,        &
     &                         IWRK2(JP),DZERO,ERN(M),DRY
              WRITE(MW17,10250)(SUMPN(M8,M),M8=1,MENG)
            ELSE
              WRITE(MW29)int(JCP(M)),int(JTP(M)),int(JWRN(M)),          &
     &                   int(NFK(JP)),int(JP),int(IWRK2(JP)),DZERO,     &
     &                   ERN(M),DRY
              WRITE(MW29)(SUMPN(M8,M),M8=1,MENG)
            ENDIF
          ENDIF
          IF(SUMPD(1,M).GT.DZERO)THEN
            IF(BPRNT0)THEN
              WRITE(MW17,10110)JCP(M),JTP(M),JWRD(M),NFK(JP),JP,        &
     &                         IWRK2(JP),DZERO,ERD(M),DRY
              WRITE(MW17,10250)(SUMPD(M8,M),M8=1,MENG)
            ELSE
              WRITE(MW29)int(JCP(M)),int(JTP(M)),int(JWRD(M)),          &
     &                   int(NFK(JP)),int(JP),int(IWRK2(JP)),DZERO,     &
     &                   ERD(M),DRY
              WRITE(MW29)(SUMPD(M8,M),M8=1,MENG)
            ENDIF
          ENDIF
        ENDDO
!
!
 1800 ENDDO                                   !END LOOP OVER UPPER TERMS
!
!
! determine usage of Born integrals
! note: practically all are used for normal targets.
! e.g. of where usage is low is large pseudostate expansions,
! especially ls coupling. Also, perhaps, use of relaxed orbitals;
! but the bindb variable helps greatly.
!
!bu      if(bborn)then                                       !born usage
!bu        nh=ngroup/2
!bu        icount=0
!bu        icountb=0
!bu        write(778,*)'kpole=',ngroup
!bu        write(779,*)'kpole=',ngroup
!bu        do i=1,mb4(0)
!bu          if(bl(1,i,nh).ne.dzero)then
!bu            nc=indl(i)
!bu            nd=indk(i)
!bu            j=mb4(nc)
!bu            k=mb3(nc)
!bu            if(mod(ngroup,2).eq.mod((ql(j)+ql(k))/2,2))then
!bu              icount=icount+1
!bu              if(iflagb(i).gt.0)then   !used
!bu                icountb=icountb+1
!bu                if(bprnt0)
!bu     x             write(778,*)nc,mb3(nc),mb4(nc),nd,mb3(nd),mb4(nd)
!bu              else                     !not used
!bu                if(bprnt0)
!bu     x             write(779,*)nc,mb3(nc),mb4(nc),nd,mb3(nd),mb4(nd)
!bu              endif
!bu              if(bprnt0)write(777,6999)i,indl(i),iflagb(i),icountb
!bu 6999         format(i7,i5,i3,i6)
!bu            endif
!bu          endif
!bu        enddo
!bu        p=icountb
!bu        if(icount.gt.0)p=100*p/icount
!bu        npp=nint(p,sp)
!bu        write(mw0,777)ngroup,icount,icountb,npp
!bu        write(mw6,777)ngroup,icount,icountb,npp
!bu  777   format(/'LAM=',I2,3X,'BORN INTEGRALS: CALC=',I7,'  USED='
!bu     X         ,I7,I5,'%'/)
!bu      endif
!
! END MULTIPOLE LOOP OVER RADIATIVE TRANSITIONS
!
      IF(MLAM.LT.MPOLE)GO TO 1600
!
      DEALLOCATE(DG)
!
      if(btime)then
        call nrb_time(timef)
        times=timef-timei
!par        if(iam.ge.0)then                                        !par
!par          write(iwp,*)'proc',iam,' for diagon:'                 !par
!par          write(iwp,*)'    radiative time=',nint(times),'sec'   !par
!par          call flush(iwp)                                       !par
!par        else                                                    !par
        write(iw,*)'radiative timer1=',nint(timer1),'sec'
        write(iw,*)'radiative timer2=',nint(timer2),'sec'
        write(iw,*)'radiative time=',nint(times),'sec'
!par        endif                                                   !par
      endif
!
! WRITE AN ADF04 (AND, MAYBE, INFINITE ENERGY OMEGA) FILE
!
      IF(MENGB.GE.-1)THEN                   !BBORN
!
        if(btime)timei=timef
!
! WRITE DATA TO OMGINF FILE
!
        WRITE(MW6,*)' '
        WRITE(MW6,*)'IBOMX=',IBOMX
!        write(mw0,*)ibifmx,ibomx
!
        CALL DIMUSE('MXBIF',IBOMX)
!
        do j=lupe,1,-1                               !nenerg
          if(iorig(j).gt.0)go to 1850
        enddo
        j=lupe                                       !shouldn't get here
 1850   lupe=j
!
        IF(ABS(MENGB).EQ.1)THEN            !INF ENG BORN, ROW *AND* COL
!
          IF(MENGB.EQ.-1)THEN
            DO I=1,NOMWRT
              OMR(I)=MIN(OMR(I),D1P30)
              OMC(I)=MIN(OMC(I),D1P30)
            ENDDO
          ENDIF
!
          K=0
          DO J=1,lupe                       !NENERG
            I=IORIG(J)
            IF(I.GT.0)THEN
              K=K+1
              N=NFQ(I)
              IWRK3(K)=(1-QPI(N))*(QSI(N)+1)
              IWRK4(K)=QLI(N)/2
              DWRK(K)=DENERG(I)*DTWO/DZ2
            ENDIF
          ENDDO
!
          IF(K.NE.NSPECE)THEN
            WRITE(MW6,*)'DIAGON: ENERGY MISMATCH',K,NSPECE     !,lupe
            WRITE(MW0,*)'DIAGON: ENERGY MISMATCH'
            GO TO 2400
          ENDIF
!
          if(nmeta.eq.0)nmeta=nspece                         !case no E1
          if(nmeta.lt.nspece)then
            ixr=irow(nmeta,nspece,ione1,nspece)
            if(ixr.lt.nomwrt)nomwrt=ixr
            ixc=icol(nmeta,nspece,ione1)
          else
            ixc=nomwrt
          endif
          if(nmeta0.eq.0)nmeta=-nmeta
!
          F713='(1PE14.8,6E11.3/(14X,6E11.3))'    !SUPPRESS IFORT REMARK
!
          WRITE(MRW23,*)NZION,MION
          WRITE(MRW23,*)NSPECE,ABS(MENGB),NOMWRT
          WRITE(MRW23,*)(IWRK3(I),IWRK4(I),I=1,NSPECE)
          WRITE(MRW23,10410)(DWRK(I),I=1,NSPECE)
          WRITE(MRW23,F713)EINF,(OMR(I),I=1,NOMWRT)
!
          IF(IDW.EQ.0)THEN                           !COLUMNWISE AS WELL
            NOMWRT=(NSPECE*(NSPECE+1-2*ione1))/2
            if(ixc.lt.nomwrt)nomwrt=ixc
!
            WRITE(MRW23,*)NZION,MION
            WRITE(MRW23,*)NSPECE,ABS(MENGB),-NOMWRT
            WRITE(MRW23,*)(IWRK3(I),IWRK4(I),I=1,NSPECE)
            WRITE(MRW23,10410)(DWRK(I),I=1,NSPECE)
            WRITE(MRW23,F713)EINF,(OMC(I),I=1,NOMWRT)
          ENDIF
!
        ENDIF                                 !SUM BORN MULTIPOLES
!
! WRITE DATA TO ADF04 FILE
!
        BEXP=.FALSE.                          !TRUE=1.0E+0, FALSE=1.0+0
        IF(NSPECE.LT.1000)THEN
          i1=0
          IF(BEXP)THEN
            F761='(F5.2,4X,"1", 8X,20(1PE10.2))'
            F762='(2I4,22(1PE10.2))'
          ELSE
            F761='(F5.2,4X,"1", 6X, 20(A5, A3))'
            F762='(2I4, 22(A5, A3))'
          ENDIF
        ELSE
          i1=1
          IF(BEXP)THEN
            F761='(F5.2,4X,"1",10X,20(1PE10.2))'
            F762='(2I5,22(1PE10.2))'
          ELSE
            F761='(F5.2,4X,"1", 8X, 20(A5, A3))'
            F762='(2I5, 22(A5, A3))'
          ENDIF
        ENDIF
!
        if(ieq(0).ne.0)then
!
          WRITE(MRW25,F542)-1             !OLD TERMINATOR
!
        else
!                                      !now write orbital energy in s.o.
          cardx=' '
          cardx(4:5)='-1'
          orbfmt='(1x,f7.?)'
!
! truncate to spectroscopic orbitals
          if(bort)then
            isob=0
            inx=0
            do i=1,mxorb
              if(dey(i).ne.dzero)then
                if(dadjus(i).lt.dzero)go to 1860
                isob=i
                in=abs(qn(i))
                inx=max(inx,in)
              endif
            enddo
          else
            isob=mxorb
            inx=abs(qn(isob))
          endif
! re-map
 1860     isox=0
          inx=(inx*(inx+1))/2
!
 1880     allocate(isorb(0:inx))
!
          do i=1,inx
            isorb(i)=0
          enddo
          do i=1,isob
            in=abs(qn(i))
            il=ql(i)/2
            iso=(in*(in-1))/2+il+1
            if(iso.le.inx)isorb(iso)=i
            isox=max(isox,iso)
          enddo
!
          if(isox.gt.inx)then
            deallocate(isorb)
!         write(mw6,*)'***sr.diagon: isorb buffer too short, need ',isox
            inx=isox
            go to 1880
          endif
!
          is=9+2*i1
          ie=is+abs(isox)*8
          IF(ie.GT.mxlenx)THEN
                            !note, >200(=7d) not passed by dwxls,adasexj
!            write(mw6,*)'***sr.diagon: cardx too short, need mxlenx=',i
            isox=-(mxlenx-is)/8
          endif
          if(isox.lt.0)then
!            write(mw6,*)'***adf04ls note: truncated orbital energy list
!!            write(mw0,*)'***adf04ls note: truncated orbital energy lis
            isox=-isox
          endif
! print
          do ix=1,isox
            ie=is+7
            i=isorb(ix)
            t=dzero
            if(i.gt.0)then              !break into two for bounds check
              if(dey(i).ne.dzero)then
                in=icol(i,i,izero)
                t=dey(i)-duy(in)
                if(bmvdr.and.bmvd)t=t+dmass(in)+dcd(in)
                t=-2*t
              endif
            endif
            imt=max(itwo,ifive-max(izero,int(log10(max(t,d1m30)),sp)))
            write(orbfmt(8:8),'(i1)')imt
            write(cardx(is:ie),orbfmt)t
            is=ie+1
          enddo
!
          orbfmt=' '
          orbfmt(1:7)='(a    )'
          write(orbfmt(3:6),'(i4)')ie
          write(MRW25,orbfmt)cardx(1:ie)
!
          deallocate(isorb)
!
        endif
!
        IF(BEXP)THEN
          WRITE(MRW25,F761)REAL(NZA),(XB(K),K=1,MXNXB)
        ELSE
          MSCP=MSC+1
          OPEN(MSCP,STATUS='SCRATCH',FORM='FORMATTED')
          WRITE(MSCP,10460)(XB(K),K=1,MXNXB)
          BACKSPACE(MSCP)
          READ(MSCP,10470)(XMANT(K),IEXP(K),K=1,MXNXB)
          WRITE(MRW25,F761)REAL(NZA),(XMANT(K),IEXP(K),K=1,MXNXB)
        ENDIF
!
        DO M=MSC0,MSC                     !RE-POINT BORN MULTIPOLE FILES
          REWIND(M)
        ENDDO
!
        IOLD=JJMN               !1+ione1
        JOLD=IIMN               !1
!
        if(nenerg.eq.ione1)go to 1950
!
        if(iorig(iold).lt.0.or.iorig(jold).lt.0)then
          write(mw6,*)'Lowest two terms cannot be correlation!'
          write(mw0,*)'Lowest two terms cannot be correlation!'
          go to 2400
        endif
        INEW=IOLD
        JNEW=JOLD
        KTRAN=0
!
 1900   IF(BSCRO)THEN
!
          BBORN=.FALSE.
          DO K=0,MXNXB1
            OMEGAB(K)=DZERO
          ENDDO
!
          IP=IORIG(IOLD)
          IP=NFQ(IP)
          IP=QPI(IP)
          JP=IORIG(JOLD)
          JP=NFQ(JP)
          JP=QPI(JP)
          IF(IP.NE.JP)THEN
            MMN=MSC0+1                     !ODD MULTIPOLES
            MMX=MSC+MOD(MSC,ITWO)-1
          ELSE
            MMN=MSC0
            MMX=MSC-MOD(MSC,ITWO)
          ENDIF
!
          IFLAGO=999
          DO M=MMN,MMX,2
            READ(M,END=1920,ERR=1920)I,J,(XS(K),K=0,MXNXB1)
            IF(I.GT.IOLD.OR.J.GT.JOLD)THEN
              BACKSPACE(M)
              GO TO 1920
            ELSE
              if(jold.gt.iimx)then
                if(nmeta0.eq.0)then
                  go to 1920         !unfortunate interchange of i,j use
                else
                  stop '370'
                endif
              endif
              BBORN=.TRUE.
              KMX=MXNXB1
              IF(IP.NE.JP)THEN
                LAM=MOD(M,I80)
                IF(LAM.EQ.1.AND.ABS(XS(MXNXB1)).GT.TOLO)IFLAGO=1 !E1 LIM
                IF(LAM.GT.IFLAGO)KMX=MXNXB    !DON'T OVEFRWRITE E1 LIMIT
              ENDIF
              DO K=0,KMX
                OMEGAB(K)=OMEGAB(K)+XS(K)
              ENDDO
            ENDIF
 1920     ENDDO
!
        ELSE
          KTRAN=KTRAN+1
          DO K=0,MXNXB1
            OMEGAB(K)=REAL(OMEGA(K,KTRAN),WP)
          ENDDO
        ENDIF
!
        IF(BBORN)THEN
          DO K=0,MXNXB
            OMEGAB(K)=ABS(OMEGAB(K))
            IF(OMEGAB(K).LT.D1M99)OMEGAB(K)=DZERO
          ENDDO
          IF(OMEGAB(0).LT.D1M30)OMEGAB(0)=D1M30
          IF(OMEGAB(MXNXB1).GT.D1P30)OMEGAB(MXNXB1)=D1P30
          IF(BEXP)THEN
            WRITE(MRW25,F762)INEW,JNEW,(OMEGAB(K),K=0,MXNXB1)
          ELSE
            BACKSPACE(MSCP)
            WRITE(MSCP,10460)(OMEGAB(K),K=0,MXNXB1)
            BACKSPACE(MSCP)
            READ(MSCP,10470)(XMANT(K),IEXP(K),K=0,MXNXB1)
            WRITE(MRW25,F762)INEW,JNEW,(XMANT(K),IEXP(K),K=0,MXNXB1)
          ENDIF
        ENDIF
!
 1950   JOLD=JOLD+1
        IF(JOLD.GT.IOLD-ione1.or.JOLD.GT.IIMX.and.nmeta0.ne.0)THEN
 1960     IOLD=IOLD+1
          IF(IOLD.GT.lupe)THEN                 !NENERG        !TERMINATE
            WRITE(MRW25,F762)-1
            WRITE(MRW25,F762)-1,-1
            if(.not.badas)then                      !adas skip comments
              WRITE(MRW25,10420)
              NREC=1
 1965         NREC=NREC+1
              BACKSPACE(MR5)
              BACKSPACE(MR5)
              READ(MR5,10480)CARD4
              IF(CARD4.NE.'A.S.'.AND.CARD4.NE.'S.S.')GO TO 1965
              REWIND(MR5)
              DO N=1,NREC
                READ(MR5,10440)CARD
                WRITE(MRW25,10430)CARD
              ENDDO
              DATE='        '
              CALL DATE_AND_TIME(DATE)
              WRITE(MRW25,10450)DATE(7:7),DATE(8:8),DATE(5:5),DATE(6:6),&
     &                          DATE(3:3),DATE(4:4)
            endif
            DO M=MSC0,MSC
              CLOSE(M)
            ENDDO
            IF(.NOT.BEXP)CLOSE(MSCP)
          ELSE
            IF(IORIG(IOLD).LT.0)GO TO 1960
            JOLD=IIMN          !1
            JNEW=IIMN          !1
            INEW=INEW+1
            GO TO 1900
          ENDIF
        ELSE
          IF(IORIG(JOLD).LT.0)GO TO 1950
          JNEW=JNEW+1
          GO TO 1900
        ENDIF
!
        if(btime)then
          call nrb_time(timef)
          timew=timef-timei
!par          if(iam.ge.0)then                                      !par
!par            write(iwp,*)'proc',iam,' for diagon:'               !par
!par            write(iwp,*)'    radiative time=',nint(times),'sec' !par
!par            call flush(iwp)                                     !par
!par          else                                                  !par
          write(iw,*)'adf04/omginf time=',nint(timew),'sec'
!par          endif                                                 !par
        endif
!
      ENDIF                               !END ADF04/OMGINF WRITES
!
! DE-ALLOCATE
!
 2000 CONTINUE
!
      IF(BOMRC)THEN
        DEALLOCATE(OMR,OMC,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGON: DE-ALLOCATION FAILS FOR OMR,OMC'
          NF=MIN(NF,IZERO)
        ENDIF
        BOMRC=.FALSE.
      ENDIF
!
      IF(ALLOCATED(IDY))THEN
        DEALLOCATE(IDY,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGON: DE-ALLOCATION FAILS FOR IDY'
          NF=MIN(NF,IZERO)
        ENDIF
      ENDIF
!
      IF(ALLOCATED(OMEGA))THEN
        DEALLOCATE(OMEGA,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGON: DE-ALLOCATION FAILS FOR OMEGA'
          NF=MIN(NF,IZERO)
        ENDIF
      ENDIF
!
      IF(.NOT.BFOTJ.AND.ALLOCATED(DVECF))THEN
        DEALLOCATE(DVECF,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGON: DE-ALLOCATION FAILS FOR DVECF'
          NF=MIN(NF,IZERO)
        ENDIF
      ENDIF
!
      IF(BPOS)THEN
        DEALLOCATE(NPOS,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DIAGON: DE-ALLOCATION FAILS FOR NPOS'
          NF=MIN(NF,IZERO)
        ENDIF
        BPOS=.FALSE.
      ENDIF
!
      IF(NF.LE.0)GO TO 2200                                      !RETURN
!
! UPDATE FUNCTIONAL (RE-ENTRY POINT IF NO RADIATION)
!
      IF(NGF.NE.0)SGF=DTWO*SGF/NGF
 2100 DRY=DF
      IF(IOPTIM.EQ.0)DRY=DRY+DECORE
      DRY=DRY*DTWO
      IF(BPRNT0)THEN
        WRITE(MW6,10770)INCLUD,DRY,SGF,NGF,JPRINT
        IF(DRY.NE.DZERO.AND.IWGHT.LT.0)WRITE(MW6,10780)
      ENDIF
      IF(JPRINT.EQ.-2)THEN
        DF=SGF
        if(includ.ne.0)WRITE(MW6,10760)
        DECORE=DZERO
      ENDIF
!
 2200 CONTINUE
!
! LOCAL DEALLOCATE
!
      IF(ALLOCATED(IHARRY))THEN
        DEALLOCATE(IHARRY,E1BCF,SUMA)
      ENDIF
      IF(ALLOCATED(DENERG))THEN
        DEALLOCATE(DENERG,IWRK2,ID,IORIG,DVECL,DVECV,DVECA)
      ENDIF
      IF(ALLOCATED(DWRK))THEN
        DEALLOCATE(DWRK,IWRK3,IWRK4)
      ENDIF
      IF(ALLOCATED(JCP))THEN
        DEALLOCATE(JCP,JTP,JWRN,JWRD,ERN,ERD)
      ENDIF
      IF(ALLOCATED(JRP))DEALLOCATE(JRP)
      IF(ALLOCATED(SUMRN))THEN
        DEALLOCATE(SUMRN,SUMRD)
      ENDIF
      IF(ALLOCATED(SUMPN))THEN
        DEALLOCATE(SUMPN,SUMPD)
      ENDIF
      if(allocated(iwrkb))then
        deallocate(iwrkb)
      endif
      if(allocated(iwrkg0))then
        deallocate(iwrkg0)
      endif
      IF(ALLOCATED(ITMP))DEALLOCATE(ITMP)
      IF(ALLOCATED(DPA))DEALLOCATE(DPA)   !,DP
!
! WRITE TERMINATORS
!
      IF(MODE.GT.0)THEN
        IF(BPRNT0)WRITE(MW7,10220)MBLK
        IF(.NOT.BPRNT0)WRITE(MW27)int(IZERO),int(IZERO),int(IZERO),     &
     &                            int(IZERO),int(IZERO),int(IZERO),     &
     &                            DZERO,DZERO,DZERO
      ENDIF
      IF(.NOT.BFOTJ)THEN
        IF(BPRNT0)WRITE(MW17,10220)MBLK
        IF(.NOT.BPRNT0)WRITE(MW29)int(IZERO),int(IZERO),int(IZERO),     &
     &                            int(IZERO),int(IZERO),int(IZERO),     &
     &                            DZERO,DZERO,DZERO
      ENDIF
!
! CLOSE SOME FILES
!
      IF(NJO.LE.0)THEN
        IF(IUNIT(MW1).GT.0)THEN
          CLOSE(MW1)
          IUNIT(MW1)=-1
        ENDIF
        IF(IUNIT(MW4).GT.0)THEN
          CLOSE(MW4)
          IUNIT(MW4)=-1
        ENDIF
      ENDIF
      IF(IUNIT(MW21).GT.1)THEN
        CLOSE(MW21)
        IUNIT(MW21)=-1
      ENDIF
      IF(IUNIT(MRW23).GT.1)THEN               !so par scratch not closed
        CLOSE(MRW23)
        IUNIT(MRW23)=-1
      ENDIF
      IF(IUNIT(MRW25).GT.1)THEN
        CLOSE(MRW25)
        IUNIT(MRW25)=-1
      ENDIF
!
      IF(BKUTDSK)THEN
        DO KGROUP=1,NSL0
          CALL DISKTF(KGROUP,IVEC,ILEN,TFU,IZERO)
        ENDDO
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
 2300 IF(NF.GT.0)NF=-1
      GO TO 1500                                            !DE-ALLOCATE
!
 2400 IF(NF.GT.0)NF=-1
      GO TO 2000                                            !DE-ALLOCATE
!
! DIMENSION EXCEEDED, ABORT
!
 2500 WRITE(MW6,10640)NCTOT,ABS(IAXUC)
      WRITE(MW0,*)'SR.DIAGON: MAXUC DIMENSION EXCEEDED'
      GO TO 2300
!
!-----------------------------------------------------------------------
!
10010 FORMAT(I6,' CALC ',F10.1,'     OBS ',F10.1,'   SQ-DIF.SUM',E16.5)
10020 FORMAT(88X,'R OF 3 LAST P(R):',3F9.3)
10030 FORMAT(I4,3I3,F14.5,F14.6,I3,2I4,10F8.4)
10040 FORMAT((52X,10F8.4))
10050 FORMAT(//' GAM ( N,  L,NION, Z,SIG/D/P)  EPSILON/RY      <1/R>  ',&
     &  '<Z/R-V>      <R>   <R**2>   <R**3>   (ADJUST, REND, 3 LAST P) '&
     &  ,'IN',I8,' STEPS')
10060 FORMAT(//' GAM ( N,  L,NION, Z,Q.D/D/P)  EPSILON/RY      <1/R>  ',&
     &  '<Z/R-V>      <R>   <R**2>   <R**3>   (ADJUST, REND, 3 LAST P) '&
     &  ,'IN',I8,' STEPS')
10070 FORMAT(5I4,F9.5,F13.5,1X,3F9.5,2F9.4,2X,F8.4,F6.2,1X,3(1PE9.2))
10080 FORMAT(22X,'2MXLBD=',I3)
10090 FORMAT(//'   T,2S+1L  P    H(1)/2RY   EIGEN-H/2RY   CF  NI  NO  ',&
     &       'CI-MATRIX <GSL!CASL>  AND  H(2)/2RY-TRIANGLE.',           &
     &       '  E(CORE)/2RY =',F10.4,F11.4)
10100 FORMAT(I5,A4,2I4,1PE15.3,0PF14.7,F16.6,3X,2F10.5,F12.4,4F12.4)
10110 FORMAT(6I5,1PE15.5,2(0PF15.6))
10120 FORMAT(1X,4X,I4,2I4,1PE15.3,2(0PF15.4))
10130 FORMAT(60X,F15.6)
10140 FORMAT(4X,'NA',2X,'W',3X,'T  TP',8X,'AA*SEC',6X,'ECONT(A.U)',7X,  &
     &       'E-I(A.U)')
10150 FORMAT(8X,'I-S',12X,'C-S',11X,'AUTO-IONIZATION DATA',7X,'Z=',I2,  &
     &       3X,'N=',I2/3X,'CF',4X,'T',4X,'W',3X,'CF',4X,'T',4X,'W',6X, &
     &       'AA*SEC',9X,'E-C(RYD)',6X,'E-I(RYD)')
10160 FORMAT(5I5,4X,'X',1PE15.5,2(0PF15.6))
10170 FORMAT(I3,'CFLS',2X,'G',3X,'Z=',I2,4X,'N=',I2,2X,'NL',62(I3,I2))
10180 FORMAT(8X,'I-S',12X,'G-S',15X,'RADIATIVE DATA',9X,'Z=',I2,3X,'N=',&
     &       I2/3X,'CF',4X,'T',4X,'W',3X,'CF',4X,'T',4X,'W',6X,'AR*SEC',&
     &       9X,'DEL(RYD)',6X,'E-G(RYD)')
10190 FORMAT('+',67X,'(AA DATA INCLUDES TERM ENERGY CORRECTION)')
10200 FORMAT(4X,'NTERM=',I5,39X,'E1/RY=',F15.6/4X,'I',4X,'T',6X,'2S+1', &
     &       4X,'L',8X,'CF',5X,'(EI-E1)/RY')
10210 FORMAT(2I5,5X,2I5,5X,I5,F15.6,I10)
10220 FORMAT(A4)
10230 FORMAT(8X,'I-S',12X,'C-S',7X,'PHOTO-RECOMBINATION DATA',7X,'Z=',  &
     &       I2,3X,'N=',I2/3X,'CF',4X,'T',4X,'W',3X,'CF',4X,'T',3X,'EO',&
     &       6X,' P/CM2',9X,'E-I(RYD)',6X,'E-C(RYD)')
10240 FORMAT(I3,' E(RYD) ',2X,'Z=',I2,4X,'N=',I2,5X,'LS-Coupling',11X,  &
     &       'EIONMIN=',F15.6)
10250 FORMAT(5(1PE15.5))
10260 FORMAT(8X,'I-S',12X,'C-S',10X,'PHOTO-IONIZATION DATA',7X,'Z=',I2, &
     &       3X,'N=',I2/3X,'CF',4X,'T',4X,'W',3X,'CF',4X,'T',3X,'EO',6X,&
     &       ' P/CM2',9X,'E-I(RYD)',6X,'E-C(RYD)')
10270 FORMAT(2I5,4X,I1,I2,1X,10(I2,A1))
10280 FORMAT(I4,3I3,1PE14.6)
10290 FORMAT(I4,' TERMS AMONG',I4,' (KCUT=',I2,')')
10300 FORMAT(I5,' LS TERMS',I5,36X,A4//                                 &
     &     '   TERM   2S+1      L     PI     ENERGY(RYD)   ORIG. TERM #'&
     &     )
10310 FORMAT(4I7,F16.7,I15)
10320 FORMAT(3I6,I3,100(I3,I2))
10330 FORMAT(2I6,F13.3)
10340 FORMAT(' &ADASEX NTERM= XXX',' &END')                      !,I3
10350 FORMAT('NAME:'/'DATE:'/'.')
10360 FORMAT(A2,'+',I2,2I10,F15.4,A4)
10370 FORMAT('   E',I1,'-DATA  I  IP',6X,'A(EK)*SEC         S    ',12X, &
     &       'G*F',8X,'F(ABS)   -F(EMI)    WAVEL/AE',5X,                &
     &       'GF(VEL)  V(GFL*GFV)',5X,'GF(ACC)',2X,'ALPHA(POL)')
10380 FORMAT(24X,'VELOCITY',6X,'VELOCITY',91X,'VELOCITY')
10390 FORMAT(/' GAM   I(A,C) = ONE-BODY INTEGRALS')
10400 FORMAT(1X,I3,9F14.7/(4X,9F14.7))
10410 FORMAT(1P,5E16.6)
!10420 FORMAT(1PE14.8,6E11.3/(14X,6E11.3))
10420 FORMAT('C',79('-')/'C'/'C')
10430 FORMAT('C ',A200)
10440 FORMAT(A200)
10450 FORMAT('C'/'C'/'C',79('-')/'C'/'C',1X,                            &
     &       'AUTOSTRUCTURE PLANE-WAVE BORN'/'C'/'C NAME:'/'C DATE: ',  &
     &       2(A1),'/',2(A1),'/',2(A1)/'C'/'C',79('-'))
10460 FORMAT(22(1PE9.2))
10470 FORMAT(22(A5,1X,A3))
10480 FORMAT(A4)
10490 FORMAT(I6,40(F6.3))
10500 FORMAT(/"CONFIGURATION OVERLAP MATRIX (SET TO ZERO IF CF'S DIFFER"&
     &       ," BY MORE THAN 2 PAIRS) CASE IRLX=2:"/6X,40(I6))
10510 FORMAT('   E',I1,'-DATA  I  IP',6X,'A(EK)*SEC         S    ',4X,  &
     &       '10**',I1,'*','  G*F',7X,'*F(ABS)   -F(EMI)    WAVEL/AE',  &
     &       4X,'*GF(VEL) *V(GFL*GFV)',4X,'*GF(ACC)',3X,'OMG(BORN)')
10520 FORMAT('  E',I2,'-DATA  I  IP',6X,'A(EK)*SEC         S    ',4X,   &
     &       '10**',I1,'*','  G*F',7X,'*F(ABS)   -F(EMI)    WAVEL/AE',  &
     &       4X,'*GF(VEL) *V(GFL*GFV)',4X,'*GF(ACC)',3X,'OMG(BORN)')
10530 FORMAT(24X,'VELOCITY',6X,'VELOCITY')
10540 FORMAT(I6)
10550 FORMAT(' ',I8,' USED, MXAAI=',I8)
10560 FORMAT('*****STORAGE EXCEEDED IN SR.DIAGON, INCREASE MXAAI TO',I8)
10570 FORMAT(//9X,'ONE-BODY RELATIVISTIC CORRECTIONS TO INDIVIDUAL ',   &
     &       'ORBITALS IN UNITS OF 2*RY',35X,'LS.JPRINT =',I4/9X,       &
     &       'GAM    N    L    E(NON.REL)',8X,'E(MASS)',6X,'E(DAR)',7X, &
     &       'E(TOT)',23X,'<P**2/RY>')
10580 FORMAT(' CORE CONTRIB. ',F12.4,F12.5)
10590 FORMAT(7X,3I5,F14.6,3X,2F12.6,F13.7,20X,F12.6)
10600 FORMAT(/' ONE-BODY RELATIVISTIC INTEGRALS'/' I(R)  I(  A,  C ) = '&
     &       ,6X,'MASS',9X,'DARWIN',24X,'<P**2>')
10610 FORMAT(I5,3X,2I4,3X,2F14.7,16X,F14.7)
10620 FORMAT(' S L P',3X,'CF',3X,'NI',7X,'ENERGY(RYD)')
10630 FORMAT(/8X,'W P',3X,'CF',7X,'ENERGY(RYD)')
10640 FORMAT(/' SR.DIAGON   MAXUC=',I9,'  REQUIRED FOR ARRAY TFU'/20X,  &
     &       I9,'  INSUFFICIENT TO COMPUTE RADIATIVE TRANSITION DATA')
10650 FORMAT(//' *** ATTN: BECAUSE BORN MULTIPOLES ARE BEING COMPUTED', &
     &     ' FOR NON-E1 TRANSITIONS, RADIATIVE DATA IS NOT COMPUTED FOR'&
     &     ,' THOSE E3 TRANSITIONS'/11X,'FOR WHICH E1 DATA ALREADY',    &
     &     ' EXISTS (SO AS NOT TO OVERWRITE THE E1-LIMIT)'/)
10660 FORMAT(/' *** WORKING ARRAYS TOO SMALL IN SR.DIAGON, INCREASE',   &
     &       ' MXAAI TO:',                                              &
     &       I6/' *** OR REDUCE NUMBER OF SPECTROSCOPIC TERMS')
10670 FORMAT(3I2,I5,I5,F18.6,3X,A4)
10680 FORMAT(I9,I2,I5,F18.6)
10690 FORMAT(90X,'TERM ENERGY ',A24)
10700 FORMAT(' ',85X,I5,F10.0,F11.6,F14.6)
10710 FORMAT(2I10,F13.0,I5,I2,I5,A4,F8.3,F18.6,I10)
10720 FORMAT(2I10,F13.0,I7,I5,A4,8X,F18.6)
10730 FORMAT(9X,'I',8X,' T',8X,'K*CM',2X,'2S+1 L   CF',5X,'WEIGHTS',8X, &
     &       '(EI-E1)/RY     E1/RY =',F14.6)
10740 FORMAT(/' LIST OF CONFIGS WITH A WEIGHTED MEAN OVER THE TERM ',   &
     &       'STRUCTURE'/9X,'I',8X,' C',8X,'K*CM',7X,'W   CF',20X,      &
     &       '(EI-E1)/RY     E1/RY =',F14.6)
10750 FORMAT(//I6,' (IF .GT. 0: LOWEST STAT-WEIGHTED) TERMS ARE',       &
     &       ' MINIMIZED;    SCALING PARAMETERS ',5F9.5,/((84X,5F9.5)))
10760 FORMAT(68X,'*WARNING*  G WILL BE MINIMIZED, AS JPRINT=-2')
10770 FORMAT(//9X,'INCLUD =',I5,9X,'FUNCTIONAL F =',1PE14.7,9X,         &
     &       'FUNCTIONAL G =',E10.3,' (',I4,' TRANSITIONS)',9X,         &
     &       'LS.JPRINT=',I2//)
10780 FORMAT(9X,'THE ENERGY FUNCTIONAL IS THE ARITHMETIC MEAN OF THE ', &
     &       'CONFIGURATION WEIGHTED-MEAN ENERGIES'//)
10790 FORMAT(' SR.DIAGON DOES NOT CALCULATE E-ENERGIES (OR RATES) SINCE'&
     &       ,' MPRINT= ',                                              &
     &       I2/' ***********************************************',     &
     &       '******************* ')
10800 FORMAT(' *****ERROR IN SR.DIAGON, IT IS NOT POSSIBLE TO RUN MDEL',&
     &       ' .LT. 0 AND BDR .TRUE. AS PROGRAMMED ')
10810 FORMAT(33X,I1,'-POLE PERTURBED TFDA POTENTIAL SCALING PARAMETERS '&
     &       ,5F9.5,/((84X,5F9.5)))
10820 FORMAT(80A1)
10830 FORMAT('SR.DIAGON: ALLOCATION INCREASES NO. OF BORN INTERACTIONS '&
     &       ,'IXBIF=',I10,' .GT. MXBIF=',I10)
10840 FORMAT(2X,2I5,I4,10X,9(I2,I1))
10850 FORMAT(//1X,'LIST OF CFS THAT CONTRIBUTE AN ENERGY GREATER THAN ',&
     &       F7.0,'  /CM'//)
10860 FORMAT('*** SR.DIAGON: COULD ACCESS MEMORY FASTER IF MXD30=',I7)
10870 FORMAT(//'*** FILE "ITANAL" WRITTEN FOR:  ITANAL=',I6,5X,         &
     &       'ECNTRB=',F12.2,' /CM'/)
10880 FORMAT(1X,2I5,F10.5,F15.2,F12.2,5X,9(I2,I1))
10890 FORMAT(//1X,'TERM NUMBER',I4,'  SLP = ',2I3,'  ENERGY =',F15.2,   &
     &       ' /CM'/1X,'***************'//                              &
     &       '     T   CF     COEFF   ENERGY-DIFF',                     &
     &       '   ENERGY-CNTRB      ELECTRON CF'/)
10900 FORMAT(/25X,' Q.E.D. CONTRIBUTIONS /2RY'/8X,'  GAM    N    L',3X, &
     &       'VACUUM POLARIZ.',6X,'SELF ENERGY',9X,'TOTAL')
10910 FORMAT(8X,3I5,3(2X,F15.7),2F10.5)
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!-----------------------------------------------------------------------
      FUNCTION IROW(ILI,ILF,IONE1,NENG)
!
      INTEGER(SP) ILI,ILF,IONE1,NENG,IROW
!
      IROW=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE1))/2
!
      END FUNCTION IROW
!-----------------------------------------------------------------------
!
      END SUBROUTINE DIAGON
!
!                             *******************
!
      SUBROUTINE DIFF(DA,DB,NH,HN,JH)
!
!-----------------------------------------------------------------------
!
!  SR.DIFF COMPUTES THE FIRST DERIVATIVE OF ARRAY DA INTO ARRAY DB,
!  USING A 7 POINT LAGRANGE FORMULA.
!  REFERENCE: W.G. BICKLEY, MATH.GAZ.25, 19-27 (1941).
!
!  IT IS CALLED BY:
!    SR.FCF6
!    SR.FSINT
!    SR.FSINTI
!    SR.RADBP1
!    SR.RADBP2
!    SR.RADCON
!    SR.RADCX0
!    SR.RADIAL
!    SR.RADWAV
!    SR.RK4PI
!    SR.RKINT
!    FN.TLAM
!    FN.ULAM
!    SR.VLAM0
!    SR.VNYKX
!    SR.ZETA
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION DA(*),DB(*),HN(JH),NH(JH)
!
!-----------------------------------------------------------------------
!
      N=0
!
      DO J=1,JH
        F=1/(60*HN(J))
        NA=N+1
        K=NA
        DB(NA)=(-147*DA(K)+360*DA(K+1)-450*DA(K+2)+400*DA(K+3)          &
     &         -225*DA(K+4)+72*DA(K+5)-10*DA(K+6))*F
        DB(NA+1)=(-10*DA(K)-77*DA(K+1)+150*DA(K+2)-100*DA(K+3)          &
     &           +50*DA(K+4)-15*DA(K+5)+2*DA(K+6))*F
        DB(NA+2)=(2*DA(K)-24*DA(K+1)-35*DA(K+2)+80*DA(K+3)-30*DA(K+4)   &
     &           +8*DA(K+5)-DA(K+6))*F
        N=NH(J)+N
        NB=N-6
!
        DO K=NA,NB
          DB(K+3)=(((DA(K+4)-DA(K+2))*5+DA(K+1)-DA(K+5))*9+DA(K+6)-DA(K)&
     &            )*F
        ENDDO
!
        K=NB
        NB=N
        DB(NB-2)=(DA(K)-8*DA(K+1)+30*DA(K+2)-80*DA(K+3)+35*DA(K+4)      &
     &           +24*DA(K+5)-2*DA(K+6))*F
        DB(NB-1)=(-2*DA(K)+15*DA(K+1)-50*DA(K+2)+100*DA(K+3)-150*DA(K+4)&
     &           +77*DA(K+5)+10*DA(K+6))*F
        DB(NB)=(10*DA(K)-72*DA(K+1)+225*DA(K+2)-400*DA(K+3)+450*DA(K+4) &
     &         -360*DA(K+5)+147*DA(K+6))*F
      ENDDO
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE DIFF
!
!                             *******************
!
      SUBROUTINE DIMUSE(NAME,NDIMEN)
!
!-----------------------------------------------------------------------
!
!  SR.DIMUSE
!     NDIMEN.GT.0 STORES THE MAX VALUE OF THE PRIMARY DIMENSION NAME.
!     NDIMEN.LE.0 RETURNS THE MAX VALUE OF THE PRIMARY DIMENSION NAME.
!
!  IT IS CALLED BY:
!    SR.ALGEB
!    SR.ALGEB1
!    SR.ALGEB2
!    SR.ALGEB3
!    SR.ALGEB4
!    SR.ALGX
!    SR.ALGXFS
!    SR.ALGXLS
!    SR.CALGEB
!    SR.CALGX
!    SR.CASC
!    SR.CASYM
!    SR.CONFG0
!    SR.CONFG1
!    SR.DIAGFS
!    SR.DIAGON
!    SR.DWX
!    SR.MESH
!    SR.MINIM0
!    SR.PCASYM
!    SR.PSYMJ
!    SR.PSYMLS
!    SR.RADCN0
!    SR.RADCON
!    SR.RADCX0
!    SR.RADIAL
!    FN.SJS
!    SR.SYMLS
!    SR.SYMLSJ
!    FN.VCC
!    SR.VCG
!    SR.VCU
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      CHARACTER(LEN=5) NAME           !KNAM,
!
!-----------------------------------------------------------------------
!
      DO K=1,MXDIM
        IF(NAME.EQ.KNAM(K))THEN
          IF(NDIMEN.GT.0)THEN
            MXUSED(K)=MAX(MXUSED(K),NDIMEN)
          ELSE
            NDIMEN=MXUSED(K)
          ENDIF
          GO TO 100
        ENDIF
      ENDDO
!                                                 SHOULD NEVER GET HERE!
      WRITE(MW6,*)'SR.DIMUSE: DIMENSION NAME NOT FOUND ',NAME
      STOP 'SR.DIMUSE: DIMENSION NAME NOT FOUND'
!
!-----------------------------------------------------------------------
!
  100 RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE DIMUSE
!
!                             *******************
!
       SUBROUTINE DIPOL(JSW,N1,N2,E2,LMAX,CP,CM,JC)
!
!-----------------------------------------------------------------------
!
!  ALAN BURGESS DAMTP CAMBRIDGE, MODS BY NRB.
!
!  SR.DIPOL CALCULATES SQUARES OF HYDROGENIC DIPOLE LENGTH RADIAL MATRIX
!  ELEMENTS FOR BOUND-BOUND OR BOUND-FREE TRANSITIONS.
!
!  BOUND STATES ARE NORMALISED TO UNITY.
!  FREE STATES ARE NORMALISED TO ASYMPTOTIC AMPLITUDE K**(-0.5).
!
!  N.B. DIPOLE ACCELERATION MATRIX ELEMENT = (E12**2/4Z) * DIPOLE LENGTH
!  WHERE E12 = - N1**(-2) + N2**(-2)  FOR BOUND-BOUND
!            = - N1**(-2) + E2        FOR BOUND-FREE
!          Z = REDUCED CHARGE
!  INPUT:
!   FOR BOUND-BOUND,SET JSW=NEGATIVE
!                     N1,N2=PRINCIPAL QUANTUM NUMBERS OF STATES
!                      LMAX=RANGE OF ANGULAR MOMENTUM QUANTUM NUMBERS
!   FOR BOUND-FREE, SET JSW=POSITIVE
!                       N1=BOUND STATE PRINCIPAL QUANTUM NUMBER
!                       E2=FREE STATE ENERGY IN RYDBERGS (=K**2)
!
!  OUTPUT:
!   VECTOR CP(L),L=1,LMAX,CONTAINS SQUARED MATRIX ELEMENTS FOR ANGULAR
!                         MOMENTUM TRANSITIONS FROM L-1 TO L,
!   VECTOR CM(L),L=1,LMAX,CONTAINS SQUARED MATRIX ELEMENTS FOR ANGULAR
!                         MOMENTUM TRANSITIONS FROM L TO L-1,
!               IN BOTH CASES THE TRANSITION IS FROM LOWER TO HIGHER
!               ENERGY, INDEPENDANT OF THE SIGN OF N1-N2 FOR BOUND-BOUND
!               CASES. IF N1=N2 THEN CP(L)=CM(L).
!   VECTOR JC(L),L=1,LMAX WILL USUALLY BE ZERO AND MAY THEN BE IGNORED,
!               BUT FOR EXTREME INPUT VALUES THERE IS POSSIBILITY OF
!               OVER OR UNDERFLOW OF CP(L) OR CM(L),IN WHICH CASE THE
!               OUTPUT VALUES OF CP(L) AND CM(L) SHOULD BE MULTIPLIED
!               BY (1.0D10)**JC(L) TO OBTAIN TRUE VALUES.
!
!  IT IS CALLED BY:
!    SR.RK4PI
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (S1=D1P10)
      PARAMETER (S2=D1M10)
      PARAMETER (TEST1=D1M20)
      PARAMETER (TEST2=D1P20)
      PARAMETER (TEST3=0.044_WP)
      PARAMETER (TEST4=D0PT1)
      PARAMETER (TEST5=300)
      PARAMETER (TEST6=D1M30)
      PARAMETER (TEST7=D1P30)
!
      DIMENSION CP(LMAX),CM(LMAX),JC(LMAX)
!
!-----------------------------------------------------------------------
!
      PI=ACOS(-DONE)
!
      N=N1
      E=E2
      IF(JSW.LE.0)THEN
        EN2=N2
        N3=N2
        IF(N1.EQ.N2)GO TO 600
        IF(N2.LT.N1)THEN
          N=N2
          EN2=N1
          N3=N1
        ENDIF
        E=-DONE/(EN2*EN2)
      ENDIF
!
      EN=N
      ENN=EN*EN
      E1=-DONE/ENN
      JMAX=LMAX
      C1=DONE
      C2=DZERO
      JS=0
      L=N+1
      IF(N.LE.LMAX)THEN
        CP(N)=DONE
        CM(N)=DZERO
        JC(N)=0
        JMAX=N-1
        DO I=L,LMAX
          CP(I)=DZERO
          CM(I)=DZERO
          JC(I)=0
        ENDDO
      ENDIF
!
  100 L=L-1
      IF(L.GT.1)THEN
        EL=L
        ELL=EL*EL
        T1=DONE+ELL*E1
        T2=DONE+ELL*E
        T3=L+L-1
        T4=DONE/(T3+DONE)
        T5=(T3*T1*C2+T2*C1)*T4
        C1=(T1*C2+T3*T2*C1)*T4
        C2=T5
  150   IF(C1*C1.GT.TEST2)THEN
          C1=S2*C1
          C2=S2*C2
          JS=JS+1
          GO TO 150
        ENDIF
        IF(L.LE.LMAX+1)THEN
          CP(L-1)=C1
          CM(L-1)=C2
          JC(L-1)=JS
        ENDIF
        GO TO 100
      ENDIF
!
      JS=0
      T=4
      T=DONE/(T*EN*ENN)
      IF(JSW.LE.0)THEN                          !JSW.LT.0
        ENN2=EN2*EN2
        T1=4
        T1=T1*ENN*ENN2/(ENN2-ENN)
        T1=T1*T1
        T=T*T1*T1/(EN2*ENN2)
        IF(N3.LE.30)THEN
          T=T*((EN2-EN)/(EN2+EN))**(N3+N3)
          GO TO 200
        ENDIF
        E21=E/E1
        IF(E21.LE.TEST4)THEN
          T2=DZERO
          DO J=1,11
            T3=2*(11-J)+1
            T2=DONE/T3+T2*E21
          ENDDO
          T2=T2+T2
        ELSE
          T3=EN/EN2
          T2=LOG((DONE+T3)/(DONE-T3))/T3
        ENDIF
        T2=T2+T2
        T1=T1*EXP(-T2)
!
      ELSE                                      !JSW.GT.0
!
        T1=4
        T1=T1*ENN/(DONE+ENN*E)
        T1=T1*T1
        T=T*T1*T1
        IF(E.LT.TEST3)THEN
          T3=2
          T=T*(PI/T3)
        ELSE
          T4=SQRT(E)
          IF(T4.LE.TEST5)THEN
            T3=(PI+PI)/T4
            T3=DONE-EXP(-T3)
            T3=DONE/T3
          ELSE
            T4=PI/T4
            T3=3
            T3=(DONE+T4+T4*T4/T3)/(T4+T4)
          ENDIF
          T2=2
          T=T*(PI*T3/T2)
        ENDIF
!
        T4=ENN*E
        IF(T4.LE.TEST4)THEN
          T2=DZERO
          DO J=1,11
            T3=2*(11-J)+1
            T2=DONE/T3-T2*T4
          ENDDO
        ELSE
          T3=SQRT(T4)
          T2=ATAN(T3)/T3
        ENDIF
        T2=T2+T2
        T2=T2+T2
        T1=T1*EXP(-T2)
      ENDIF
!                                               !ALL JSW
  200 DO J=1,N
        TJ=J+J
        T2=TJ*(TJ-DONE)
        T2=T2*T2
        T=T*T1/T2
  250   IF(T.LE.TEST1)THEN
          T=T*S1
          JS=JS-1
          GO TO 250
        ENDIF
  300   IF(T.GE.TEST2)THEN
          T=T*S2
          JS=JS+1
          GO TO 300
        ENDIF
      ENDDO
      J=0
!
  400 J=J+1
      IF(J.LE.JMAX)THEN
        TJ=J
        TJ=TJ*TJ
        T1=DONE+TJ*E1
        T2=DONE+TJ*E
        T3=CP(J)
        T3=T2*T*T3*T3
        T4=CM(J)
        T4=T1*T*T4*T4
        L1=JC(J)+JC(J)+JS
!
  450   IF(L1.LT.0)THEN
          IF(T4.GT.TEST6)THEN
            L1=L1+1
            T3=T3*S2
            T4=T4*S2
            GO TO 450
          ENDIF
        ELSEIF(L1.GT.0)THEN
          IF(T3.LT.TEST7)THEN
            L1=L1-1
            T3=T3*S1
            T4=T4*S1
            GO TO 450
          ENDIF
        ENDIF
!
        CP(J)=T3
        CM(J)=T4
        JC(J)=L1
        T=T*T1*T2
  500   IF(T.GT.TEST2)THEN
          T=T*S2
          JS=JS+1
          GO TO 500
        ENDIF
        GO TO 400
      ENDIF
!
      IF(N.LE.LMAX)THEN
        T2=DONE+ENN*E
        T3=CP(N)
        T3=T2*T*T3*T3
        L1=JC(N)+JC(N)+JS
!
  550   IF(L1.LT.0)THEN
          IF(T3.GT.TEST6)THEN
            L1=L1+1
            T3=T3*S2
            GO TO 550
          ENDIF
        ELSEIF(L1.GT.0)THEN
          IF(T3.LT.TEST7)THEN
            L1=L1-1
            T3=T3*S1
            GO TO 550
          ENDIF
        ENDIF
!
        CP(N)=T3
        JC(N)=L1
      ENDIF
!
      RETURN
!
  600 JMAX=LMAX
      IF(N.LE.LMAX)THEN
        DO L=N,LMAX
          CP(L)=DZERO
          CM(L)=DZERO
          JC(L)=0
        ENDDO
        JMAX=N-1
      ENDIF
      T1=9
      T2=4
      T3=(T1/T2)
      T1=EN2*EN2
      T2=T1*T3
      DO J=1,JMAX
        TJ=J
        JC(J)=0
        T=T2*(T1-TJ*TJ)
        CP(J)=T
        CM(J)=T
      ENDDO
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE DIPOL
!
!                             *******************
!
      SUBROUTINE DISKDC(IU,ISTRT,IFIN,KF,NGSYM,IRW,MSTRT0)
!
!-----------------------------------------------------------------------
!
! SR.DISKDC READS/WRITES TO AN UNFORMATTED UNIT=IU FILE.
! ALL WRITES TAKE PLACE BEFORE ALL READS, SO IT CAN BE SEQUENTIAL OR
! DIRECT ACCESS, DEPENDING ON WHICH IS MOST EFFICIENT FOR THE HARDWARE.
! THE CHOICE IS SET BY A LOGICAL VARIABLE BSEQ IN DATA STATEMENT BELOW.
! UNLESS SINGLE STAGE RESTART (MSTRT0.GT.IRL5=6), IT IS 'SCRATCH'.
!
!  IRW.EQ.0 ALLOWS OPEN/CLOSE/REWIND OF FILE ETC - SEE  BELOW
!     .GT.0 READ A SLICE OF THE DC (& IDC) ARRAYS
!     .LT.0 WRITE      "        "         "
! FROM
!  ISTRT TO IFIN (IN THE CASE OF READ, IFIN IS OUTPUT ONLY)
! FOR
!  KF CONFIG
!  NGSYM SLP SYMMETRY GROUP INDEX WITHIN THE CONFIG
!
!  MSTART IS USED TO FLAG FILE STATUS AT
!     OPEN: REPLACE/OLD
!    CLOSE: KEEP/DELETE
! (MOST OBVIOUSLY FOR THE USUAL RESTART, BUT MORE GENERALLY AS WELL.)
!
! RELEVANT COMMON /NRBDSK/ VARIABLES:
!  MDCF8 CONTAINS THE TOTAL NUMBER OF VCC'S (DC ARRAY) FOR KF
!  MDCFT8 CONTAINS THE SUM OF MDCF8 OVER ALL CONFIGS.
!  MDCBUF CONTAINS THE CURRENT DC SLICE LENGTH:
!   DURING WRITE IT LOGS THE MAX LENGTH OF SLICE OF ARRAY DC USED
!   AND DURING READ IT CHECKS IFIN DOES NOT EXCEED IT.
!
!  IT IS CALLED BY:
!    SR.ALGEB
!    SR.ALGEB2
!    SR.ALGEB3
!    SR.ALGEB4
!    SR.ALGX
!    SR.ALGXFS
!    SR.ALGXLS
!    SR.REDSS
!    SR.VCG
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam                            !par
!
      USE COMMON_ALGEB,  ONLY: MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD     &
     &                        ,KFBUFF
      USE COMMON_DC,     ONLY: DC,IDC
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
!
      USE COMMON_NRBGCF, ONLY: KGSL,KGCF,NKSL,KSLX
!par!                                                               !par
!par      use common_nrbpar, only: num                              !par
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,IBUFF4
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (LREC=2**15)
!
      PARAMETER (IRL5=6)                        !5+1 NOW ALG3/4 SEPARATE
!
      CHARACTER(LEN=2) NAME0
      CHARACTER(LEN=9) FILNAM
      CHARACTER(LEN=9) STATLB
!
      ALLOCATABLE :: NPTS0(:)
      ALLOCATABLE :: IREC(:)                     !FOR DIRECT ACCESS ONLY
!
      DATA BDSKLP/.FALSE./,BSEQ/.FALSE./,IRECL/0/
!
      SAVE KF0,NPOS0,npos1,npos2,istrt1,ifin1,istrt2,ifin2,NPTS0        &
     &    ,IREC,IRECW,IWORD,IOPEN,IUP
!
!-----------------------------------------------------------------------
!
      BFAST=DC(0).LT.DZERO                              !ELSE OPT MEMORY
!
      IF(IRECL.EQ.0.AND..NOT.BSEQ)THEN                    !DIRECT ACCESS
        IRECL=8*LREC                                      !*8 DC
        IF(.NOT.BFAST)THEN                                !*4 IDC
          ITEST4=IBUFF4
          ITEST4=ITEST4+1
          IF(ITEST4.LT.IBUFF4)THEN                        !DEFAULT
            IWORD=4
          ELSE                                            !I*8 IMPOSED
            IWORD=8
          ENDIF
          IRECL=IRECL+IWORD*LREC
        ENDIF
      ENDIF
!
      IF(IRW.EQ.0)THEN                                   !INITIALIZE I/O
!
        MSTRT=ABS(MSTRT0)
        MSTART=MOD(MSTRT,IRL5)
        MS1=1
        IF(MSTRT.NE.0)MS1=MSTART/MSTRT
!
        IF(IUNIT(IU).EQ.0)THEN                                     !OPEN
!
          IF(IU.EQ.MRW32)THEN
!
            IUP=IU+1
!
            KSL0=KSLX*KMAX
            ALLOCATE(NPTS0(KSL0))                                 !SMALL
            IF(.NOT.BSEQ)ALLOCATE(IREC(KSL0))                     !SMALL
!
            IF(MSTART.EQ.0.OR.MSTART*MS1.EQ.1)THEN
              STATLB='SCRATCH'                         !AS NO RE-RESTART
              IF(BSEQ)THEN
                OPEN(IU,FORM='UNFORMATTED',STATUS=STATLB)
              ELSE
                OPEN(IU,FORM='UNFORMATTED',STATUS=STATLB,               &
     &               ACCESS='DIRECT',RECL=IRECL)
                IRECW=1
              ENDIF
            ELSE
              NAME0=''
!par!                                                               !par
!par              i1=iam/10                                         !par
!par              i2=iam-(10*(iam/10))                              !par
!par              name0=num(i1)//num(i2)                            !par
!par!                                                               !par
              FILNAM='DISKDC'//NAME0
              IF(MSTART.LE.1)THEN                       !.EQ.0 TEST KEEP
                STATLB='REPLACE'
              ELSE
                STATLB='OLD'
              ENDIF
              IF(BSEQ)THEN
                OPEN(IU,FILE=FILNAM,FORM='UNFORMATTED',STATUS=STATLB)
              ELSE
                OPEN(IU,FILE=FILNAM,FORM='UNFORMATTED',STATUS=STATLB,   &
     &               ACCESS='DIRECT',RECL=IRECL)
                IRECW=1                            !ONLY FOR MSTART.LE.1
              ENDIF
!
              IUNIT(IUP)=1
              FILNAM='IDISKDC'//NAME0
              OPEN(IUP,FILE=FILNAM,FORM='UNFORMATTED',STATUS=STATLB)
              IF(STATLB.EQ.'OLD')THEN
                READ(IUP)KSL0
                READ(IUP)(NPTS0(K),K=1,KSL0)
                IF(.NOT.BSEQ)READ(IUP)(IREC(K),K=1,KSL0)
              ENDIF
            ENDIF
!
          ELSEIF(IU.EQ.MRW33)THEN
!
!DSK            FILNAM='DSKDMP'
!DSK            STATLB='REPLACE'
!DSK            OPEN(IU,FILE=FILNAM,FORM='UNFORMATTED',STATUS=STATLB)
!
            if(mstart.ne.0)stop 'diskdc: illegal mstart (non-zero)'
!
            STATLB='SCRATCH'                   !AS NO RESTARTX, MSTART=0
            IF(BSEQ)THEN
              OPEN(IU,FORM='UNFORMATTED',STATUS=STATLB)
            ELSE
              OPEN(IU,FORM='UNFORMATTED',STATUS=STATLB,ACCESS='DIRECT', &
     &             RECL=IRECL)
              IRECW=1
            ENDIF
!
          ELSE                           ! should not be here
            write(mw6,*)'sr.diskdc: illegal unit number',iu
            stop 'sr.diskdc: illegal unit number'
          ENDIF
!
          IUNIT(IU)=1
          IOPEN=IU                                  !FOR REDSS OPERATION
!
          KF0=9999
          NPOS0=0
          npos1=-1
          npos2=-1
!
        ELSEIF(IUNIT(IU).GT.0)THEN
!
          IF(ISTRT.EQ.0)THEN                                      !CLOSE
            IF(MSTART.GT.0.AND.MSTART.LT.4*(1-MS1))THEN       !FOR 2/3/4
              IUNIT(IU)=-1
            ELSE                                            !WE ARE DONE
              IUNIT(IU)=0
            ENDIF
            IF(IUNIT(IU).LT.0)THEN
              CLOSE(IU,STATUS='KEEP')
              IF(IU.EQ.MRW32)THEN
                IF(IUNIT(IUP).GT.0)THEN
                  IF(MSTART.LE.1)THEN                           !REPLACE
                    KSL0=KGCF(KMAX)-KGCF(KUTDSK)
                    WRITE(IUP)KSL0
                    WRITE(IUP)(NPTS0(K),K=1,KSL0)
                    IF(.NOT.BSEQ)WRITE(IUP)(IREC(K),K=1,KSL0)
                  ENDIF
                  CLOSE(IUP,STATUS='KEEP')
                  IUNIT(IUP)=-1
                ENDIF
              ENDIF
            ELSEIF(IUNIT(IU).EQ.0)THEN
              CLOSE(IU,STATUS='DELETE')
              IF(IU.eq.MRW32.and.ifin.eq.0)THEN
                IF(IUNIT(IUP).GT.0)THEN
                  CLOSE(IUP,STATUS='DELETE')
                  IUNIT(IUP)=0
                ENDIF
              ENDIF
            ENDIF
!
            IF(IU.EQ.IOPEN)THEN                             !WE ARE DONE
              DEALLOCATE(NPTS0)
              IF(.NOT.BSEQ)DEALLOCATE(IREC)
            ENDIF
!
          ELSE                                               !RE-INITIAL
            IF(NGSYM.GT.0)THEN
              KSL0=KGCF(KF-1)-KGCF(KUTDSK)+NGSYM
              NPTS=NPTS0(KSL0)
              IFIN=ISTRT+NPTS-1
            ENDIF
          ENDIF
!
        else                                        !-1
          write(mw6,*)'sr.diskdc: should not be here'
          stop 'sr.diskdc: should not be here'
        ENDIF
!
      ELSEIF(IRW.LT.0)THEN                                        !WRITE
!
        NPTS=IFIN-ISTRT+1
        MDCBUF=MAX(MDCBUF,NPTS)    !CAN'T USE IFIN BECAUSE OF VCG BUFFER
        IF(KF.GT.KF0)THEN
          MDCFT8=MDCFT8+MDCF8
          MDCF8=0
        ENDIF
        KF0=KF
        MDCF8=MDCF8+INT(NPTS,SP)
!
!        write(mw0,*)kf,ngsym,istrt,ifin,npts,mdcbuf
!
        KSL0=KGCF(KF-1)-KGCF(KUTDSK)+NGSYM                      !=KSL0+1
        NPTS0(KSL0)=NPTS
!
        IF(BDSKLP)THEN
!          write(mw6,*)kf,ngsym,npts
          IF(.NOT.BFAST)WRITE(MW6,10020)(IDC(I),I=ISTRT,IFIN)
          WRITE(MW6,10010)(DC(I),I=ISTRT,IFIN)
        ENDIF
!
        IF(BSEQ)THEN
          WRITE(IU)(DC(I),I=ISTRT,IFIN)
          IF(.NOT.BFAST)WRITE(IU)(IDC(I),I=ISTRT,IFIN)
        ELSE
          IREC(KSL0)=IRECW
          I2=ISTRT-1
   20     CONTINUE
          I1=I2+1
          I2=MIN(I2+LREC,IFIN)
          IF(BFAST)THEN
            WRITE(IU,REC=IRECW)(DC(I),I=I1,I2)
          ELSE
            WRITE(IU,REC=IRECW)(DC(I),I=I1,I2),(IDC(I),I=I1,I2)
          ENDIF
          IRECW=IRECW+1                 !POINTS TO NEXT AVAILABLE RECORD
          IF(I2.LT.IFIN)GO TO 20
        ENDIF
!
      ELSEIF(IRW.GT.0)THEN                                         !READ
!
        NREC0=1                                   !ONLY NEEDED FOR BSEQ,
        IF(.NOT.BFAST)NREC0=NREC0+1               !ELSE A VIRTUAL INDEX
!
        KSL0=KGCF(KF-1)-KGCF(KUTDSK)+NGSYM
        NPOS=NREC0*(KSL0-1)                         !WHERE WE WANT TO BE
!
! test to see which buffer in use
!        npos0=0                            !test
!
        if(kutdsk.lt.kfbuff)then            !whole group
          npos1=-1
          npos2=-1
          ibuff=0                           !for variable length
        else                                !by cf
!
! then see if we already have it for quick return
!
          if(npos.eq.npos1)then
            istrt=istrt1
            ifin=ifin1
!                      write(77,*)npos,-kf,ngsym,istrt,ifin,npts
!                      call flush(77)
            return
          elseif(npos.eq.npos2)then
            if(istrt.eq.mtgd1)then
              ifin=mtgd1-1
              do i=istrt2,ifin2
                ifin=ifin+1
                dc(ifin)=dc(i)
                if(.not.bfast)idc(ifin)=idc(i)
              enddo
              istrt1=mtgd1                                    !trivially
              ifin1=ifin
              istrt=istrt1
              ifin=ifin1
              npos1=npos2
              npos2=-1                                      !not necess.
!                      write(79,*)npos,-kf,-ngsym,istrt,ifin,npts
!                      call flush(79)
              return
            else
              istrt=istrt2
              ifin=ifin2
!                      write(78,*)npos,kf,-ngsym,istrt,ifin,npts
!                      call flush(78)
              return
            endif
          endif
!
! no we don't, so read
!
!          ibuff=0   !for variable length (and see end of this if block)
          ibuff=(mdcbuf-mtgd1+1)/2                     !for fixed length
          if(istrt.gt.mtgd1)istrt=mtgd1+ibuff          !for fixed length
        endif
!
        NPTS=NPTS0(KSL0)
!
        IFIN=ISTRT+NPTS-1
        IF(IFIN.GT.MDCBUF)THEN
          WRITE(MW6,10030)IFIN,MDCBUF
          WRITE(MW0,*)' *** DISKDC ERROR: RECORD TO LONG FOR DC ARRAY'
          IFIN=-IFIN
          RETURN
        ENDIF
!
!        write(76,*)npos,kf,ngsym,istrt,ifin,npts
!        call flush(76)
!
        IF(BSEQ)THEN
!
          IF(NPOS0.EQ.0)REWIND(IU)                           !FIRST READ
!
          IF(NPOS.GT.NPOS0)THEN              !PROGRESS THRU FINAL GROUPS
            DO N=NPOS0+1,NPOS
              READ(IU)
            ENDDO
          ELSEIF(NPOS.LT.NPOS0)THEN   !+NREC0 !START A NEW INITIAL GROUP
            IF(NPOS0-NPOS.GT.NPOS)THEN
              REWIND(IU)
              DO N=1,NPOS
                READ(IU)
              ENDDO
            ELSE
              DO N=NPOS+1,NPOS0
                BACKSPACE(IU)
              ENDDO
            ENDIF
          ENDIF
!
          READ(IU)(DC(I),I=ISTRT,IFIN)
          IF(.NOT.BFAST)READ(IU)(IDC(I),I=ISTRT,IFIN)
!
          NPOS0=NPOS+NREC0
!
        ELSE
!
          IRECR=IREC(KSL0)
          I2=ISTRT-1
   40     CONTINUE
          I1=I2+1
          I2=MIN(I2+LREC,IFIN)
          IF(BFAST)THEN
            READ(IU,REC=IRECR)(DC(I),I=I1,I2)
          ELSE
            READ(IU,REC=IRECR)(DC(I),I=I1,I2),(IDC(I),I=I1,I2)
          ENDIF
          IRECR=IRECR+1
          IF(I2.LT.IFIN)GO TO 40
!
!          if(.not.bfast)write(mw6,101)(idc(i),i=istrt,ifin)
!          write(mw6,100)(dc(i),i=istrt,ifin)
!
        ENDIF
!
! - not currently used if(kutdsk.lt.kfbuff)...
!
        if(istrt.eq.mtgd1)then
          npos1=npos
          istrt1=istrt                                        !trivially
          ifin1=ifin
          if(ibuff.eq.0)npos2=-1              !reset unless fixed length
        else
          npos2=npos
          istrt2=istrt
          ifin2=ifin
        endif
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(10F8.4)
10020 FORMAT(10I8)
10030 FORMAT(/' *** DISKDC ERROR: ATTEMPT TO READ DC ARRAY TO',I9,      &
     &       ' WHICH EXCEEDS DIMENSION:',I9)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE DISKDC
!
!                             *******************
!
      SUBROUTINE DISKTF(ISYM0,IVEC,ILEN,TFU,IRW)
!
!-----------------------------------------------------------------------
!
! SR.DISKTF READS/WRITES E-VECTORS FROM TFU(*) TO MULTIPLE UNFORMATTED
! 'SCRATCH' FILES INDEXED BY ISYM.
!
! ALL WRITES TAKE PLACE BEFORE ALL READS SO IT CAN BE SEQUENTIAL, STREAM
! OR DIRECT ACCESS DEPENDING ON WHICH IS MOST EFFICIENT FOR THE HARDWARE
! THE CHOICE IS SET BY A LOGICAL VARIABLES BSEQ AND BSTRM IN DATA
! STATEMENTS BELOW. BSTRM IS IGNORED IF BSEQ.EQ..T.
!
! N.B. BECAUSE OF CONTINUUM, THE E-VECTORS ARE NOT ALL THE SAME LENGTH
!      WITHIN A SYMMETRY, AS WE ARE BLOCK DIAGONAL WITHIN IT THEN.
!
!      'DIRECT' ACCESS REQUIRES FIXED LENGTH RECORDS.
!      A SIMPLE SOLUTION REQUIRING NO EXTRA INTERNAL MEMORY IS TO MAKE
!      THE RECORD LENGTH THE MAX E-VECTOR LENGTH WITHIN EACH SYYMETRY,
!      BUT IT USES LARGER SCRATCH FILES THAN NECESSARY.
!      THIS IS LARGELY OVERCOME BY USING A RECORD LENGTH LREC<<ILEN,
!      THUS WRITING AN E-VECTOR OVER MULTIPLE SHORTER RECORDS AND
!      LEADING TO LESS PADDING/UNUSED RECORD.
!      IT IS HANDLED MORE ELEGANTLY WITH THE USE OF THE
!      F2003 ACCESS='STREAM' FILE TYPE.
!      BOTH OF THESE REQUIRE THE STARTING POSITION OF EACH E-VECTOR AND
!      SO REQUIRE AN ADDITIONAL VECTOR OF DIMENSION OF THE TOTAL NUMBER
!      OF TERMS/LEVELS.
!
!  IRW.EQ.0 ALLOWS OPEN/CLOSE OF THE ISYM FILES, THEN (ON OPENING)
!           ILEN SPECIFIES THE MAX E-VECTOR LENGTH (FOR DIRECT ACCESS).
!           IVEC & TFU ARE NOT REFERENCED HERE.
!
!     .LT.0 WRITES AN E-VECTOR FOR STATE IVEC STORED IN TFU(1:ILEN)
!           TO FILE ISYM. IF IT IS A SEQUENTIAL FILE THEN IVEC IS
!           IMPLICITLY 1,2,3 ETC AND IS NOT REFERENCED.
!
!     .GT.0 READS AN E-VECTOR FOR STATE IVEC STORED ON FILE ISYM INTO
!           TFU(1:ILEN). IT IS USED BY SEQUENTIAL, STREAM AND DIRECT
!           ACCESS.
!
!  IT IS CALLED BY:
!    SR.DIAGON
!    SR.DIAGFS
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      LOGICAL BEX                         !INQUIRE REQUIRES DEFAULT KIND
!
      REAL(WP) TFU                              !SYNC WITH DIAGON/DIAGFS
!
      PARAMETER (IWORD=WP)                              !TFU WORD LENGTH
      PARAMETER (IU0=100)                             !UNIT NOS=IU0+ISYM
      PARAMETER (LREC0=2**13)               !DIRECT ACCESS RECORD LENGTH
!
      DIMENSION TFU(*)
!
      ALLOCATABLE :: IREC(:),LREC(:),IPOS1(:),IPOS2(:)
!
      DATA BSEQ/.FALSE./                   !CHOOSE MOST SYSTEM EFFICIENT
      DATA BSTRM/.TRUE./                                 !.NOT.BSEQ ONLY
!
      SAVE IREC,LREC,IRECW,IPOS0,IPOS1,IPOS2
!
!-----------------------------------------------------------------------
!
      ISYM=ABS(ISYM0)
!
      IU=IU0+ISYM
!
      IF(IRW.EQ.0)THEN                          !INITIALIZE/FINALIZE I/O
!
        INQUIRE(IU,OPENED=BEX)
!
        IF(BEX)THEN                                         !WE ARE DONE
!
          CLOSE(IU)
!
          IF(ALLOCATED(IREC))DEALLOCATE(IREC)                    !ISYM=1
          IF(ALLOCATED(LREC))DEALLOCATE(LREC)                    !ISYM=1
          IF(ALLOCATED(IPOS1))DEALLOCATE(IPOS1)                  !ISYM=1
          IF(ALLOCATED(IPOS2))DEALLOCATE(IPOS2)                  !ISYM=1
!
        ELSE
!
          IF(ISYM.EQ.1)THEN                                    !ALLOCATE
!
            IF(ISYM0.LT.0)THEN
              NSYM=IAXSL
              NPOS=IAXTM
            ELSE
              NSYM=IAXJG
              NPOS=IAXLV
            ENDIF
!
            IF(BSEQ)THEN
!
              ALLOCATE(IREC(NSYM))                                !SMALL
!
            ELSE
!
              ALLOCATE(IPOS1(NSYM),IPOS2(NPOS),STAT=IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)'SR.DISKTF:ALLOCATION FAILS FOR IPOS1,IPOS2'
                ILEN=-ILEN
                RETURN
              ENDIF
!
              IPOS0=0          !GLOBAL SYMMTERY ORDER INDEX OF THE STATE
!
              IF(.NOT.BSTRM)ALLOCATE(LREC(NSYM))                  !SMALL
!
            ENDIF
!
          ENDIF
!                                                    !OPEN FILE FOR ISYM
          IF(BSEQ)THEN
!
            IREC(ISYM)=0
!
            OPEN(IU,FORM='UNFORMATTED',STATUS='SCRATCH')
!
          ELSE
!
            IPOS1(ISYM)=IPOS0        !MARK WHERE NEW SYM STARTS IN IPOS2
!
            IF(BSTRM)THEN
!
              OPEN(IU,FORM='UNFORMATTED',STATUS='SCRATCH',              &
     &             ACCESS='STREAM')
!
              IRECW=0
!
            ELSE
!
              LREC(ISYM)=MIN(LREC0,ILEN)  !=ILEN => ONE E-VEC PER RECORD
              IRECL=IWORD*LREC(ISYM)
!
              OPEN(IU,FORM='UNFORMATTED',STATUS='SCRATCH',              &
     &             ACCESS='DIRECT',RECL=IRECL)
!
              IRECW=1
!
            ENDIF
!
          ENDIF
!
        ENDIF
!
      ELSEIF(IRW.LT.0)THEN                                        !WRITE
!
        IF(BSEQ)THEN
          WRITE(IU)(TFU(I),I=1,ILEN)
        ELSE
!
          IPOS0=IPOS0+1
          IPOS2(IPOS0)=IRECW
!
          IF(BSTRM)THEN
            IPOS=IWORD*IRECW+1
            WRITE(IU,POS=IPOS)(TFU(I),I=1,ILEN)
            IRECW=IRECW+ILEN
          ELSE
            LRECW=LREC(ISYM)
            I2=0
   10       CONTINUE
            I1=I2+1
            I2=MIN(I2+LRECW,ILEN)
            WRITE(IU,REC=IRECW)(TFU(I),I=I1,I2)
            IRECW=IRECW+1
            IF(I2.LT.ILEN)GO TO 10
          ENDIF
!
        ENDIF
!
      ELSEIF(IRW.GT.0)THEN                                         !READ
!
        IF(BSEQ)THEN
!
   20     IF(IREC(ISYM).EQ.0)REWIND(IU)                      !FIRST READ
!
          IRECR=IREC(ISYM)
!
          NRD=IVEC-IRECR-1
          IF(NRD.GT.0)THEN
            DO I=1,NRD
              READ(IU)
            ENDDO
          ELSEIF(NRD.LT.0)THEN
            IF(-NRD.GT.IVEC)THEN
              IREC(ISYM)=0
              GO TO 20
            ENDIF
            DO I=1,-NRD
              BACKSPACE(IU)
            ENDDO
          ENDIF
          IRECR=IRECR+NRD
!
          IRECR=IRECR+1
          IREC(ISYM)=IRECR
!
          READ(IU)(TFU(I),I=1,ILEN)
!
        ELSE
!
          IPOS0=IPOS1(ISYM)
          IRECR=IPOS2(IPOS0+IVEC)
!
          IF(BSTRM)THEN
            IPOS=IWORD*IRECR+1
            READ(IU,POS=IPOS)(TFU(I),I=1,ILEN)
          ELSE
            LRECR=LREC(ISYM)
            I2=0
   30       CONTINUE
            I1=I2+1
            I2=MIN(I2+LRECR,ILEN)
            READ(IU,REC=IRECR)(TFU(I),I=I1,I2)
            IRECR=IRECR+1
            IF(I2.LT.ILEN)GO TO 30
          ENDIF
!
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE DISKTF
!
!                             +++++++++++++++++++
!
      SUBROUTINE DNAMP(A0,A,E,C,Q,U,Z,X,NMAX,JMAX)
!
!-----------------------------------------------------------------------
!
!     N.R.BADNELL  D.A.M.T.P. CAMBRIDGE
!     ALAN BURGESS D.A.M.T.P. CAMBRIDGE
!
!  SR.DNAMP CALCS THE ASYMP. AMP. & ITS  DERIVS. FOR A COULOMB FUNCTION.
!
!  IT IS CALLED BY:
!    SR.ASSX
!    SR.FCF6
!
!  IT CALLS:
!    SR.DNAQ
!    SR.DNPROD
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
      REAL(WP) Q
!
!      INCLUDE './INCLUDE'
!
      DIMENSION A(*),Y(100),W(100),V(100)
!
!-----------------------------------------------------------------------
!
      X1=DONE/X
      X2=X1*X1
!
      F=-DTWO*Z*X1
      G=-C*X2
      D=-Q*X2*X1
      H=-U*X2*X2
      W0=E+F+G+D+H
      S=DONE
!
      IF(W0.LT.D1M50)THEN
        W0=-W0
        F=-F
        G=-G
        S=-S
        D=-D
        H=-H
      ENDIF
!
      NMAX2=NMAX+2
!
      DO N=1,NMAX2
        EN=N
        F=-EN*F*X1
        G=-(EN+DONE)*G*X1
        D=-(EN+DTWO)*D*X1
        H=-(EN+DTHREE)*H*X1
        W(N)=F+G+D+H
      ENDDO
!
      CALL DNAQ(W0,W,A0,A,-DQUART,NMAX2,IFIVE)
!
      DO J=1,JMAX
!
        CALL DNAQ(A0,A,Y0,Y,-DONE,NMAX,ITHREE)
!
        A0=A(2)
        DO N=1,NMAX
          A(N)=A(N+2)
        ENDDO
!
        CALL DNPROD(A0,A,Y0,Y,V0,V,NMAX)
!
        Y0=W0+V0*S
        DO N=1,NMAX
          Y(N)=W(N)+V(N)*S
        ENDDO
!
        CALL DNAQ(Y0,Y,A0,A,-DQUART,NMAX,IFIVE)
!
      ENDDO
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE DNAMP
!
!                             +++++++++++++++++++
!
      SUBROUTINE DNAQ(A0,A,Y0,Y,Q,NMAX,JSWICH)
!
!-----------------------------------------------------------------------
!
!     ALAN BURGESS D.A.M.T.P. CAMBRIDGE
!
!  SR.DNAQ:
!  GIVEN A0 AND ITS FIRST NMAX DERIVATIVES IN ARRAY A, AND GIVEN Q
!  AND NMAX, CALCULATES Y0 AND ARRAY B, BEING THE VALUE AND FIRST
!  NMAX DERIVATIVES OF (A0)**Q
!
!  FOR PERHAPS GREATER SPEED, YOU MAY SET JSWICH TO 2 IF Q IS -2.0
!   JSWICH TO 3 IF Q IS -DONE
!   JSWICH TO 4 IF Q IS -0.5
!   JSWICH TO 5 IF Q IS -0.25
!   JSWICH TO 6 IF Q IS 0.25
!   JSWICH TO 7 IF Q IS 0.5
!   JSWICH TO 8 IF Q IS 2.0
!  OTHERWISE SET JSWICH TO 1
!
!  IT IS CALLED BY:
!    SR.ASSX
!    SR.DNAMP
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
      REAL(WP) Q
!
!      INCLUDE './INCLUDE'
!
      DIMENSION A(*),Y(*),W(100)
!
!-----------------------------------------------------------------------
!
      if(a0.le.dzero.and.jswich.lt.8)then         !shouldn't get here...
        if(a0.lt.0.and.jswich.le.1.or.jswich.ge.4)then
          write(mw6,*)'dnaq failure, a0.lt.0 ...'
          stop 'dnaq failure, a0.lt.0...'
        endif
        if(a0.eq.dzero.and.jswich.ge.2.and.jswich.le.5)then
          write(mw6,*)'dnaq failure, a0.eq.0 ...'
          stop 'dnaq failure, a0.eq.0...'
        endif
      endif
!
      IF(JSWICH.LE.1.OR.JSWICH.GT.8)THEN
        Y0=A0**Q
      ELSEIF(JSWICH.EQ.2)THEN
        Y0=DONE/(A0*A0)
      ELSEIF(JSWICH.EQ.3)THEN
        Y0=DONE/A0
      ELSEIF(JSWICH.EQ.4)THEN
        Y0=DONE/SQRT(A0)
      ELSEIF(JSWICH.EQ.5)THEN
        Y0=DONE/SQRT(A0)
        Y0=SQRT(Y0)
      ELSEIF(JSWICH.EQ.6)THEN
        Y0=SQRT(A0)
        Y0=SQRT(Y0)
      ELSEIF(JSWICH.EQ.7)THEN
        Y0=SQRT(A0)
      ELSEIF(JSWICH.EQ.8)THEN
        Y0=A0*A0
      ENDIF
!
      W(1)=Q
      C=DONE/A0
      Y(1)=Q*A(1)*Y0*C
!
      DO N=2,NMAX
        Y(N)=Q*Y0*A(N)
        W(N)=Q
        U=-DONE
        J1=N-1
        DO J=1,J1
          V=W(J)
          W(J)=U+W(J)
          U=V
          J2=N-J
          Y(N)=Y(N)+W(J)*A(J)*Y(J2)
        ENDDO
        Y(N)=C*Y(N)
      ENDDO
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE DNAQ
!
!                             *******************
!
      SUBROUTINE DNPROD(A0,A,Y0,Y,C0,C,NMAX)
!
!-----------------------------------------------------------------------
!
!    ALAN BURGESS D.A.M.T.P. CAMBRIDGE
!
!  SR.DNPROD EVALUATES THE ASYMPTOTIC COULOMB AMPLITUDE.
!
!  IT IS CALLED BY:
!    SR.ASSX
!    SR.DNAMP
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION A(20),Y(20),C(20),W(20)
!
!-----------------------------------------------------------------------
!
      C0=A0*Y0
!
      DO N=1,NMAX
        C(N)=A0*Y(N)+Y0*A(N)
      ENDDO
!
      W(1)=DONE
      U=DONE
!
      DO N=2,NMAX
        W(N)=DONE
        JMAX=N-1
        DO J=1,JMAX
          V=W(J)
          W(J)=U+W(J)
          U=V
          J1=N-J
          C(N)=C(N)+W(J)*A(J1)*Y(J)
        ENDDO
      ENDDO
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE DNPROD
!
!                             *******************
!
      SUBROUTINE DWX
!
!-----------------------------------------------------------------------
!
!  SR.DWX CALCULATES EIE COLLISION STENGTHS.
!
!  IT IS CALLED BY:
!    SR.DEIE
!
!  IT CALLS:
!    SR.CADWX
!    SR.DIMUSE
!    SR.DWXBP
!    SR.DWXLS
!    SR.DWX_DEALLOC
!    SR.RADCX0
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam,nproc,                     !par&
!par     &                           comm_barrier,comm_finalize     !par
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CCLSH,  ONLY: NNL
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DMQSS3, ONLY: DSS,MSS,QSS,NADR                         &
     &                        ,NL000=>NL,NL=>NL000
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL,NAD,IRLAST
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_INTS,   ONLY: IXD28
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_QTG,    ONLY: NFI,NFK,NFQ,NTG
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,VSC,XC1,XC2,NPITER
      USE COMMON_NRBDEN, ONLY: DENSI,DENS,TKAYS,NDEN
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,INAST0=>NASTB                            &
     &                        ,INASTJ0=>NASTJB,LFACT,JFACT              &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDW1, ONLY: MXORB,ma0,mb0
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
      USE COMMON_NRBDW4, ONLY: DSPECE,INDEX,JNDEX,NSPECE,NENERG
      USE COMMON_NRBDW5, ONLY: DYY,MENG,NLAG
      USE COMMON_NRBDW6, ONLY: QPOS,QPOS0
      USE COMMON_NRBDW7, ONLY: MNDEX,MRNDX,MTRAN,mlim
      USE COMMON_NRBDW8, ONLY: DYY0,IYY0,MENG0
      USE COMMON_NRBDW9, ONLY: DSPECJ,INDXJ,JNDXJ,NSPECJ,NENERJ
      USE COMMON_NRBDWJ, ONLY: JSYMM,NCHGJ,NADGJ
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBDWP, ONLY: DLAMX,DLAMDX,DLAMQX,JENDX,SCALERX,MCFSTOX
      USE COMMON_NRBDWX, ONLY: LLCH,ITARG,NCHG
      USE COMMON_NRBGRJ, ONLY: NSLJ,NGSLJ
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,INASTJ=>NASTJ                   &
     &                        ,MINJT,MAXJT,NEIGENJ
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBORB, ONLY: IEQ
      USE COMMON_NRBPOT, ONLY: DPOT,TOL,MEND
      USE COMMON_NRBPOT, ONLY: ZS0,ZS,JZNM
      USE COMMON_NRBPOT, ONLY: DERV1,DERV2
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBREL, ONLY: RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0
      USE COMMON_NRBREL, ONLY: DNUK0,DNUK1,DNUK2,DNUK,IXNUK
      USE COMMON_NRBSTO, ONLY: ALF,TEL,MSHELL,MCFSTO,MC,MCFMX,MEXPOT    &
     &                        ,NOCC,NLSTOE,BFIX,BSTO,MXSHLL
!
      use common_nrbuse, only: buguse,buse,busi,btmp
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      ALLOCATABLE :: FRX(:,:,:),PSHFTX(:,:),DRLX(:,:,:)
      ALLOCATABLE :: DZLX(:,:,:),DXTWOX(:,:,:),DETAX(:,:,:)
      ALLOCATABLE :: DNLX(:,:)
!
!-----------------------------------------------------------------------
!
      IF(NZION.EQ.0)RETURN                                   !QUICK EXIT
!
      BKUTOO=KUTOOX.NE.0
      BKUTSS=KUTSSX.NE.-1.AND.MAXJFS.GE.0
      BREL2=ABS(IREL).EQ.2
!
!-----------------------------------------------------------------------
!
      if(nsl0.lt.0)then
        WRITE(MW6,10010)
      elseif(abs(modd).gt.1)then
        WRITE(MW6,10020)
      elseif(abs(modd).le.1)then
        WRITE(MW6,10030)
      endif
!
!-----------------------------------------------------------------------
!
! RECOVER ORBITAL INFO: DPNL, DQNL, DORIG, DEY, DUY & RADIAL MESH ETC.
! VIZ. SOME/ALL OF MODULE /RADF/, /NRBDQE/, /GENINF/ AND COMMON /CMESH/.
! IF BKUTOOX THEN DPNL, DQNL ARE EXTENDED MXORB->MXORB+LCONDW/J
!
      REWIND(MRW11)
      READ(MRW11)MXORB,MJH,MAXRS
!
      MDIM3=MXORB
      IF(BKUTOO)MDIM3=MDIM3+MAX(LCONDW,LCONDWJ)       !BUFFER FOR SR.RAD
      CALL DIMUSE('MAXGR',MDIM3)
!
! EX-COMMON/RADF/
      ALLOCATE(DPNL(MAXRS,MDIM3),DUY(IXD28),DX(MAXRS),DORIG(MXORB),     &
     &         STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWX: ALLOCATION FAILS FOR DPNL,DUY,DX,DORIG'
        NF=0
        GO TO 200
      ENDIF
!
! EX-COMMON/NRBDQE/
      ALLOCATE(DQNL(MAXRS,MDIM3),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWX: ALLOCATION FAILS FOR DQNL'
        NF=0
        GO TO 200
      ENDIF
!
! EX-COMMON/COM1/
      MEND=0
      ALLOCATE(DPOT(MAXRS),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWX: ALLOCATION FAILS FOR DPOT'
        NF=0
        GO TO 200
      ENDIF
!
      IF(BSTO)THEN
!
        IXORB1=MXORB+1
        IXSHLL=MAX(MXORB,MXSHLL)
        IXSHLL1=IXSHLL+1
!
! EX-COMMON/NRBSTO/
        ALLOCATE(ALF(IXORB1),TEL(IXSHLL1),MC(IXSHLL1),MCFSTO(IXORB1),   &
     &           STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: ALLOCATION FAILS FOR STO'
          NF=0
          GO TO 200
        ENDIF
!
      ENDIF
!
      READ(MRW11)(DUY(I),I=1,IXD28),(DEY(K),K=1,MXORB)
      READ(MRW11)(DHNS(J),J=1,MJH),(MNH(J),J=1,MJH)
      READ(MRW11)(DX(M),M=1,MAXRS),(DORIG(K),K=1,MXORB)
      READ(MRW11)((DPNL(M,K),M=1,MAXRS),K=1,MXORB)
      READ(MRW11)((DQNL(M,K),M=1,MAXRS),K=1,MXORB)
      READ(MRW11)DLAMX,DLAMDX,DLAMQX
      IF(BSTO)THEN
        READ(MRW11)MCFMX,MEXPOT,NOCC,NLSTOE,MCFSTOX,NOCCX
        IF(NOCC.NE.0)THEN
          IF(NOCCX.EQ.0)THEN                    !CASE UNIQUE POTENTIAL
            READ(MRW11)MEND
            READ(MRW11)(DPOT(M),M=1,MAXRS)
          ELSE
            IXSHLL=ABS(NOCC)
            READ(MRW11)(TEL(I),I=1,IXSHLL)      !CASE NEW CONTINUUM
          ENDIF
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
! "LOCAL"
!
! EX-COMMON/NRBDEN/ (N.B. USED MORE GENERALLY)
      ALLOCATE(VSC(MAXRS),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWX: ALLOCATION FAILS FOR VSC'
        NF=0
        GO TO 200
      ENDIF
!
! EX-COMMON/NRBPLS/
! CURRENTLY NO DW PLASMA LOOP (NDEN=1), SO INHERIT LAST DENE,TKAY SET-UP
!      IF(NDEN.GT.1)ALLOCATE(DENSI(NDEN),DENS(NDEN),TKAYS(NDEN))
!
! EX-COMMON/NRBREL/
      IF(BREL)THEN
        ALLOCATE(DNUK0(IXNUK),DNUK1(IXNUK),DNUK2(IXNUK),DNUK(IXNUK),    &
     &           STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: ALLOCATION FAILS FOR DNUK0,DNUK1,DNUK2,DNUK'
          NF=0
          GO TO 200
        ENDIF
!      ENDIF
!
! EX-COMMON/NRBSPL/
!      IF(BREL)THEN
        ALLOCATE(DERV1(MAXRS),DERV2(MAXRS),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: ALLOCATION FAILS FOR DERV1,DERV2'
          NF=0
          GO TO 200
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
! READ SCATTERING ENERGIES AND INDEX INTERACTING ENERGY PAIRS.
! GENERATE THE UNIQUE CONTINUUM DW POTENTIAL AND CHECK THE RADIAL GRID.
!
      CALL RADCX0
!
      IF(NF.LE.0)GO TO 200
      IF(IRL.EQ.0.AND.NL000.EQ.0)THEN
        WRITE(MW6,10040)
        GO TO 200
      ENDIF
!
!-----------------------------------------------------------------------
!
! initialize flag of use of interpolation energies.
! more detailed output can be obtained by setting:
!      buguse=.true.
!
      do m2=1,meng
        buse(m2)=.false.
        if(buguse)then
          do m1=1,meng
            busi(m1,m2)=.false.
          enddo
        endif
      enddo
      do m0=1,meng0
        m=iyy0(m0)
        buse(m)=.true.
        if(buguse)busi(m,m)=.true.
      enddo
!
!-----------------------------------------------------------------------
!
! LOCAL
!
! NOW ALLOCATE BASED ON KNOWN NO OF POINTS (MAXRS), ENERGIES (MENG),
! ENERGY PAIRS (MTRAN) AND INTEGRALS (IRL), FOR LSTORE+1 TOTAL L-VALUES.
! LS COUPLING ONLY REQUIRES LSTORE=0.
!
      if(abs(modd).gt.1)then
        LSTORE=0
      else
        LSTORE=QCS0+1
      endif
!
      MDIM0=MTRAN
      MDIM1=MAXRS
      IF(BREL2)MDIM1=2*MDIM1
      MDIM2=MENG
      MDIM3=MAX(LCONDW,LCONDWJ)
      MDIM4=MAX(IRL,IONE)
      MDIM5=LSTORE
!
      ALLOCATE(FRX(MDIM1,MDIM2,MDIM3),PSHFTX(MDIM2,MDIM3),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWX: ALLOCATION FAILS FOR DFRX,PSHFTX'
        NF=0
        GO TO 100
      ENDIF
!
      ALLOCATE(DRLX(MDIM4,MDIM0,0:MDIM5),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWX: ALLOCATION FAILS FOR DRLX'
        NF=0
        GO TO 100
      ENDIF
!
      IF(BKUTOO)THEN
        MDIM6=MDIM0
        MDIM7=MDIM4
        MDIM8=MDIM5
      ELSE
        MDIM6=1
        MDIM7=1
        MDIM8=0
      ENDIF
!
      ALLOCATE(DZLX(MDIM7,MDIM6,0:MDIM8),DXTWOX(MDIM7,MDIM6,0:MDIM8),   &
     &         DETAX(MDIM7,MDIM6,0:MDIM8),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWX: ALLOCATION FAILS FOR DZLX,DXTWOX,DETAX'
        NF=0
        GO TO 100
      ENDIF
!
      IF(BKUTSS)THEN
        MDIM9=MDIM0
        MDIM10=MAX(NL000,IONE)
      ELSE
        MDIM9=1
        MDIM10=1
      ENDIF
!
      ALLOCATE(DNLX(MDIM10,MDIM9),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWX: ALLOCATION FAILS FOR DNLX'
        NF=0
        GO TO 100
      ENDIF
!
      if(nsl0.lt.0)then
!
!-----------------------------------------------------------------------
!
! SR.CADWX CALCULATES EIE (NR) COLLISION STRENGTHS IN CA-COUPLING
!
        CALL CADWX(FRX,PSHFTX,DRLX,MDIM0,MDIM1,MDIM2,MDIM3,MDIM4,MDIM5)
!
        IF(NF.LE.0)GO TO 100
!
!-----------------------------------------------------------------------
!
      elseif(abs(modd).gt.1)then
!
!-----------------------------------------------------------------------
!
! SR.DWXLS CALCULATES EIE NR (+2NFS) COLLISION STRENGTHS IN LS-COUPLING
!
        CALL DWXLS(FRX,PSHFTX,DRLX,MDIM0,MDIM1,MDIM2,MDIM3,MDIM4,MDIM5, &
     &             DZLX,DXTWOX,DETAX,MDIM6,MDIM7,MDIM8)
!
        IF(NF.LE.0)GO TO 100
!
!-----------------------------------------------------------------------
!
      elseif(abs(modd).le.1)then
!
!-----------------------------------------------------------------------
!
! SR.DWXBP CALCULATES EIE BP (+2FS) COLLISION STRENGTHS IN JK-COUPLING
!
        CALL DWXBP(FRX,PSHFTX,DRLX,MDIM0,MDIM1,MDIM2,MDIM3,MDIM4,MDIM5, &
     &             DZLX,DXTWOX,DETAX,MDIM6,MDIM7,MDIM8,DNLX,MDIM9,      &
     &             MDIM10)
!
        IF(NF.LE.0)GO TO 100
!
!-----------------------------------------------------------------------
!
      endif
!                       write use of interpolation energies
      nskp=0
      do m2=1,meng
        if(.not.buse(m2))then
          write(mw0,10050)m2,dyy(m2)
          write(mw6,10050)m2,dyy(m2)
        elseif(buguse)then
          do m1=1,meng
            btemp1=buse(m1).and.btmp(m1,m2)
            btemp2=.not.busi(m1,m2).and..not.busi(m2,m1)
            if(btemp1.and.btemp2)then
              write(mw6,*)'INTEGRAL PAIR NOT USED',m1,m2
              nskp=nskp+1
            endif
          enddo
        endif
      enddo
      if(nskp.gt.0)write(mw6,10060)nskp,mtran
!
!
!-----------------------------------------------------------------------
!
! LOCAL DE-ALLOCATES
!
  100 CONTINUE
!
      IF(ALLOCATED(FRX))THEN
!
        DEALLOCATE(FRX,PSHFTX,DRLX,STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR FRX,PSHFTX,DRLX'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(DZLX))THEN
!
        DEALLOCATE(DZLX,DXTWOX,DETAX,STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR DZLX,DXTWOX,DETAX'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(DNLX))THEN
!
        DEALLOCATE(DNLX,STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR DNLX'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
! DE-ALLOCATE EVERYTHING ELSE
!
  200 CONTINUE
!
      CALL DWX_DEALLOC
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(///1X,136('-')//50X,'*** COLLISION HAMILTONIAN (CA) ***'// &
     &       1X,136('-')//)
10020 FORMAT(///1X,136('-')//50X,'*** COLLISION HAMILTONIAN (LS) ***'// &
     &       1X,136('-')//)
10030 FORMAT(///1X,136('-')//50X,'*** COLLISION HAMILTONIAN (BP) ***'// &
     &       1X,136('-')//)
10040 FORMAT(//'*** NO INTERACTIONS/CHANNELS - BAILING-OUT ***')
10050 FORMAT('*** INTERPOLATION ENERGY',I3,' NOT USED E=',F9.3)
10060 FORMAT(/' NOTE:',I3,' OUT OF',I4,                                 &
     &       ' ENERGY INTEGRAL PAIRS WERE NOT USED')
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE DWX
!
!                             *******************
!
      SUBROUTINE DWX_DEALLOC
!
!-----------------------------------------------------------------------
!
!  SR.DWX_DEALLOC DEALLOCATES ALL ARRAYS STILL OPEN AT THE COMPLETION
!  OF SR.DWX
!
!  IT IS CALLED BY:
!    SR.DWX
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CCLSH,  ONLY: NNL
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DMQSS3, ONLY: DSS,MSS,QSS,NADR
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL,NAD,IRLAST
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_QTG,    ONLY: NFI,NFK,NFQ,NTG
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,VSC,XC1,XC2,NPITER
      USE COMMON_NRBDEN, ONLY: DENSI,DENS,TKAYS,NDEN
      USE COMMON_NRBDQE, ONLY: DQNL
!      USE COMMON_NRBDW,  ONLY: IDW
!     &                        ,INAST0=>NASTB
!     &                        ,INASTJ0=>NASTJB,LFACT,JFACT
!     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO
!     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDW1, ONLY: MXORB,ma0,mb0,MSTAT
!      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
      USE COMMON_NRBDW4, ONLY: DSPECE,INDEX,JNDEX,NSPECE,NENERG
      USE COMMON_NRBDW5, ONLY: DYY,MENG,NLAG
      USE COMMON_NRBDW6, ONLY: QPOS,QPOS0
      USE COMMON_NRBDW7, ONLY: MNDEX,MRNDX,MTRAN,mlim
      USE COMMON_NRBDW8, ONLY: DYY0,IYY0,MENG0
      USE COMMON_NRBDW9, ONLY: DSPECJ,INDXJ,JNDXJ,NSPECJ,NENERJ
      USE COMMON_NRBDWJ, ONLY: JSYMM,NCHGJ,NADGJ
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBDWX, ONLY: LLCH,ITARG,NCHG
      USE COMMON_NRBGRJ, ONLY: NSLJ,NGSLJ
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,INASTJ=>NASTJ                   &
     &                        ,MINJT,MAXJT,NEIGENJ
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBORB, ONLY: IEQ
      USE COMMON_NRBPOT, ONLY: DPOT,TOL,MEND
      USE COMMON_NRBPOT, ONLY: ZS0,ZS,JZNM
      USE COMMON_NRBPOT, ONLY: DERV1,DERV2
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBREL, ONLY: RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0
      USE COMMON_NRBREL, ONLY: DNUK0,DNUK1,DNUK2,DNUK,IXNUK
      USE COMMON_NRBSTO, ONLY: ALF,TEL,MSHELL,MCFSTO,MC,MCFMX,MEXPOT    &
     &                        ,NOCC,NLSTOE,BFIX,BSTO,MXSHLL
!
      use common_nrbuse, only: buguse,buse,busi,btmp
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
! "LOCAL" DE-ALLOCATES
!
! EX-COMMON/COM1/
      IF(ALLOCATED(DPOT))THEN
        DEALLOCATE(DPOT,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR DPOT'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBSTO/
      IF(ALLOCATED(ALF))THEN
        DEALLOCATE(ALF,TEL,MC,MCFSTO,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'dwx: DE-ALLOCATION FAILS FOR STO'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/RADF/
      IF(ALLOCATED(DPNL))THEN
        DEALLOCATE(DPNL,DUY,DX,DORIG,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR DPNL,DUY,DX,DORIG'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBDQE/
      IF(ALLOCATED(DQNL))THEN
        DEALLOCATE(DQNL,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR DQNL'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBDEN/
      IF(ALLOCATED(VSC))THEN
        DEALLOCATE(VSC,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR VSC'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBPLS/
      IF(ALLOCATED(TKAYS))THEN
        DEALLOCATE(DENSI,DENS,TKAYS,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR DENSI,DENS,TKAYS'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBREL/
      IF(ALLOCATED(DNUK0))THEN
        DEALLOCATE(DNUK0,DNUK1,DNUK2,DNUK,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)                                                  &
     &             'DWX: DE-ALLOCATION FAILS FOR DNUK0,DNUK1,DNUK2,DNUK'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBSPL/
      IF(ALLOCATED(DERV1))THEN
        DEALLOCATE(DERV1,DERV2,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR DERV1,DERV2'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
! "NON-LOCAL" DE-ALLOCATES
!
! EX-COMMON/CCLSH/
      IF(ALLOCATED(NNL))THEN
        DEALLOCATE(NNL,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR NNL'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/DBD2/
      IF(ALLOCATED(QCP))THEN
        DEALLOCATE(QCP,QCG,QL,QN,DEY,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR QCP,QCG,QL,QN,DEY'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/DXRL/
      IF(ALLOCATED(DRK))THEN
        DEALLOCATE(DRK,QRL,NRK,NAD,IRLAST,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR DRK,QRL,NRK,NAD'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/MQVC/
      IF(ALLOCATED(NEL))THEN
        DEALLOCATE(NEL,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR NEL'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBDW1/
      IF(ALLOCATED(MSTAT))THEN
        DEALLOCATE(MSTAT,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR MSTAT'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBDW4/
      IF(ALLOCATED(DSPECE))THEN
        DEALLOCATE(DSPECE,INDEX,JNDEX,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR DSPECE,INDEX,JNDEX'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBDW5/
      IF(ALLOCATED(DYY))THEN
        DEALLOCATE(DYY,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR DYY'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBDW6/
      IF(ALLOCATED(QPOS))THEN
        DEALLOCATE(QPOS,QPOS0,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: ALLOCATION FAILS FOR QPOS'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBDW7/
      IF(ALLOCATED(MNDEX))THEN
        DEALLOCATE(MNDEX,MRNDX,mlim,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR MNDEX,MRNDX,mlim'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBDW8/
      IF(ALLOCATED(IYY0))THEN
        DEALLOCATE(IYY0,DYY0,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR IYY0,DYY0'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBLS/
      IF(ALLOCATED(LSPI))THEN
        DEALLOCATE(LSPI,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR LSPI,NLSPI'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBORB/
      IF(ALLOCATED(IEQ))THEN
        DEALLOCATE(IEQ,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'SR.DWX: ALLOCATION FAILS FOR IEQ'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! ex-common/nrbuse/
      if(allocated(buse))then
        deallocate(buse,stat=ierr)
        if(ierr.ne.0)then
          write(mw0,*)'dwx: de-allocation fails for buse'
          if(nf.gt.0)nf=0
        endif
      endif
!
      if(buguse)then
!
        if(allocated(busi))then
          deallocate(busi)
          if(ierr.ne.0)then
            write(mw0,*)'dwx: de-allocation fails for busi'
            if(nf.gt.0)nf=0
          endif
        endif
!
        if(allocated(btmp))then
          deallocate(btmp)
          if(ierr.ne.0)then
            write(mw0,*)'dwx: de-allocation fails for btmp'
            if(nf.gt.0)nf=0
          endif
        endif
!
      endif
!
      IF(NSL0.GT.0)THEN
!
! EX-COMMON/QTG/
        IF(ALLOCATED(NFI))THEN
          DEALLOCATE(NFI,NFK,NFQ,NTG,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR  NFI,NFK,NFQ,NTG'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/TERMS/
        IF(ALLOCATED(NSL))THEN
          DEALLOCATE(NSL,QSI,QLI,QPI,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR NSL,QSI,QLI,QPI'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/NRBDWM/
        IF(ALLOCATED(NMETAG))THEN
          DEALLOCATE(NMETAG,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR NMETAG'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/NRBDWX/
        IF(ALLOCATED(LLCH))THEN
          DEALLOCATE(LLCH,ITARG,NCHG,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR LLCH,ITARG,NCHG'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/NRBGRP/
        IF(ALLOCATED(NGRPI))THEN
          DEALLOCATE(NGRPI,NADG,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'DWX: ALLOCATION FAILS FOR NGRPI,NADG'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/NRBNF1/
        IF(ALLOCATED(DEK))THEN
          DEALLOCATE(DEK,BFALL,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR  DEK, BFALL'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
      ENDIF
!
      IF(NJO.GT.0)THEN
!
! EX-COMMON/JSPOR/
        IF(ALLOCATED(NRR))THEN
          DEALLOCATE(NRR,NT,JN,NGR,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR NJO,NRR,NT,JN,NGR'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/NRBDW9/
        IF(ALLOCATED(DSPECJ))THEN
          DEALLOCATE(DSPECJ,INDXJ,JNDXJ,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)                                                &
     &                 'DWX: DE-ALLOCATION FAILS FOR DSPECJ,INDXJ,JNDXJ'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/NRBDWM/
        IF(ALLOCATED(NMETGJ))THEN
          DEALLOCATE(NMETGJ,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'DWX: ALLOCATION FAILS FOR NMETGJ'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/NRBDWJ/
        IF(ALLOCATED(JSYMM))THEN
          DEALLOCATE(JSYMM,NCHGJ,NADGJ,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR JSYMM,NCHGJ,NADGJ'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/NRBGRJ/
        IF(ALLOCATED(NSLJ))THEN
          DEALLOCATE(NSLJ,NGSLJ,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR NSL0,NGSLJ'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/NRBJ/
        IF(ALLOCATED(JPI))THEN
          DEALLOCATE(JPI,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR JPI,NJPI'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/DMQSS3/
        IF(ALLOCATED(DSS))THEN
          DEALLOCATE(DSS,MSS,QSS,NADR,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'DWX: DE-ALLOCATION FAILS FOR  DSS,MSS,QSS,NADR'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE DWX_DEALLOC
!
!                             *******************
!
      SUBROUTINE DWXBP(FRX,PSHFTX,DRLX,MDIM0,MDIM1,MDIM2,MDIM3,MDIM4    &
     &                ,MDIM5,DZLX,DXTWOX,DETAX,MDIM6,MDIM7,MDIM8        &
     &                ,DNLX,MDIM9,MDIM10)
!
!-----------------------------------------------------------------------
!
!  SR.DWXBP WRAPPER
!
!  IT IS CALLED BY:
!    SR.DWX
!
!  IT CALLS:
!    SR.DWXBP_DAXPY
!    SR.DWXBP_DDOT
!
!-----------------------------------------------------------------------
!
      USE COMMON_MINIM,  ONLY: XMIX
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION FRX(MDIM1,MDIM2,MDIM3),PSHFTX(MDIM2,MDIM3)              &
     &         ,DRLX(MDIM4,MDIM0,0:MDIM5)                               &
     &         ,DZLX(MDIM7,MDIM6,0:MDIM8)                               &
     &         ,DXTWOX(MDIM7,MDIM6,0:MDIM8)                             &
     &         ,DETAX(MDIM7,MDIM6,0:MDIM8)                              &
     &         ,DNLX(MDIM10,MDIM9)
!
!
      IF(XMIX.LT.DZERO)THEN
        CALL DWXBP_DDOT(FRX,PSHFTX,DRLX,MDIM0,MDIM1,MDIM2,MDIM3,MDIM4,  &
     &                  MDIM5,DZLX,DXTWOX,DETAX,MDIM6,MDIM7,MDIM8,DNLX, &
     &                  MDIM9,MDIM10)
      ELSE
        CALL DWXBP_DAXPY(FRX,PSHFTX,DRLX,MDIM0,MDIM1,MDIM2,MDIM3,MDIM4, &
     &                   MDIM5,DZLX,DXTWOX,DETAX,MDIM6,MDIM7,MDIM8,DNLX,&
     &                   MDIM9,MDIM10)
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE DWXBP
!
!                             *******************
!
      SUBROUTINE DWXBP_DAXPY                                            &
     &                (FRX,PSHFTX,DRLX,MDIM0,MDIM1,MDIM2,MDIM3,MDIM4    &
     &                ,MDIM5,DZLX,DXTWOX,DETAX,MDIM6,MDIM7,MDIM8        &
     &                ,DNLX,MDIM9,MDIM10)
!
!-----------------------------------------------------------------------
!
!  SR.DWXBP_DAXPY
!    CALCULATES EIE BP (+2FS) COLLISION STRENGTHS IN JK-COUPLING
!
!  IT IS CALLED BY:
!    SR.DWXBP
!
!  IT CALLS:
!    SR.DATE_AND_TIME (SYSTEM)
!    SR.FSINTX
!    FN:NCHAJK
!    SR.NRB_TIME
!    SR.PQ
!    SR.PQLAP
!    FN.QPTLS
!    FN.QPTLSJ
!    SR.RADCNX
!    FN.SJS
!    SR.SLATRX
!    SR.TOP1
!    SR.TOP2
!    FN.XINT
!
!  IT CONTAINS:
!    FN.ICOL
!    FN.IROW
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam,comm_barrier               !par&
!par     &                          ,sp_mpi,izero_mpi               !par
!par      use mpi, only : mpi_real4,mpi_real8,mpi_integer           !par&
!par     &               ,mpi_sum,mpi_comm_world                    !par
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DMQSS3, ONLY: DSS,MSS,QSS,NADR                         &
     &                        ,NL000=>NL,NL=>NL000
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL,NAD
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR
      USE COMMON_MINIM,  ONLY: BECOR
      USE COMMON_MINIM,  ONLY: XMIX
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_QTG,    ONLY: NFI,NFK,NFQ
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      use common_misc,   only: ione1,ione0
      use common_misc,   only: iw,iwp,btime,btimex
      use common_misc,   only: badas
!
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,INAST0=>NASTB                            &
     &                        ,INASTJ0=>NASTJB,LFACT,JFACT              &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDW1, ONLY: MXORB,ma0,mb0
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
      USE COMMON_NRBDW4, ONLY: DSPECE,INDEX,JNDEX,NSPECE,NENERG
      USE COMMON_NRBDW5, ONLY: DYY,MENG,NLAG
      USE COMMON_NRBDW6, ONLY: QPOS,QPOS0
      USE COMMON_NRBDW7, ONLY: MNDEX,MRNDX,MTRAN,mlim
      USE COMMON_NRBDW8, ONLY: DYY0,IYY0,MENG0
      USE COMMON_NRBDW9, ONLY: DSPECJ,INDXJ,JNDXJ,NSPECJ,NENERJ
      USE COMMON_NRBDWJ, ONLY: JSYMM,NCHGJ,NADGJ,NCHSJ
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBDWX, ONLY: LLCH,ITARG,NCHG
      USE COMMON_NRBGRJ, ONLY: NSLJ,NGSLJ
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,INASTJ=>NASTJ                   &
     &                        ,MINJT,MAXJT,NEIGENJ
      USE COMMON_NRBKUT, ONLY: KCUTX,LSKUT,NASTK
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
      USE COMMON_NRBREL, ONLY: BREL
      USE COMMON_NRBRN3, ONLY: MXNXB,MXNXB1
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (MXLEN=200)                                 !CARD LENGTH
!
      PARAMETER (MXD13=500)
!
      INTEGER(SP) QPTLS,QPTLSJ                 !DO NOT USE SHORT INTEGER
!
      INTEGER(SP) SA,SAP
!par!                                                               !par
!par      integer(sp_mpi) itmp4,ier4,my_mpi_real                    !par
!par!                                                               !par
!par      real(rp) omsend,omrecv                                    !par
!
      REAL(RP) OMEGA,E1M10
!
      PARAMETER (E1M10=1.E-10_RP)
      PARAMETER (XBTEST=DFIVE)          !APPLY btop ONLY FOR X.GT.XBTEST
!
      CHARACTER(LEN=3) IEXP,IEXP0,IEXP1
      CHARACTER(LEN=4) CARD4
      CHARACTER(LEN=5) XMANT,XMANT0,XMANT1
      CHARACTER(LEN=8) DATE
      CHARACTER(LEN=15) F767
      CHARACTER(LEN=29) F713
      CHARACTER(LEN=35) F762
      CHARACTER(LEN=44) F761
      CHARACTER(LEN=MXLEN) CARD
!
      ALLOCATABLE :: RHO1(:,:),RHO2(:,:),OMEGA(:,:),TFU(:)              &
     &              ,TEMP(:,:),OMGINF(:),KACT(:,:),KTMP(:)
!par      allocatable :: omsend(:),omrecv(:)                        !par
!
      allocatable :: rhom(:,:),wrkp(:),wrkq(:),iwrkn(:),iwrkl(:)        &
     &              ,work(:)
!
      allocatable :: bswap(:),bswapj(:)
!
      ALLOCATABLE :: IEXP(:),XMANT(:)
      ALLOCATABLE :: NADRUG(:),NTGJ(:),TMP(:,:),OMP(:)                  &
     &              ,DWRK(:),IWRK3(:),IWRK4(:)
!
      ALLOCATABLE :: QPX(:),QPX0(:),QPOSJ(:)
!
      ALLOCATABLE :: PSHFT0(:)
!
      DIMENSION FRX(MDIM1,MDIM2,MDIM3),PSHFTX(MDIM2,MDIM3)              &
     &         ,DRLX(MDIM4,MDIM0,0:MDIM5)                               &
     &         ,DZLX(MDIM7,MDIM6,0:MDIM8)                               &
     &         ,DXTWOX(MDIM7,MDIM6,0:MDIM8)                             &
     &         ,DETAX(MDIM7,MDIM6,0:MDIM8)                              &
     &         ,DNLX(MDIM10,MDIM9)
!
      dimension ntest(1,1)                   !check channel set-up
!
!-----------------------------------------------------------------------
!
!      ICOL(ILI,ILF,IONE1)=((ILF-1)*(ILF-2*IONE1))/2+ILI
!      IROW(ILI,ILF,IONE1,NENG)=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE1))/2
!
!-----------------------------------------------------------------------
!
! flag write of cross sections to adf04ic instead of collision strengths
! - this is for test purposes only.
!
      bcrossx=.false.                !.true.
!
      if(bcrossx)then
!
        write(mw0,*)' *** Attention, adf04ic contains cross sections!'
        write(mw6,*)' *** Attention, adf04ic contains cross sections!'
!
        xconv=done                   !pi*a_0^2
        xconv=xconv*acos(-done)      !a_0^2
        xconv=xconv*28.003D0         !Mbarns
        xconv=xconv*1.D6             !barns
!
      endif
!
! flag write of "OMEGA" file - this is by final scattered energy and so
! *not* directly usable by R-matrix utility codes such as xtrct/adasexj.
! this is somewhat historic as adasexj *does* read/process dw adf04 file
!
      bomega=.false.
!
! elastic switch (normally ione1=1, no elastic. ione1=0 inc elastic)
! now set by user in algeb, and passed thru /nrbdwm/ as needed.
!
!old  ione1=1
!
! test: DO NOT CHANGE!
!old  ione0=0                !algxls/fs ione1, elastic needed for mixing
!
! some test set-up switches that user joe should not need to touch.
!
      bht=.false.                  !.true. for bht(1970) test comparison
!
! set (approx) unitarity switch
!
      bunit=.true.
      if(bht)bunit=.false.
!
! set approximation-ii unitarization switch - needs the full rho-matrix
! (.and.. not.bthrsh, i.e. lvmax.lt.0) only coded for F95.
! currently, in principle, only for use at medium to high energies
! since it still works with the final scattered energy, but seems to
! work well down to low-e as well - strongest coupling with nearby
! states, i.e. ones calculated at the same/similar relative energy.
!
      bunit2=nmetaj.ge.nspecj.and.ione1.eq.0.and.lvmax.lt.0
!
! set print of approx r(tau=0)-matrix as opposed to rho(tau)-matrix
! *MUST* use full T=-2iR/(1-iR) if converting via R-matrix.   (not done)
! can only use weak coupling T=-2i*rho for rho-matrix -see bunit2 above.
!
      brmx=.false.
      if(jprint.eq.4)brmx=.true.
!
! set mixing switch, can test interpolation followed by mixing (false).
!
      bmix=xmix.ge.dzero                !default xmix->.true.
      xmix=abs(xmix)
!
! flag effect of missing phase shifts.
!
      if(kutssx.eq.-1)then
        if(ione1.eq.0)write(mw6,10320)
        if(brmx)write(mw6,10330)
        if(bunit2)write(mw6,10340)
      endif
!
! checks channel set-up (needs ntest dimensioned)
!
      bntest=.false.                    !ione1.eq.0.and.jprint.ge.2
!
      bntest=bntest.and.nmetaj.ge.nspecj
!
! if bcor then we have algebraic correlation, and we know how ordered
!
      bcor=kmax*kcut.ne.kcut*kcut
!
! if becor then we have correlation by energy, and we know not where, so
!
      beqgrpl0=.not.becor                       !false for full li=lf mx
!
! if only algebraic then can reduce memory requirement  NAD/J(NCOR/J)
!
      bcorr=bcor.and..not.becor.and.kcutx.ge.0
!par!                                                               !par
!par      if(rp.eq.4)then                                           !par
!par        my_mpi_real=mpi_real4                                   !par
!par      elseif(rp.eq.8)then                                       !par
!par        my_mpi_real=mpi_real8                                   !par
!par      else                                                      !par
!par        if(iam.eq.0)write(iw,*)'error rp precsion =',rp         !par
!par        go to 5500                                              !par
!par      endif                                                     !par
!
!-----------------------------------------------------------------------
!
      btimep=btimex                                        !for iam.ne.0
      if(btimex)then
!        if(abs(modd).le.1)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Starting proc',iam,' for dwxbp'           !par
!par        else                                                    !par
        write(iw,*)'Starting dwxbp'
!par        endif                                                   !par
!        endif
        call nrb_time(timei)
        time0=timei
      endif
      btimet=btimex  !.false.                             !debug timings
!
! INITIALIZATIONS
!
      PI=ACOS(-DONE)
      TPI=DTWO*PI
!
      NZA2=MAX(NZION-MION,IONE)
      NZA2=NZA2*NZA2
      TOLO=E1M10/NZA2
!
      BPRNT2=JPRINT.GE.2                    !FOR DETAILED OMEGA PRINTOUT
      BPRNT3=JPRINT.GE.3                      !FOR DETAILED RHO PRINTOUT
      BPRNT0=JPRINT.NE.-3
!
      KOLDOO=KUTOOX
      BKUTOO=KUTOOX.NE.0
!
      BKUTSS=KUTSSX.NE.-1
!
      LAPAK=1                                                    !LAPACK
!
      IF(NZION.EQ.MION)THEN
        NZA=0
        DZ2=DONE
      ELSE
        NZA=NZION-MION
        DZ2=NZA*NZA
      ENDIF
!
      LOLD=-1                                          !INITIAL FOR QPOS
      JOLD=-2                                         !INITIAL FOR QPOSJ
!
      IF(MAXJT.GE.0)THEN
        IF(LRGLAM.GT.MAXJT)THEN
          WRITE(MW0,*)'*** SR.DWXBP: LRGLAM.GT.MAXJT, SO NO TOP-UP'
          LRGLAM=-1
        ELSE
          IF(LRGLAM.EQ.-999)LRGLAM=MAXJT
        ENDIF
        IF(LRGLAM.EQ.0)LRGLAM=-1
      ENDIF
!
      IF(LRGLAM.GT.1)THEN        !SET L WHERE DIPOLE TOP-UP NEEDS CHECKS
        LRGLMN=LRGLAM-2*(QCL0+QCS0)
      ELSE
        LRGLMN=1000
      ENDIF
!
      btop=btop.and.lrglam.ge.0
!
      jktest=2*maxlx+QCS0+1                           !max J for K.ne.K'
!
      MPOSC=MXORB+(LCONDWJ-1)/2-(LCONDW-1)/2               !BUFFER SPACE
!
! SMALL LOCAL MEMORY
!
      MXD4=MAX(MENG,10_SP)+3
      ALLOCATE(IEXP(0:MXD4),XMANT(0:MXD4))
      ALLOCATE(TMP(MENG,MENG),OMP(MENG))
      ALLOCATE(NADRUG(NJO),NTGJ(NJO))
      ALLOCATE(QPX(0:MDIM5),QPX0(0:MDIM5),QPOSJ(LCONDWJ))
!
      ixd13=mxd13
      allocate(bswap(ixd13))                                      !small
      if(maxjfs.ge.0)then
        jxd13=2*mxd13
        allocate(bswapj(jxd13))                                   !small
      endif
!
! SET POINTER TO START OF GROUP IN MIXING COEFFICIENT ARRAY TFU,
! AND FOR MAPPING TERMS OF A J-GROUP TO ABSOLUTE LEVEL INDEX.
!
      MC=0
      NCMX=0
      NSUM=0
      DO N=1,NJO
        NADRUG(N)=MC
        NTGJ(N)=NSUM
        NC=NT(N)
        NCMX=MAX(NCMX,NC)
        MC=MC+NC*NC
        NSUM=NSUM+NC
      ENDDO
!
! RECOVER TARGET MIXING COEFFICIENTS
!
      READ(MRW10)NCTOT
!
      if(nctot.ne.mc)stop 'dwxbp:nctot index error'    !shouldn't happen
!
      ALLOCATE(TFU(NCTOT),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXBP: ALLOCATION FAILS FOR TFU'
        NF=0
        GO TO 800
      ENDIF
!
      READ(MRW10)(TFU(I),I=1,NCTOT)
!
! LOOK FOR LAST SPECTROSCOPIC ENERGY
!
!      NSPECL=0
!      DO N=1,NENERJ
!        NSPECL=MAX(NSPECL,JNDXJ(N))
!      ENDDO
!
! USE ROWWISE TO SIMPLY REDUCE NDIM2 IF NMETAJ.LT.NSPECJ
!
      NOMTG=NCMX*NCMX                               !NEED ALL FOR MIXING
      nmin=min(NMETAJ,NSPECJ)
      NOMWRT=IROW(nmin,NSPECJ,ione1,NSPECJ)                     !ROWWISE
      NOMWR0=NOMWRT
!
!test    if(ione1.eq.1)nomwr0=nomwr0+nmin      !incase ione1=0 in diagfs
!
!
      BTHRSH=LVMAX.GE.0
      IF(BTHRSH)THEN
        MOGGY=LVMAX+1-LVMIN
        ALLOCATE(PSHFT0(LVMIN:LVMAX))                             !SMALL
      ELSE
        MOGGY=MENG0
        ALLOCATE(PSHFT0(LVMIN:LVMIN))                             !SMALL
      ENDIF
!
      MX=MTRAN
      if(.not.bmix)mx=meng0
!
      ALLOCATE(RHO1(MTRAN,NOMTG),RHO2(MX,NOMTG),TEMP(MX,NCMX),          &
     &         OMGINF(NOMWR0),OMEGA(MOGGY,NOMWRT),STAT=IERR)
!par!                                                               !par
!par      allocate(omsend(nomwrt),omrecv(nomwrt),stat=ierr)         !par
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXBP: ALLOCATION FAILS FOR RHO,OMEGA,TEMP'
        NF=0
        GO TO 700
      ENDIF
!
      DO N=1,NOMWRT
        OMGINF(N)=DZERO
        DO M=1,MOGGY
          OMEGA(M,N)=0
        ENDDO
      ENDDO
!
! RECOVER INFINITE ENERGY INFO (ROWWISE)
!
      IF(IUNIT(MRW24).EQ.0)THEN                !ADF04 WILL BE INCOMPLETE
        WRITE(MW6,*)'NO INFINITE ENERGY FILE="OMGINFIC"...'
        WRITE(MW0,*)'NO INFINITE ENERGY FILE ON UNIT=',MRW24
        IF(LRGLAM.GE.0)THEN
          WRITE(MW6,*)'NO INFINITE ENERGY FILE INFO, CANNOT TOP-UP'
          WRITE(MW0,*)'NO INFINITE ENERGY FILE INFO, CANNOT TOP-UP'
          NF=-1
          GO TO 600
        ELSE
          GO TO 100
        ENDIF
      ELSEIF(IUNIT(MRW24).LT.0)THEN
        OPEN(MRW24,FILE='OMGINFIC',STATUS='OLD',ERR=100)
        IUNIT(MRW24)=1
      ELSE                               !SERIAL SHOULD NOT BE HERE
        REWIND(MRW24)                       !BUT PAR ALREADY OPEN
!par        if(iam.eq.0)then                                        !par
        stop 'dwxbp: omginfbp confusion'
!par        endif                                                   !par
      ENDIF
!
      READ(MRW24,*)NZDUM,MDUM
      READ(MRW24,*)NSPEC0,MENGB,NOMWR0
!
      IF(NSPEC0.NE.NSPECJ)THEN                   !SHOULD NOT HAPPEN, NOW
        WRITE(MW6,*)'DWXBP: INFINITE ENERGY TARGET MISMATCH',NSPEC0,    &
     &              NSPECJ
        WRITE(MW0,*)'DWXBP: INFINITE ENERGY TARGET MISMATCH'
        NF=-1
        GO TO 600
      ENDIF
!
      ALLOCATE(DWRK(NSPEC0),IWRK3(NSPEC0),IWRK4(NSPEC0))
!
      READ(MRW24,*)(IDUM0,IWRK3(I),I=1,NSPEC0)
      READ(MRW24,10050)(DWRK(I),I=1,NSPEC0)
!
! optionally recover spec energy subset from omginf,
! and retain full-set in denerg back above.
!
!      do i=1,nspec0
!        dwrk0(i)=dwrk0(i)*dz2
!      enddo
!
      iflag=0
      if(nomwrt.ne.nomwr0)then       !should not happen in non-test mode
        if(ione1.eq.0)then                             !elastic in dwxbp
          if(nomwrt-nmin.ne.nomwr0)then
            write(mw6,*)'dwxbp: infinite energy omega mismatch',nomwrt, &
     &                  nomwr0
            write(mw0,*)'dwxbp: infinite energy omega mismatch'
            nf=-1
            go to 600
          else                                   !case ione1=1 in diagfs
            iflag=1
          endif
        else                                         !inelastic in dwxbp
          if(nomwrt+nmin.ne.nomwr0)then
            write(mw6,*)'dwxbp: infinite energy omega mismatch',nomwrt, &
     &                  nomwr0
            write(mw0,*)'dwxbp: infinite energy omega mismatch'
            nf=-1
            go to 600
          else                                   !case ione1=0 in diagfs
            iflag=2
          endif
        endif
      endif
!
      F713='(1PE14.8,6E11.3/(14X,6E11.3))'        !SUPPRESS IFORT REMARK
!
      READ(MRW24,F713)EINF,(OMGINF(I),I=1,NOMWR0)
!par!                                                               !par
!par      if(iam.ne.0)then                                          !par
!par        IUNIT(MRW23)=-1                                         !par
!par        CLOSE(MRW23)                                            !par
!par        IUNIT(MRW24)=-1                                         !par
!par        CLOSE(MRW24)                                            !par
!par      endif                                                     !par
!
      if(iflag.eq.1)then                          !make room for elastic
        n=nomwrt+1
        nshft=nmin
        do i=nmin,1,-1
          do j=nspec0,i+1,-1
            n=n-1
            omginf(n)=omginf(n-nshft)
          enddo
          n=n-1
          omginf(n)=done                             !flag poss. allowed
          nshft=nshft-1
        enddo
        if(n.ne.1)stop 'iflag=1 nshft error'
      elseif(iflag.eq.2)then                               !drop elastic
        n=0
        nshft=1
        do i=1,nmin
          do j=i+1,nspec0
            n=n+1
            omginf(n)=omginf(n+nshft)
          enddo
          nshft=nshft+1
        enddo
        if(n.ne.nomwrt)stop 'iflag=2 nshft error'
      endif
!
!
  100 CONTINUE
!
! WRITE-OUT SPEC. TARGET ENERGIES
!
      im=-1
      if(nmetag(0).ne.0)im=1
!
      WRITE(MW6,10230)
      WRITE(MW6,10170)NMETAJ*im
!
      DO J=1,NSPECJ
        I=INDXJ(J)
        M1=NRR(I)
        II=NFQ(M1)
        IP=(1-QPI(II))*(QSI(II)+1)
        WRITE(MW6,10160)J,I,M1,IP,QLI(II)/2,JN(I),NFK(M1),DSPECJ(J)
      ENDDO
!
      WRITE(MW6,10240)
!
! FLAG ACTIVE ORBITAL PAIR IN INTERACTING CONFIGS C.F. SR.ALGX BXIST0
!
      ALLOCATE(KACT(KMAX,KMAX),KTMP(NF),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXBP: ALLOCATION FAILS FOR KACT,KTMP'
        NF=0
        GO TO 600
      ENDIF
!
      DO KF=1,KMAX
        DO KG=1,KF
          KACT(KF,KG)=0
          KACT(KG,KF)=0
          DO I=1,NF
            KTMP(I)=QCG(I,KG)
          ENDDO
          K=0
          DO I=1,NF
            L0=0
            DO L=1,NF
              IF(IEQ(KTMP(L)).EQ.IEQ(QCG(I,KF)))THEN
                KTMP(L)=0
                GO TO 120
              ELSE
                IF(KTMP(L).NE.0.AND.L0.EQ.0)L0=L
              ENDIF
            ENDDO
            K=K+1
            IF(K.GT.1)GO TO 150
            KACT(KF,KG)=QCG(I,KF)
            KACT(KG,KF)=KTMP(L0)
  120     ENDDO
  150   ENDDO
      ENDDO
!
!-----------------------------------------------------------------------
!
! BEGIN LOOP OVER Jp SCATTERING SYMMETRIES
!
!-----------------------------------------------------------------------
!
      if(bunit2)write(mw6,10180)
      iwait=0
      wait=done
!
      DO KX=1,INASTJ
!
        MTJ=JPI(KX)/10
        MTP=JPI(KX)-MTJ*10
        MTP=MTP+MTP
!
! SEE IF WE NEED TO UPDATE INTEGRALS & CONTINUUM BASIS
!
        JNEW=MTJ
!
        IF(JNEW.NE.JOLD)THEN
!
!-----------------------------------------------------------------------
!
          if(btimex)then
!par            if(iam.ge.0)then                                    !par
!par              write(iwp,*)'Starting proc',iam                   !par&
!par     &                 ,'updating continuum for 2j=',mtj        !par
!par              call flush(iwp)                                   !par
!par            else                                                !par
            write(iw,*)                                                 &
     &             'Begin update of continuum basis & integrals for 2J='&
     &             ,MTJ
!par            endif                                               !par
!
            call nrb_time(timei)
            times=timei
          endif
!
!-----------------------------------------------------------------------
!
          jstep=jnew-jold
          if(jstep.gt.2.and.jfact.gt.200.and.jold.gt.0)then
            if(iwait.eq.2)then
              iwait=1
            else
              iwait=2
            endif
            wait=iwait*jstep
            wait=wait/dthree
          endif
!
! UPDATE CONTINUUM BASIS
!
!  NOTE: IF THE USER HAS RESTRICTED LCONDWJ THEN ANY FINE-STRUCTURE HAS
!        A TRUNCATED PARTIAL WAVE EXPANSION.
!
          IF(BKUTSS)THEN
!
            IF(BTHRSH)LCONDWJ=-LCONDWJ                        !FLAG
!
            CALL RADCNX(FRX,PSHFTX,PSHFT0,MDIM1,MDIM2,MDIM3,JNEW/2,     &
     &                  JOLD/2,LCONDWJ,-MXORB)
!
            IF(NF.LE.0)GO TO 500
!
            DO L=1,LCONDWJ
              QPOSJ(L)=QPOS(L)
            ENDDO
!
          ENDIF
!
! UPDATE FINE-STRUCTURE
!
          IF(JNEW.LE.MAXJFS)THEN
!
! UPDATE EXCHANGE MULTIPOLE
!
            JDIFF=JNEW
            IF(JOLD.GE.0)JDIFF=JDIFF-JOLD
            jdiff=2*(jdiff/2)
!
            DO L=1,NL000
              IF(QSS(1,L).GT.MXORB.AND.QSS(3,L).GT.MXORB.OR.QSS(2,L)    &
     &           .GT.MXORB.AND.QSS(4,L).GT.MXORB)THEN
              ELSE
                QSS(5,L)=QSS(5,L)+INT(JDIFF,QP)                !EXCHANGE
              ENDIF
            ENDDO
!
! UPDATE FINE-STRUCTURE INTEGRALS
!
            IF(BPRNT0)WRITE(MW6,10390)JNEW
!
            DO M=1,MTRAN
              M1=MNDEX(M,1)
              M2=MNDEX(M,2)
              CALL FSINTX(FRX,PSHFTX,MDIM1,MDIM2,MDIM3,DNLX(1,M),M1,M2, &
     &                    JNEW,MXORB)
            ENDDO
!
          ENDIF
!
! PREPARE TO UPDATE NON-FINE-STRUCTURE INTEGRALS:
!   SET POINTERS FOR INTEGRAL STORAGE FOR MULTIPLE LTOT
!
          IF(JOLD.LT.0)THEN                               !FIRST TIME
            DO L=0,QCS0+1
              QPX(L)=INT(L+1,QP)
            ENDDO
          ELSE
            DO L=0,QCS0+1
              QPX0(L)=QPX(L)
              QPX(L)=0
            ENDDO
            L00=(JOLD-INT(QCS0,SP)-1)/2
            K0=(JNEW-JOLD)/2
            DO L=0,QCS0+1
              L0=L00+L
              IF(2*L0.GE.(JNEW-INT(QCS0,SP)-1).AND.                     &
     &           2*L0.LE.(JNEW+INT(QCS0,SP)+1))THEN
                                                          !RE-USE
                K=L-K0
                QPX(K)=-QPX0(L)                           !FLAG OLD
              ELSE
                QPX0(L)=-QPX0(L)                          !NOT WANTED
              ENDIF
            ENDDO
          ENDIF
!
          DO L=0,QCS0+1
            IF(QPX(L).EQ.0)THEN                           !NEW
              DO K=0,QCS0+1                              !LOOK FOR SPACE
                IF(QPX0(K).LT.0)THEN
                  QPX(L)=-QPX0(K)
                  QPX0(K)=0
                  GO TO 160
                ENDIF
              ENDDO
              WRITE(MW6,*)' SR.DWXBP: QPX INDEX ERROR...'
              WRITE(MW0,*)' SR.DWXBP: QPX INDEX ERROR...'
              NF=-1
              GO TO 500
            ENDIF
  160       CONTINUE
!        write(mw0,*)l,qpx(l),qpx0(l)             !debug print
          ENDDO
!
          LPOS=(JNEW-QCS0-1)/2
!
          DO LQ=0,QCS0+1                        !do lq=QCS0+1,0,-1
!
            LNEW=LPOS+LQ
!
!
            IF(LNEW.GE.0.AND.QPX(LQ).GT.0)THEN
!
! UPDATE/RE-LABEL CONTINUUM BASIS FOR THIS LTOT
!
              IF(BKUTSS)THEN
!
! NOTE: CURRENTLY, NO NEW CONTINUUM ORBITALS ARE GENERATED HERE.
!       SO, IF THE USER HAS RESTRICTED LCONDWJ (*NOT A GOOD IDEA*)
!       THEN FLAG & DISCARD PWS.
!
                J=MPOSC-MXORB
                J=J+LNEW-JNEW/2
                MYL2=2*(LNEW-(LCONDW+1)/2)
!
                DO L=1,LCONDW
                  J=J+1
                  MYL2=MYL2+2
                  if(j.le.0.or.j.gt.lcondwj)then !user restricts lcondwj
                    QPOS(L)=0                    !flag not to calculate
                    QL(MPOSC+L)=-99              !flag non-existence
                  else
                    QPOS(L)=ABS(QPOSJ(J))
                    QL(MPOSC+L)=INT(MYL2,QP)
                  endif
                ENDDO
!
              ELSE
!
! UPDATE CONTINUUM BASIS
!
                IF(BTHRSH)LCONDW=-LCONDW                        !FLAG
!
                CALL RADCNX(FRX,PSHFTX,PSHFT0,MDIM1,MDIM2,MDIM3,LNEW,   &
     &                      LOLD,LCONDW,MPOSC)
!
                IF(NF.LE.0)GO TO 500
!
              ENDIF
!
! UPDATE EXCHANGE MULTIPOLE
!
              LDIFF=LNEW
              IF(LOLD.GE.0)LDIFF=LDIFF-LOLD
              LDIFF=LDIFF+LDIFF
!
              DO I=1,IRL
                IF(QRL(2,I).GT.MXORB)QRL(5,I)=QRL(5,I)+INT(LDIFF,QP) !EX
              ENDDO
!
! UPDATE SLATER INTEGRALS (INC. 2NFS IF BKUTOO=.TRUE.)
!
              IF(BKUTOO.AND.LNEW.GT.MAXLOO)THEN
                KUTOOX=0
                BKUTOO=.FALSE.
              ENDIF
!
              IF(BPRNT0)WRITE(MW6,10380)LNEW
              LSTORE=QPX(LQ)-1
!
              DO M=1,MTRAN
                M1=MNDEX(M,1)
                M2=MNDEX(M,2)
                IF(BKUTOO)THEN
                  CALL SLATRX(FRX,PSHFTX,MDIM1,MDIM2,MDIM3,             &
     &                        DRLX(1,M,LSTORE),DZLX(1,M,LSTORE),        &
     &                        DXTWOX(1,M,LSTORE),DETAX(1,M,LSTORE),M1,  &
     &                        M2,LNEW,MPOSC)
                ELSE
                  CALL SLATRX(FRX,PSHFTX,MDIM1,MDIM2,MDIM3,             &
     &                        DRLX(1,M,LSTORE),DZLX(1,1,0),DXTWOX(1,1,0)&
     &                        ,DETAX(1,1,0),M1,M2,LNEW,MPOSC)
                ENDIF
              ENDDO
!
              LOLD=LNEW
              KUTOOX=KOLDOO
              BKUTOO=KUTOOX.NE.0
!
            ENDIF
!
            QPX(LQ)=ABS(QPX(LQ))
!
          ENDDO
!
! RE-SET
!
          JOLD=JNEW
!
! (NOTE: MAKE SURE QL IS SYNCHRONIZED WITH LDIFF USAGE BELOW WHEN
!        TESTING WHETHER "INITIAL" & "FINAL" STATES HAVE BEEN SWAPPED
!        BY FALLING ORDER)
!
          IF(BKUTSS)THEN
            DO J=1,LCONDWJ
              QPOS(J)=QPOSJ(J)
            ENDDO
            JPOS=JNEW
          ELSE
            JPOS=LNEW+LNEW
          ENDIF
!
          MYL2=2*(JPOS/2-(LCONDWJ+1)/2)
          DO L=1,LCONDWJ
            MYL2=MYL2+2
            QL(MXORB+L)=INT(MYL2,QP)
          ENDDO
!
!-----------------------------------------------------------------------
!
          if(btimex)then
            call nrb_time(timef)
            times=timef-times
!
!par            if(iam.ge.0)then                                    !par
!par              write(iwp,*)'Ending proc',iam                     !par&
!par     &                  ,'updating continuum'                   !par&
!par     &                 ,' time=',nint(times),'sec'              !par
!par              call flush(iwp)                                   !par
!par            else                                                !par
            write(iw,*)'End update of continuum basis & integrals',     &
     &                 ', time=',nint(times),'sec'
!par            endif                                               !par
          endif
!
!-----------------------------------------------------------------------
!
        ENDIF
!
! INITIALIZE FOR J-LOOP
!
        IF(BPRNT0)WRITE(MW6,10270)KX,MTJ,MTP/2
!
        NWTJ=MTJ+1
!                                                     WRITE CHANNEL LIST
        NCHJT=NCHAJK(KX,-IONE,-IONE,-IONE,-IONE,NTGJ)
        NCHSJT=NCHSJ
!
        IF(.NOT.BPRNT0)WRITE(MW6,10250)KX,MTJ,MTP/2,NCHSJT,NCHJT
!
        if(bntest)then
          do i=1,nchjt
            do j=1,nchjt
              ntest(j,i)=0
            enddo
          enddo
        endif
!
! initialize for approximation-ii (memory hog)
!
        if(bunit2)then
!
          nx=(nchjt*(nchjt+1))/2
!
          ALLOCATE(rhom(nx,meng0),wrkp(nx),wrkq(nx),iwrkn(nchjt),       &
     &             iwrkl(nchjt),work(nchjt),stat=ierr)
!
          if(ierr.ne.0)then
            write(mw0,*)'dwxbp: allocation fails for rhom,wrk'
            nf=0
            go to 500
          endif
!
          do i=1,nchjt
            iwrkn(i)=-1
            iwrkl(i)=-1
          enddo
!
          do m=1,meng0
            n=0
            do i=1,nchjt
              n=n+1
              rhom(n,m)=done
              do j=i+1,nchjt
                n=n+1
                rhom(n,m)=dzero
              enddo
            enddo
          enddo
!
        endif
!
! detailed print
!
        if(jprint.eq.6)then
          write(mw6,10350)
          if(maxjfs.ge.0)write(mw6,10400)
        endif
!
        IF(BPRNT2)WRITE(MW6,10290)
!
!-----------------------------------------------------------------------
!
        if(btimex)then
!par          if(iam.ge.0)then                                      !par
!par            write(iwp,*)'Starting proc',iam                     !par&
!par     &                ,'dwxbp symmetry',kx,':',mtj,mtp/2        !par
!par            call flush(iwp)                                     !par
!par          else                                                  !par
          write(iw,*)'Starting dwxbp symmetry',kx,' :',mtj,mtp/2
!par          endif                                                 !par
!par!                                                               !par
          call nrb_time(timei)
          timej=timei
        endif
!
        if(btimet)then
          timeset=dzero
          timemix=dzero
          timemixi=dzero
          timemixf=dzero
          timemixir=dzero
          timemixfr=dzero
          timeunit=dzero
          timeint=dzero
        endif
!
!-----------------------------------------------------------------------
!
        INASTX=NCHGJ(KX)                    !NO. OF LS-SYMMS FOR THIS JP
!
! BEGIN K-LOOPS
!
        KAY2=MTJ+1
        IF(MTJ.GT.0)THEN
          KAY1=MTJ-1
        ELSE
          KAY1=KAY2
        ENDIF
!
        if(mtj.le.jktest)then       !exchange present so K.ne.K' allowed
          kay1p=kay1
          kay2p=kay2
        endif
!
        DO KAYI=KAY1,KAY2,2                  !LOOP OVER INTIAL CHANNEL K
!
          if(mtj.gt.jktest)then                !no-exchange so K=K' only
            kay1p=kayi
            kay2p=kayi
          endif
!
          DO KAYF=KAY1p,KAY2p,2               !LOOP OVER FINAL CHANNEL K
!
! BEGIN TARGET JP LOOPS (CURRENTLY, WE HAVE NOT YET SELECTED SUBSET
!                        THAT CONTRIBUTE TO THE TOTAL JP SYMMETRY,
!                        SO LOOP OVER ALL AND DISCARD ON-THE-FLY.)
!
            DO JIG=1,NJO             !LOOP OVER INITIAL TARGET JP GROUPS
!
              NC=NSLJ(1,JIG)
              JIP=QPI(NC)
              JI=NTGJ(JIG)+1
              JI=JN(JI)
              SJKI=SQRT(REAL((JI+1)*(KAYI+1),WP))
              L1=ABS(KAYI-JI)
              IF(MOD(JIP+L1,IFOUR).NE.MTP)L1=L1+2
              L2=KAYI+JI
              IF(MOD(JIP+L2,IFOUR).NE.MTP)L2=L2-2
!
              NCJ0=NT(JIG)
              NCN0=NGSLJ(JIG)
!
              jf2=jig
              if(kayf.gt.kayi)jf2=jig-1
!
              DO JFG=1,jf2             !LOOP OVER FINAL TARGET JP GROUPS
!
                ND=NSLJ(1,JFG)
                JFP=QPI(ND)
                JF=NTGJ(JFG)+1
                JF=JN(JF)
                SJKF=SQRT(REAL((JF+1)*(KAYF+1),WP))
                L1P=ABS(KAYF-JF)
                IF(MOD(JFP+L1P,IFOUR).NE.MTP)L1P=L1P+2
                L2P=KAYF+JF
                IF(MOD(JFP+L2P,IFOUR).NE.MTP)L2P=L2P-2
!
                NCJP0=NT(JFG)
                NCNP0=NGSLJ(JFG)
!
! get lambda for non-dipole infnite energy top-up
!
                if(jnew.ge.lrglam)then
                  if(ji+jf.ne.0)then
                    litlam=abs(ji-jf)/2
                    if(jip.ne.jfp)then
                      if(litlam.le.1)then          !for case of octupole
                        litlam=3
                      elseif(1.gt.2*mod(abs(litlam),itwo))then
                        litlam=litlam+1
                      endif
                    else
                      if(litlam.eq.0)then
                        litlam=2
                      elseif(1.lt.2*mod(abs(litlam),itwo))then
                        litlam=litlam+1
                      endif
                    endif
                    if(litlam.gt.(ji+jf)/2)litlam=0
                  else
                    litlam=0
                  endif
                else
                  litlam=0
                endif
!
!                beqgrpj=jig.eq.jfg                  !not currently used
!
                DO LI=L1,L2,4               !LOOP OVER INITIAL CHANNEL L
!
! set position of phase shift for this li
! only required by  elastic case for diagonal rho
! or if printing usual reactance matrix
!
                  if(ione1.eq.0.or.brmx)then
                    L=(LCONDWJ+1)/2-JPOS/2+LI/2
!                    if(l.gt.lcondwj.or.l.lt.1)stop 'phase error'
                    l=min(l,lcondwj)   !case user has restricted lcondwj
                    l=max(l,ione)     !then we don't have all the phases
                    L0=ABS(QPOS(L))
                  endif
!
                  DO LF=L1P,L2P,4             !LOOP OVER FINAL CHANNEL L
!
! set position of phase shift for this lf
! only need if printing usual reactance matrix, not needed by rho matrix
!
                    if(brmx)then
                      L=(LCONDWJ+1)/2-JPOS/2+LF/2
!                      if(l.gt.lcondwj.or.l.lt.1)stop 'phase error'
                      l=min(l,lcondwj) !case user has restricted lcondwj
                      l=max(l,ione)   !then we don't have all the phases
                      L00=ABS(QPOS(L))
                    endif
!
! NOW FORM JK INTERACTION (BY TARGET SYMMETRY GROUP)
!*************************
!
! THIS IS IN THE RHO-I REPRESENTATION, WHERE
! |T^R(V,V')|=|T^RHO(V,V')| FOR CHANNELS V.NE.V'.
! WE USE T^RHO(V,V')=-2I*RHO(V,V'), WITH A 2X2 UNITARITY CONDITION.
! FOR V.EQ.V' T^R(V,V)~-2*TAN(TAU(V)), FOR RHO(V,V) SMALL.
! (IN GENERAL, WE ARE NOT INTERESTED IN ELASTIC TRANSITIONS.)
!
!
                    if(btimet)call nrb_time(timei)
!
                    NOMTG=NCJ0*NCJP0
                    DO N=1,NOMTG
                      DO M=1,MTRAN
                        RHO1(M,N)=DZERO
                      ENDDO
                    ENDDO
!
                    NCI0=0
                    DO NC00=1,NCN0    !BEGIN LOOP OVER INITIAL SL GROUPS
                      NC=NSLJ(NC00,JIG)
                      MC=NSL(NC)
                      SA=QSI(NC)
                      LA=QLI(NC)
                      MCI=NGRPI(NC)
!
                      NCIP0=0
                      DO ND00=1,NCNP0   !BEGIN LOOP OVER FINAL SL GROUPS
                        ND=NSLJ(ND00,JFG)
                        MCP=NSL(ND)
                        SAP=QSI(ND)
!                        IF(ABS(SA-SAP).GT.2)GO TO 68   !unnecessary...
                        IF(NMETAG(NC)+NMETAG(ND).EQ.2)GO TO 178
                        LAP=QLI(ND)
                        MCIP=NGRPI(ND)
!
                        DO IXX=1,INASTX      !LOOP OVER INITIAL LS SYMMS
!
                          IX=JSYMM(IXX,KX)
                          NCN=NCHG(IX)
!
                          nchi=0
                          DO NC0=1,NCN               !FIND INITIAL GROUP
                            LL1=LLCH(1,NC0,IX)
                            LL2=LLCH(2,NC0,IX)
                            nchi=nchi+((ll2-ll1)/4+1)*mc
                            IF(NC.EQ.ITARG(NC0,IX))THEN         !MATCHED
                              IF(LI.LT.LL1.OR.LI.GT.LL2)GO TO 162
                              nchi=nchi-((ll2-li)/4+1)*mc
                              GO TO 164
                            ENDIF
                          ENDDO
!
  162                     CONTINUE
!                    write(mw6,*)'NO CONTRIB. FROM LS SYM',IXX,' IX=',IX
                          GO TO 176             !SLP DOES NOT CONTRIBUTE
!
  164                     IS=LSPI(IX)/10000
                          IP=LSPI(IX)-IS*10000
                          IL=IP/10
                          IP=IP-IL*10
!
                          IF(MTP.NE.IP+IP)STOP 'IXX ERROR'       !REMOVE
                          MTS=IS-1
                          MTL=IL+IL
!
                          IF(KAYI.LT.ABS(MTL-SA).OR.KAYI.GT.MTL+SA)     &
     &                       GO TO 176                    !LAST TRIANGLE
!
                          IF(BKUTOO.AND.IL.GT.MAXLOO)THEN
                            KUTOOX=0
                            BKUTOO=.FALSE.
                          ENDIF
!
                          bnx=il.gt.maxlx
!
                          if(jprint.ge.5)then
                            if(bnx)then
                              nwt=-2*is+2
                            else
                              nwt=is
                            endif
                            write(mw6,10260)ix,nwt,il,ip
                          endif
!
! must be synchronized with current values of l placed in ql(i) for
! orbital and integral evaluations.
!
                          ldiff=2*(jpos/2)-mtl      !for adjust of ql(i)
!
! DETERMINE INITIAL STATE RECOUPLING COEFFICIENT
!
                          W=SJS(LA,LI,MTL,KAYI,SA,JI)
                          ISGN=(LI+MTL+SA+JI)/2
                          isgn=1-2*mod(abs(ISGN),ITWO)
                                                      !(-1)**isgn
                          W=W*ISGN
                          W2=SJS(MTS,MTL,MTJ,KAYI,IONE,SA)
                          ISGN=(MTL+MTJ+1+SA)/2
                          isgn=1-2*mod(abs(ISGN),ITWO)
                                                      !(-1)**isgn
                          W2=W*W2*ISGN
                          W2=W2*SQRT(REAL((MTL+1)*(MTS+1),WP))*SJKI
!
                          if(bnx)then
                            mts=mts-2
                            if(mts.ge.abs(mtj-mtl))then
                              x2=sjs(mts,mtl,mtj,kayi,ione,sa)
!                              isgn=(mtl+mtj+1+sa)/2
!                              isgn=1-2*mod(abs(isgn),2)!(-1)**isgn
                              x2=w*x2*isgn
                              x2=x2*sqrt(real((mtl+1)*(mts+1),wp))*sjki
                            endif
                          else
                            x2=dzero
                          endif
!
                          if(abs(w2)+abs(x2).lt.1.D-70)go to 176
!
                          JX1=1                            !FS
                          IF(MTJ.GT.MAXJFS)JX1=IXX         !NO-FS
!
                          DO JXX=JX1,IXX       !LOOP OVER FINAL LS SYMMS
!
                            JX=JSYMM(JXX,KX)
                            NCNP=NCHG(JX)
!
                            nchip=0
                            DO ND0=1,NCNP              !FIND FINAL GROUP
                              LL1P=LLCH(1,ND0,JX)
                              LL2P=LLCH(2,ND0,JX)
                              nchip=nchip+((ll2p-ll1p)/4+1)*mcp
                              IF(ND.EQ.ITARG(ND0,JX))THEN       !MATCHED
                                IF(LF.LT.LL1P.OR.LF.GT.LL2P)GO TO 166
                                nchip=nchip-((ll2p-lf)/4+1)*mcp
                                GO TO 168
                              ENDIF
                            ENDDO
!
  166                       CONTINUE
!                   write(mw6,*)'NO CONTRIB. FROM LS SYM',JXX,' JX=',JX
                            GO TO 174              !SLP DOES NOT CONTRIB
!
  168                       ISP=LSPI(JX)/10000
                            IPP=LSPI(JX)-ISP*10000
                            ILP=IPP/10
                            IPP=IPP-ILP*10
!
                            IF(MTP.NE.IPP+IPP)STOP 'JXX ERROR'   !REMOVE
                            MTSP=ISP-1
                            MTLP=ILP+ILP
!
                            IF(KAYF.LT.ABS(MTLP-SAP).OR.                &
     &                         KAYF.GT.MTLP+SAP)GO TO 174 !LAST TRIANGLE
!
                            BLS=IX.EQ.JX
!
                            btest1=(IS+ISP-2)*(IL+ILP).GT.0
                            btest2=abs(NMETAG(NC))+abs(NMETAG(ND)).lt.2
                            b2fs=mtj.le.maxjfs.and.btest1.and.btest2
!
                            if(jprint.ge.5)then
                              if(bnx)then
                                nwtp=-2*isp+2
                              else
                                nwtp=isp
                              endif
                              write(mw6,10280)jx,nwtp,ilp,ipp
                            endif
!
! DETERMINE FINAL STATE RECOUPLING COEFFICIENT
!
                            W=SJS(LAP,LF,MTLP,KAYF,SAP,JF)
                            ISGN=(LF+MTLP+SAP+JF)/2
                            isgn=1-2*mod(abs(ISGN),ITWO)
                                                        !(-1)**isgn
                            W=W*ISGN
                            W2P=SJS(MTSP,MTLP,MTJ,KAYF,IONE,SAP)
                            ISGN=(MTLP+MTJ+1+SAP)/2
                            isgn=1-2*mod(abs(ISGN),ITWO)
                                                        !(-1)**isgn
                            W2P=W*W2P*ISGN
                            W2P=W2P*SQRT(REAL((MTLP+1)*(MTSP+1),WP))    &
     &                          *SJKF
!
                            W4=W2*W2P
!
                            if(bnx)then
                              mtsp=mtsp-2
                              if(mtsp.ge.abs(mtj-mtlp))then
                                x2p=sjs(mtsp,mtlp,mtj,kayf,ione,sap)
!                                isgn=(mtlp+mtj+1+sap)/2
!                                isgn=1-2*mod(abs(isgn),2)!(-1)**isgn
                                x2p=w*x2p*isgn
                                x2p=x2p*sqrt(real((mtlp+1)*(mtsp+1),wp))&
     &                              *sjkf
                                w4=w4+x2*x2p
                              endif
                            endif
!
                            if(abs(w4).lt.1.D-70)go to 174
!
! set pointers to ls and fs interactions
!
!
                            beqgrp=bls.and.nc0.eq.nd0     !ls equal grps
!                                                          !to fill rho1
                            beqgrpl=beqgrpl0.and.beqgrp.and.li.eq.lf
!
                            if(bls)then
                              ncor=qptls(ix,nc0,nd0,li,lf)
                              if(ncor.ge.0)then
                                nun=0
                              else             !reverse
                                nun=mc-1
!                       write(mw6,*)ix,nc0,nd0,li,lf,ncor+1
                              endif
                              ncor0=ncor
                              LSTORE=IL-LPOS
                              LSTORE=QPX(LSTORE)-1
                            else
                              ncor0=0
                            endif
!
                            if(b2fs)then
                              ncorj=qptlsj(kx,ixx,jxx,nc0,nd0,li,lf)
                              if(ncorj.ge.0)then
                                nunj=0
                              else             !reverse
                                nunj=mc-1
!                      write(mw6,*)kx,ixx,jxx,nc0,nd0,li,lf,ncorj+1
                              endif
                              ncorj0=ncorj
                            else
                              ncorj0=0
                            endif
!
                            icl0=0
                            btest=ncor0.lt.0.or.ncorj0.lt.0
                            if(bcorr.and.btest)then
                              do md1=1,mc
                                j1=md1+mci
                                j=jndex(j1)
                                if(j.lt.0)icl0=icl0+1
                              enddo
                            endif
!
! POPULATE UNMIXED RHO1 INTERACTION MATRIX
!
                            icl=0
                            DO MD1=1,MC        !LOOP OVER INITIAL LEVELS
                              J1=MD1+MCI
!
                              j=jndex(j1)
                              if(kcutx.lt.0)j=abs(j)  !keep corr.-corr.
                              if(bcorr.and.j.lt.0)icl=icl+1
                              KF=NFK(J1)
                              NCJ=NCI0+MD1
!
                              if(ncor0.lt.0)ncor=-ncor0-1+md1-1
                              if(ncorj0.lt.0)ncorj=-ncorj0-1+md1-1
!
                              iclp=0
                              DO MDP1=1,MCP      !LOOP OVER FINAL LEVELS
                                J1P=MDP1+MCIP
!
                                jp=jndex(j1p)
                                if(bcorr.and.jp.lt.0)iclp=iclp+1
                                if(j.lt.0.and.jp.lt.0)then      !cor-cor
                                  if(becor)then
                                    if(bls)ncor=ncor+1
                                    if(b2fs)ncorj=ncorj+1
                                    go to 170
                                  endif
                                  go to 172
                                endif
!
                                KG=NFK(J1P)
                                NCJP=NCIP0+MDP1
!
                                NOMTG=(NCJP-1)*NCJ0+NCJ     !rho1 (orig)
!
! LS ALGEBRA
!
                                IF(BLS)THEN
!                                           since ls only stores half...
                                  if(beqgrpl.and.j1p.gt.j1-ione0)then
                                    ncor=ncor0+icol(md1,mdp1,ione0)-1
                                    IF(bcorr)                           &
     &                                 ncor=ncor-icol(iclp-1,iclp-1,    &
     &                                 ione0)
                                  endif
!
                                  N1=NAD(NCOR)+1
                                  NCOR=NCOR+1
                                  N2=NAD(NCOR)
! debug write
                                  if(jprint.eq.6.and.n1.le.n2)then
                                    nch=nchi+md1
                                    nchp=nchip+mdp1
                                    if(n2-n1.eq.5)then
                                      write(mw6,10410)ncor,ix,nch,nchp, &
     &                                  0,0,(nrk(n),drk(n),n=n1,n2)
                                    else
                                      write(mw6,10420)ncor,ix,nch,nchp, &
     &                                  0,0,(nrk(n),drk(n),n=n1,n2)
                                    endif
                                    IF(bkutoo)write(mw6,10430)          &
     &                                 (nrk(n),dek(n),n=n1,n2)
                                    write(mw6,10420)
                                  endif
!
! need to find if Slater integral initial and final states are swapped
! because of falling order. this also picks-up any case that needs
! swapping because initial and final algebraic states are swapped.
! it doesn't pick-up all cases of ncor0.lt.0 but the symmetry of the
! Slater integrals means that such cases are unchanged by a swap.
!
                                  ixxx=n2-n1+1
                                  if(ixxx.gt.ixd13)then
                                    deallocate(bswap)
                                    ixd13=ixxx
                                    allocate(bswap(ixd13))
                                  endif
!
                                  ks=0
                                  do n=n1,n2
                                    ks=ks+1
                                    bswap(ks)=.false.
                                    n0=int(nrk(n),sp)
                                    m0=qrl(1,n0)
                                    if(li.eq.ql(m0)-ldiff)then
                                      if(li.eq.lf.and.kf.ne.kg)then
                                        m0=qrl(3,n0)
                                        if(qn(m0).gt.0)then    !exchange
                                          if(m0.ne.kact(kg,kf))then   !f
                                            bswap(ks)=.true.       !swap
                                          endif
!                                       else    !direct - doesn't matter
                                        endif
!                                     else      !distinct/kf=kg so can't
                                      endif
                                    else           !trivially, they were
                                      bswap(ks)=.true.
                                    endif
                                  enddo
!
                                ELSE
                                  N1=1
                                  N2=0
                                ENDIF
!
! FS ALGEBRA
!
                                if(b2fs)then
!                                           since ls only stores half...
                                  if(beqgrpl.and.j1p.gt.j1-ione0)then
                                    ncorj=ncorj0+icol(md1,mdp1,ione0)-1
                                    IF(bcorr)ncorj=ncorj-               &
     &                                 icol(iclp-1,iclp-1,ione0)
                                  endif
!
                                  k1=nadr(ncorj)+1
                                  ncorj=ncorj+1
                                  k2=nadr(ncorj)
! debug write
                                  if(jprint.eq.6.and.k1.le.k2)then
                                    nch=nchi+md1
                                    nchp=nchip+mdp1
                                    if(k2-k1.eq.5)then
                                      write(mw6,10360)ncorj,kx,ix,jx,   &
     &                                  nch,nchp,0,0,                   &
     &                                  (mss(n),dss(n),n=k1,k2)
                                    else
                                      write(mw6,10370)ncorj,kx,ix,jx,   &
     &                                  nch,nchp,0,0,                   &
     &                                  (mss(n),dss(n),n=k1,k2)
                                    endif
                                    write(mw6,10360)
                                  endif
!
! need to find if n & v integral initial and final states are swapped
! because of falling order.
!
! this does *not* pick-up all cases that need swapping because initial
! and final algebraic states are swapped (ncorj0.lt.0) hence additional
! test on ncorj0.
!
                                  jxxx=k2-k1+1
                                  if(jxxx.gt.jxd13)then
                                    deallocate(bswapj)
                                    jxd13=jxxx
                                    allocate(bswapj(jxd13))
                                  endif
!
! **********************************************************************
! currently, swapping of indexes due to falling order has been
! suppressed in sr.resx1 (see also sr.fsintx) because of the lesser
! symmetry compared to Slater integrals which means that an additional
! flag is needed.
! **********************************************************************
!
! so, we simply have:
                                  ksj=0
                                  do k=k1,k2
                                    ksj=ksj+1
                                    bswapj(ksj)=ncorj0.lt.0
                                  enddo
!! instead of:
!                                  ksj=0
!                                  do k=k1,k2
!                                    ksj=ksj+1
!                                    bswapj(ksj)=.false.
!                                    k0=int(mss(k),sp)
!!
!                                    i1=qss(1,k0)
!                                    i3=qss(3,k0)
!                                    i2=qss(2,k0)
!                                    i4=qss(4,k0)
!                                    if(qn(i1).lt.0)then
!                                      ic=i1
!                                      if(qn(i3).lt.0)then       !direct
!                                        ib=i4
!                                      else                    !exchange
!                                        ib=i3
!                                      endif
!                                    else
!                                      ic=i2
!                                      if(qn(i4).lt.0)then       !direct
!                                        ib=i3
!                                      else                    !exchange
!                                        ib=i4
!                                      endif
!                                    endif
!                                    if(li.eq.ql(ic))then
!                                      if(li.eq.lf)then
!                                        if(kf.ne.kg)then
!                                          if(ib.ne.kact(kg,kf))then  !f
!                                            bswapj(ksj)=.true.
!                                          endif
!                                        else
!! tbd for exchange falling order (see also sr.resx1 and sr.fsintx):
!! the case of N(C'C;BB)=N(BC;C'B) for Bound and Continuum needs a
!! further flag so as to distinguish it from N(C'C;BB)=N(C'B;BC),
!! since in the former we need C'=M2 while in the latter C'=M1, so
!!                                           if(former)then
!!                                           bswapj(ksj)=.true.
!!           since unlike slater we cannot interchange 1 & 3 with 2 & 4
!!         - this also means that we need
!                                          if(ncorj0.lt.0)
!     &                                    bswapj(ksj)=.not.bswapj(ksj)
!                                        endif
!                                      else           !distinct so can't
!                                      endif
!                                    else          !trivially, they were
!                                      bswapj(ksj)=.true.
!                                    endif
!!
!!                           nj=ntgj(jig)
!!                           njp=ntgj(jfg)
!!                           n1=ncj+nj
!!                           n=jndxj(n1)
!!                           n1p=ncjp+njp
!!                           np=jndxj(n1p)
!!          write(mw6,*)ixx,jxx,nc0,nd0,n,np,li,lf,ncorj0,k0,bswapj(ksj)
!!          bswapt=ncorj0.lt.0
!!          if(bswapt.neqv.bswapj(ksj))
!!     &    write(mw0,*)ixx,jxx,nc0,nd0,n,np,li,lf,ncorj0,k0,bswapj(ksj)
!!
!!                                  enddo
!
                                else
                                  k1=1
                                  k2=0
                                endif
!
! LOOP OVER ENERGIES
!
                                DO M=1,MTRAN
                                  M1=MNDEX(M,1)
                                  M2=MNDEX(M,2)
!
! LS CONTRIBUTION:
!
                                  DD=DZERO
                                  ks=0
                                  DO N=N1,N2
                                    ks=ks+1
!
                                    if(bswap(ks))then              !swap
                                      mm=mrndx(m)
                                    else
                                      mm=m
                                    endif
!
                                    N0=INT(NRK(N),SP)
!
                                    DD=DD+DRLX(N0,mm,LSTORE)*DRK(N)
!
                                    IF(BKUTOO)THEN
                                      DS=DZLX(N0,mm,LSTORE)
                                      IF(BFALL(N))DS=-DS
                                      DS=DS+DXTWOX(N0,mm,LSTORE)*DRK(N) &
     &                                   +DETAX(N0,mm,LSTORE)*DEK(N)
                                      DD=DD+DS
                                    ENDIF
                                  ENDDO
!
! FS CONTRIBUTION:
!
!                                  dd=dzero !test fs, switch-off coulomb
!
                                  DDJ=DZERO
                                  ksj=0
                                  DO K=K1,K2
                                    ksj=ksj+1
!
                                    if(bswapj(ksj))then            !swap
                                      mm=mrndx(m)
                                    else
                                      mm=m
                                    endif
!
                                    K0=INT(MSS(K),SP)
!
                                    DDJ=DDJ+DNLX(K0,mm)*DSS(K)
                                  ENDDO
!
                                  DEE=DD+DDJ
!                                                               !UNMIXED
                                  RHO1(M,NOMTG)=RHO1(M,NOMTG)+DEE*W4
                                ENDDO
!
                                if(jprint.eq.6)then
                                  nchj=nchajk(kx,kayi,jig,li,ncj,ntgj)
                                  nchjp=nchajk(kx,kayf,jfg,lf,ncjp,ntgj)
                                  nj=ntgj(jig)
                                  njp=ntgj(jfg)
                                  n1=ncj+nj
                                  n=jndxj(n1)
                                  n1p=ncjp+njp
                                  np=jndxj(n1p)
                                  write(mw6,10010)nchj,nchjp,n,np,      &
     &                                  (rho1(m,nomtg),m=1,mtran)
                                endif
!
  170                           if(ncor0.lt.0)then
                                  ncor=ncor+nun
                                  if(jp.lt.0)ncor=ncor-icl0
                                endif
                                if(ncorj0.lt.0)then
                                  ncorj=ncorj+nunj
                                  if(jp.lt.0)ncorj=ncorj-icl0
                                endif
!
                              ENDDO          !END LOOP OVER FINAL LEVELS
!
  172                         if(beqgrpl)then
                                if(bls)then
                                  ncor=ncor0+icol(md1,md1,ione0)
                                  if(bcorr)ncor=ncor-icol(icl,icl,ione0)
                                endif
                                if(b2fs)then
                                  ncorj=ncorj0+icol(md1,md1,ione0)
                                  IF(bcorr)ncorj=ncorj-                 &
     &                               icol(icl,icl,ione0)
                                endif
                              endif
!
                            ENDDO          !END LOOP OVER INITIAL LEVELS
!
  174                     ENDDO            !END LOOP OVER FINAL LS SYMMS
!
                          KUTOOX=KOLDOO
                          BKUTOO=KUTOOX.NE.0
!
  176                   ENDDO            !END LOOP OVER INITIAL LS SYMMS
!
  178                   CONTINUE
!
                        NCIP0=NCIP0+MCP
                      ENDDO               !END LOOP OVER FINAL SL GROUPS
                      if(ncip0.ne.ncjp0)then
                        stop 'ncip0.ne.nt(jfg)'               !temp test
                      endif
!
                      NCI0=NCI0+MC
                    ENDDO               !END LOOP OVER INITIAL SL GROUPS
                    if(nci0.ne.ncj0)stop 'nci0.ne.nt(jig)'   !temp test
!
                    if(jprint.ge.5)then
                      write(mw6,*)'unmixed rho-matrix:'
                      nj=ntgj(jig)
                      njp=ntgj(jfg)
                      do ncjp=1,ncjp0      !begin loop over final levels
                        nchjp=nchajk(kx,kayf,jfg,lf,ncjp,ntgj)
                        j1p=ncjp+njp
                        jp=jndxj(j1p)
                        nomtg0=(ncjp-1)*ncj0
                        do ncj=1,ncj0    !begin loop over initial levels
                          nchj=nchajk(kx,kayi,jig,li,ncj,ntgj)
                          j1=ncj+nj
                          j=jndxj(j1)
                          nomtg=nomtg0+ncj
                          write(mw6,10010)nchj,nchjp,j,jp,              &
     &                                    (rho1(m,nomtg),m=1,mtran)
                        enddo
                      enddo
                    endif
!
                    if(btimet)then
                      call nrb_time(timef)
                      timeset=timeset+timef-timei
                      timei=timef
                    endif
!
!-----------------------------------------------------------------------
!
                    MX=MTRAN
!
! INTERP THEN MIX (APPROX)
!
                    if(.not.bmix)then
!
                      NJ=NTGJ(JIG)
                      NJP=NTGJ(JFG)
!
                      DO NCJP=1,NCJP0      !BEGIN LOOP OVER FINAL LEVELS
!
                        J1P=NCJP+NJP
                        JP=JNDXJ(J1P)
!
                        NOMTG0=(NCJP-1)*NCJ0
!
                        DO NCJ=1,NCJ0    !BEGIN LOOP OVER INITIAL LEVELS
!
                          J1=NCJ+NJ
                          J=JNDXJ(J1)
!
                          NOMTG=NOMTG0+NCJ            !rho1 nomtg (orig)
!
                          IF(J.LE.JP)THEN
                                        !INITIAL ALGEBRAIC IS LOWER ENRG
!
                            JL=J
                            JH=JP
!
                            DO M=1,MX
                              M1=MNDEX(M,1)
                              M2=MNDEX(M,2)
                              TMP(M1,M2)=RHO1(M,NOMTG)
                            ENDDO
!
                          ELSE          !FINAL ALGEBRAIC IS LOWER ENERGY
!
                            JL=JP
                            JH=J
!
                            DO M=1,MX
                              M1=MNDEX(M,1)
                              M2=MNDEX(M,2)
                              TMP(M2,M1)=RHO1(M,NOMTG)
                            ENDDO
!
                          ENDIF
!
                          DE=DSPECJ(JH)-DSPECJ(JL)
!
                          NOMT=IROW(JL,JH,ione1,NSPECJ)         !ROWWISE
!
                          bdip=.false.
                          if(jl.le.nmetaj.and.jl.lt.jh)then !need exists
                            bdip=omginf(nomt).lt.dzero      !flag dipole
                          endif
!
! LOOP-OVER MENG0 UPPER STATE SCATTERING ENERGIES
!
                          DO M0=1,MENG0
!
                            M=IYY0(M0)
!
                            ml=mlim(m,1)
                            mu=mlim(m,2)
!
                            if(bdip)mu=-mu                  !flag dipole
!
                            RHO=-2*XINT(DE,DYY,NLAG,TMP(1,M),M,ml,mu)
                                                                   !A.U.
!
                            RHO1(M0,NOMTG)=RHO
!
                          ENDDO                  !END LOOP OVER ENERGIES
!
                        ENDDO              !END LOOP OVER INITIAL LEVELS
!
                      ENDDO                  !END LOOP OVER FINAL LEVELS
!
                      if(btimet)then
                        call nrb_time(timef)
                        timeint=timeint+timef-timei
                        timei=timef
                      endif
!
                      mx=meng0                                   !re-set
!
                    endif
!
!-----------------------------------------------------------------------
!
! NOW MIX (INITIAL)
!
                    N0=NADRUG(JIG)
                    N0P=NADRUG(JFG)
                    NJ=NTGJ(JIG)
                    NJP=NTGJ(JFG)
!                    NCJ0=NT(JIG)
!                    NCJP0=NT(JFG)
!
                    DO NCJ=1,NCJ0        !BEGIN LOOP OVER INITIAL LEVELS
!
                      J1=NCJ+NJ
                      j=jndxj(j1)
                      if(j.lt.0)go to 184                     !omit corr
                      if(j.gt.nmetaj)go to 184      !omit non-metastable
!
                      if(bcorr.or.kayi.eq.kayf)then
                        DO NCJP=1,NCJP0    !SEE IF WE HAVE A FINAL LEVEL
                          J1P=NCJP+NJP
                          IF(J1P.GT.J1.and.kayi.eq.kayf)GO TO 184
                          jp=jndxj(j1p)
                          if(jp.gt.0)go to 180                    !we do
                        ENDDO
                        GO TO 184                              !WE DON'T
                      endif
!
  180                 N1=N0+(NCJ-1)*NCJ0                    !tfu pointer
!
                      DO NCJP=1,NCJP0              !FOR EACH FINAL LEVEL
!
                        DO M=1,MX
                          TEMP(M,NCJP)=DZERO
                        ENDDO
!
                        NG0=(NCJP-1)*NCJ0
                        DO LD1=1,NCJ0              !BEGIN INITIAL MIXING
!
                          NG=NG0+LD1                         !rho1 nomtg
                          N2=N1+LD1
                          TF=TFU(N2)
!
                          IF(ABS(TF).GT.XMIX)THEN
                          IF(LAPAK.GT.0)THEN                     !LAPACK
           CALL DAXPY(MX,TF,RHO1(1,NG),IONE,TEMP(1,NCJP),IONE)   !LAPACK
                          ELSE                                   !LAPACK
                            DO M=1,MX
                              TEMP(M,NCJP)=TEMP(M,NCJP)+RHO1(M,NG)*TF
                            ENDDO
                          ENDIF                                  !LAPACK
                          ENDIF
!
                        ENDDO                        !END INITIAL MIXING
!
!                        j1p=ncjp+njp
!                        write(mw6,777)j1,j1p,(temp(m,ncjp),m=1,mx)
!
                      ENDDO                        !FOR EACH FINAL LEVEL
!
                      if(btimet)then
                        call nrb_time(timef)
                        timemixi=timemixi+timef-timei
                        timei=timef
                      endif
!
! NOW MIX (FINAL)
!
                      NOMTG0=(NCJ-1)*NCJP0               !for rho2 (new)
!
                      DO NCJP=1,NCJP0      !BEGIN LOOP OVER FINAL LEVELS
!
                        J1P=NCJP+NJP
                        if(j1.eq.j1p.and.ione1.ne.0)go to 182
                        if(kayi.eq.kayf)then
                          IF(J1P.GT.J1)GO TO 184
                          if(j1.eq.j1p.and.lf.gt.li)go to 182
                        endif
!
                        jp=jndxj(j1p)
                        if(jp.lt.0)go to 182                  !omit corr
!                        if(min(j,jp).gt.nmetaj)go to 10 !non-metastable
!
                        N1P=N0P+(NCJP-1)*NCJP0              !tfu pointer
!
                        NOMTG=NOMTG0+NCJP                    !rho2 (new)
                        DO M=1,MX
                          RHO2(M,NOMTG)=DZERO
                        ENDDO
!
                        DO LDP1=1,NCJP0              !BEGIN FINAL MIXING
!
                          N2P=N1P+LDP1
                          TF=TFU(N2P)
!
                          IF(ABS(TF).GT.XMIX)THEN
                      IF(LAPAK.GT.0)THEN                         !LAPACK
        CALL DAXPY(MX,TF,TEMP(1,LDP1),IONE,RHO2(1,NOMTG),IONE)   !LAPACK
                      ELSE                                       !LAPACK
                            DO M=1,MX
                              RHO2(M,NOMTG)=RHO2(M,NOMTG)+TEMP(M,LDP1)  &
     &                          *TF
                            ENDDO
                      ENDIF                                      !LAPACK
                          ENDIF
!
                        ENDDO                          !END FINAL MIXING
!
!                        write(mw6,777)j1,j1p,(rho2(m,nomtg),m=1,mx)
  182                 ENDDO                  !END LOOP OVER FINAL LEVELS
!
                      if(btimet)then
                        call nrb_time(timef)
                        timemixf=timemixf+timef-timei
                        timei=timef
                      endif
!
  184               ENDDO                  !END LOOP OVER INITIAL LEVELS
!
! FIRST SEE IF WE NEED REVERSE CASE:
!----------------------------------
!
!  INITIAL & FINAL ARE ALGEBRAIC AND SO NMETA CAN BE IN EITHER/BOTH/NONE
!  BUT WE WANT THE FIRST MIXING MATRIX MULT TO BE FOR NMETAJ SO WE DON'T
!  NEED TO MULTIPLY BY THE ZERO BLOCK. THUS, WE MAKE A DOUBLE PASS. OF
!  COURSE, IF NMETAJ=NSPECJ THEN THE SECOND PASS IS "SKIPPED".
!
                    DO NCJP=1,NT(JIG)              !CHECK INITIAL LEVELS
                      J1P=NCJP+NTGJ(JIG)
                      jp=jndxj(j1p)
                      if(jp.gt.nmetaj)go to 186                  !needed
                    ENDDO
                    GO TO 196                                  !ALL DONE
!
! NOW MIX (FINAL) - REVERSE CASE
!
  186               N0=NADRUG(JFG)
                    N0P=NADRUG(JIG)
                    NJ=NTGJ(JFG)
                    NJP=NTGJ(JIG)
                    NCJ0=NT(JFG)
                    NCJP0=NT(JIG)
!
                    DO NCJ=1,NCJ0          !BEGIN LOOP OVER FINAL LEVELS
!
                      J1=NCJ+NJ
                      j=jndxj(j1)
                      if(j.lt.0)go to 194                     !omit corr
                      if(j.gt.nmetaj)go to 194      !omit non-metastable
!
                      DO NCJP=1,NCJP0      !SEE IF WE HAVE INITIAL LEVEL
                        J1P=NCJP+NJP
                        IF(J1P.LT.J1.and.kayi.eq.kayf)GO TO 188
                        jp=jndxj(j1p)
                        if(jp.gt.nmetaj)go to 190                 !we do
  188                 ENDDO
                      GO TO 194                                !WE DON'T
!
  190                 N1=N0+(NCJ-1)*NCJ0                    !tfu pointer
!
                      DO NCJP=1,NCJP0            !FOR EACH INITIAL LEVEL
!
                        DO M=1,MX
                          TEMP(M,NCJP)=DZERO
                        ENDDO
!
                        DO LD1=1,NCJ0                !BEGIN FINAL MIXING
!
                          NG=NCJP+(LD1-1)*NCJP0              !rho1 nomtg
                          N2=N1+LD1
                          TF=TFU(N2)
!
                          IF(ABS(TF).GT.XMIX)THEN
                          IF(LAPAK.GT.0)THEN                     !LAPACK
           CALL DAXPY(MX,TF,RHO1(1,NG),IONE,TEMP(1,NCJP),IONE)   !LAPACK
                          ELSE                                   !LAPACK
                            DO M=1,MX
                              TEMP(M,NCJP)=TEMP(M,NCJP)+RHO1(M,NG)*TF
                            ENDDO
                          ENDIF                                  !LAPACK
                          ENDIF
!
                        ENDDO                          !END FINAL MIXING
!
!                        j1p=ncjp+njp
!                        write(mw6,777)j1,j1p,(temp(m,ncjp),m=1,mx)
!
                      ENDDO                      !FOR EACH INITIAL LEVEL
!
                      if(btimet)then
                        call nrb_time(timef)
                        timemixfr=timemixfr+timef-timei
                        timei=timef
                      endif
!
! NOW MIX (INITIAL) - REVERSE CASE
!
                      DO NCJP=1,NCJP0    !BEGIN LOOP OVER INITIAL LEVELS
!
                        J1P=NCJP+NJP
                        if(j1.eq.j1p.and.ione1.ne.0)go to 192
                        if(kayi.eq.kayf)then
                          IF(J1P.LT.J1)GO TO 192
                          if(j1.eq.j1p.and.lf.gt.li)go to 192
                        endif
!
                        jp=jndxj(j1p)
!                        if(jp.lt.0)go to 12                  !omit corr
                        if(jp.le.nmetaj)go to 192        !already gotten
!
                        N1P=N0P+(NCJP-1)*NCJP0              !tfu pointer
!
                        NOMTG=NCJ+(NCJP-1)*NCJ0        !rho2 nomtg (new)
                        DO M=1,MX
                          RHO2(M,NOMTG)=DZERO
                        ENDDO
!
                        DO LDP1=1,NCJP0            !BEGIN INITIAL MIXING
!
                          N2P=N1P+LDP1
                          TF=TFU(N2P)
!
                          IF(ABS(TF).GT.XMIX)THEN
                      IF(LAPAK.GT.0)THEN                         !LAPACK
        CALL DAXPY(MX,TF,TEMP(1,LDP1),IONE,RHO2(1,NOMTG),IONE)   !LAPACK
                      ELSE                                       !LAPACK
                            DO M=1,MX
                              RHO2(M,NOMTG)=RHO2(M,NOMTG)+TEMP(M,LDP1)  &
     &                          *TF
                            ENDDO
                      ENDIF                                      !LAPACK
                          ENDIF
!
                        ENDDO                        !END INITIAL MIXING
!
!                        write(mw6,777)j1,j1p,(rho2(m,nomtg),m=1,mx)
  192                 ENDDO                !END LOOP OVER INITIAL LEVELS
!
                      if(btimet)then
                        call nrb_time(timef)
                        timemixir=timemixir+timef-timei
                        timei=timef
                      endif
!
  194               ENDDO                    !END LOOP OVER FINAL LEVELS
!
! RE-SET
                    NJ=NTGJ(JIG)
                    NJP=NTGJ(JFG)
                    NCJ0=NT(JIG)
                    NCJP0=NT(JFG)
!
  196               CONTINUE
!
!-----------------------------------------------------------------------
!
! (IF bmix INTERPOLATE MIXED RHO2.) CONVERT TO TMX AND ADD TO OMEGA
! NOTE, RHO2 IS IN "A.U"
! ALLOW FOR ANY INITIAL ALGEBRAIC LEVELS NOT BEING LOWEST IN ENERGY.
!
                    if(.not.bmix)mx=-mx              !skip interp set-up
!
                    DO NCJ=1,NCJ0        !BEGIN LOOP OVER INITIAL LEVELS
!
                      J1=NCJ+NJ
                      j=jndxj(j1)
                      if(j.lt.0)go to 202                     !omit corr
!
                      IF(BPRNT2.or.bunit2.or.bntest)THEN
                        NCHJ=NCHAJK(KX,KAYI,JIG,LI,NCJ,NTGJ)
                      ENDIF
! hold
                      if(bunit2)then
                        iwrkn(nchj)=j
                        iwrkl(nchj)=l0
                      endif
!
                      NOMTG0=(NCJ-1)*NCJP0
                      DO NCJP=1,NCJP0      !BEGIN LOOP OVER FINAL LEVELS
!
                        J1P=NCJP+NJP
!
                        if(j1.eq.j1p.and.ione1.ne.0)go to 200
                        if(kayi.eq.kayf)then
                          IF(J1P.GT.J1)GO TO 202
                          if(j1.eq.j1p.and.lf.gt.li)go to 200
                        endif
!
                        JP=JNDXJ(J1P)
                        if(jp.lt.0)go to 200                  !omit corr
                        if(min(j,jp).gt.nmetaj)go to 200 !non-metastable
!
                        IF(BPRNT2.or.bunit2.or.bntest)THEN
                          NCHJP=NCHAJK(KX,KAYF,JFG,LF,NCJP,NTGJ)
                        ENDIF
!
!                        write(mw6,*)nchj,nchjp,j1,j1p,j,jp
!
                        if(bntest)ntest(nchj,nchjp)=ntest(nchj,nchjp)+1
!
! "undefined" should not be accessed by xint...
!                        do m2=1,meng
!                          do m1=1,meng
!                            tmp(m1,m2)=1.d70 !dzero              !test
!                          enddo
!                        enddo
!
                        NOMTG=NOMTG0+NCJP              !rho2 nomtg (new)
!
                        IF(J.LE.JP)THEN !INITIAL ALGEBRAIC IS LOWER ENRG
!
                          JL=J
                          JH=JP
                          NCHL=NCHJ
                          NCHH=NCHJP
                          LUP=LF
!
                          DO M=1,MX
                            M1=MNDEX(M,1)
                            M2=MNDEX(M,2)
                            TMP(M1,M2)=RHO2(M,NOMTG)
                          ENDDO
!
                        ELSE            !FINAL ALGEBRAIC IS LOWER ENERGY
!
                          JL=JP
                          JH=J
                          NCHL=NCHJP
                          NCHH=NCHJ
                          LUP=LI
!
                          DO M=1,MX
                            M1=MNDEX(M,1)
                            M2=MNDEX(M,2)
                            TMP(M2,M1)=RHO2(M,NOMTG)
                          ENDDO
!
                        ENDIF
!
                        DE=DSPECJ(JH)-DSPECJ(JL)
!
                        NOMT=IROW(JL,JH,ione1,NSPECJ)           !ROWWISE
!
                        if(nomt.gt.nomwrt)then    !shouldn't happen, now
                          write(mw0,*)jl,jh,nmetaj,nspecj,nomt,nomwrt
                          stop 'omega prob.'
                        endif
!
                        bdip=omginf(nomt).lt.dzero          !flag dipole
!
                        if(bunit2)then
                          if(nchjp.le.nchj)then
                            nchl=nchjp
                            nchh=nchj
                          else
                            nchl=nchj
                            nchh=nchjp
                          endif
                        endif
!
! LOOP-OVER MENG0 UPPER STATE SCATTERING ENERGIES
!
                        DO M0=1,MENG0
!
                          M=IYY0(M0)
!
                          if(mx.gt.0)then                        !interp
!
                            ml=mlim(m,1)
                            mu=mlim(m,2)
!
                            if(bdip)mu=-mu                  !flag dipole
!
                            RHO=-2*XINT(DE,DYY,NLAG,TMP(1,M),M,ml,mu)
                                                                   !A.U.
!
                          else                             !already have
!
                            RHO=RHO2(M0,NOMTG)
!
                          endif
!
                          RHOSQ=RHO*RHO
! store for ii
                          if(bunit2)then
                            bst=j1.eq.j1p.and.li.eq.lf.and.kayi.eq.kayf
                            if(bst.neqv.(nchj.eq.nchjp))then
                              stop 'dwbp: diagonal index issue?'
                            endif
                            nx=irow(nchl,nchh,izero,nchjt)
                            rhom(nx,m0)=rho
                            go to 198
                          endif
!
!                          IF(NCHJ.eq.NCHJP)THEN            !DIAGONAL MX
!
                          btest=j1.eq.j1p.and.li.eq.lf.and.kayi.eq.kayf
                          if(btest)then
!
                            IF(BRMX)THEN                !USUAL REACTANCE
                              T=PI*PSHFTX(M,L0)
                              CT=COS(T)
                              ST=SIN(T)
                              RMX=(ST+RHO*CT)/(CT+RHO*ST)
                            ENDIF
!
                            IF(BPRNT3)WRITE(MW6,10040)NCHL,NCHH,JL,JH,  &
     &                         PSHFTX(M,L0),M0,'PHASE SHIFT'
                            T=TPI*PSHFTX(M,L0)
                            C2T=COS(T)
                            S2T=SIN(T)
!
                            if(bunit)then                   !2x2 UNITARY
                              TSQ=DONE+(C2T*(RHOSQ-DONE)+DTWO*S2T*RHO)  &
     &                            /(RHOSQ+DONE)
                            else                            !non-unitary
                              tsq=done+(dtwo*s2t*rho-c2t)
                            endif
!
                            TSQ=TSQ+TSQ     ! T^R=1+EXP(2I*TAU)(T^RHO-1)
!
                          ELSE                             !OFF DIAGONAL
!
                            IF(BRMX)THEN                !USUAL REACTANCE
                              T1=TPI*PSHFTX(M,L0)
                              T2=TPI*PSHFTX(M,L00)
                              DET=COS(T1)*COS(T2)-RHOSQ*SIN(T1)*SIN(T2)
                              RMX=RHO/DET
                            ENDIF
!
                            TSQ=4*RHOSQ      ! |T^R(V,V')|=|T^RHO(V,V')|
!
                            if(bunit)TSQ=TSQ/(DONE+RHOSQ)**2 !~UNITARITY
!
!                                    !FOR ELASTIC LI.NE.LF .OR. KI.NE.KF
                            IF(J1.EQ.J1P)TSQ=TSQ+TSQ
!
                          ENDIF
!
                          if(tsq.lt.d1m20)tsq=dzero
!
                          IF(BPRNT3)THEN
                            IF(BRMX)THEN
                              WRITE(MW6,10040)NCHL,NCHH,JL,JH,RMX,M0,   &
     &                              'R-MATRIX  '
                            ELSE
                              WRITE(MW6,10040)NCHL,NCHH,JL,JH,RHO,M0,   &
     &                              'RHO-MATRIX'
                            ENDIF
                          ENDIF
!
                          OMPW=wait*TSQ*NWTJ/DTWO
!
                          if(bht)ompw=ompw/2   !for BHT(1970) comparison
!
! LOOK AT TOP-UP ISSUES, IF L LARGE ENOUGH TO WARRANT IT (OFF IF BTHRSH)
!
                          IF(JNEW.GE.LRGLMN)THEN
!                                                     !NON-DIPOLE TOP-UP
                            IF(OMGINF(NOMT).GT.DZERO.AND.litlam.GT.0)   &
     &                         THEN
!
                              IF(JNEW.EQ.LRGLAM)THEN       !APPLY TOP-UP
                                EJ=DYY0(M0)
                                EI=EJ+DE
!
                                ompw0=ompw
                                ompw=ompw/wait
                                IF(BPRNT3)OMPW=-OMPW         !FLAG PRINT
!
                                CALL TOP2(LITLAM,LRGLAM/2,EI,EJ,OMPW)
!
                                ompw=ompw+ompw0*(wait-done)/wait !adjust
!
                              ELSEIF(JNEW.GT.LRGLAM)THEN
                                OMPW=DZERO
                              ENDIF
!                                                  !DIPOLE:LITLAM=LRGLAM
                            ELSEIF(bdip)THEN              !POSS ZERO-OUT
!                                            !ZERO-OUT AS INC. IN TOP-UP
                              IF(MAX(LI,LF).GT.LRGLAM)OMPW=DZERO
!
                            ENDIF
!
                          ENDIF
!
! ARCHIVE PARTIAL/TOTAL COLLISION STRENGTHS
!
                          IF(BTHRSH)THEN
                            M00=LUP/2+1-LVMIN
                            IF(M00.LT.1.OR.M00.GT.MOGGY)GO TO 200
                          ELSE               !CASE NOT XCLUDED BY ALGXLS
                            M00=M0
                          ENDIF
!
                          OMP(M0)=OMPW
!                                                    !UPDATE TOTAL OMEGA
                          OMEGA(M00,NOMT)=OMEGA(M00,NOMT)+REAL(OMPW,RP)
!
  198                   ENDDO                    !END LOOP OVER ENERGIES
!                                                         !PARTIAL OMEGA
                        IF(BPRNT2.and..not.bunit2)THEN
                          WRITE(MW6,10030)NCHL,NCHH,JL,JH,              &
     &                                    (OMP(M0),M0=1,MENG0)
                        ENDIF
!
  200                 ENDDO                  !END LOOP OVER FINAL LEVELS
!
  202               ENDDO                  !END LOOP OVER INITIAL LEVELS
!
                    if(btimet)then
                      call nrb_time(timef)
                      timeint=timeint+timef-timei
                      timei=timef
                    endif
!
!-----------------------------------------------------------------------
!
                  ENDDO                           !END LOOP OVER FINAL L
!
                ENDDO                           !END LOOP OVER INITIAL L
!
              ENDDO                       !END LOOP OVER FINAL JP GROUPS
!
            ENDDO                       !END LOOP OVER INITIAL JP GROUPS
!
          ENDDO                                   !END LOOP OVER FINAL K
!
        ENDDO                                   !END LOOP OVER INITIAL K
!
        if(bntest)then
          do i=1,nchjt
            if(ntest(i,i).ne.1)then
              write(mw0,*)'checksum wrong for nchj,nchj ',i,' :',       &
     &                    ntest(i,i)
            endif
            do j=i+1,nchjt
              if(ntest(i,j)+ntest(j,i).ne.1)then
                write(mw0,*)'checksum wrong for nchj,nchjp',i,j,' :',   &
     &                      ntest(i,j),ntest(j,i)
              endif
            enddo
          enddo
        endif
!
! now determine t-matrix from full rho-matrix for approximation-ii:
!
        if(bunit2)then
!
          do m0=1,meng0
            m=iyy0(m0)
!
            if(m0.gt.0)then                                      !LAPACK
             call pqlap(nchjt,rhom(1,m0),wrkp,wrkq,work,nf)      !LAPACK
            else                                                 !LAPACK
            call pq(nchjt,rhom(1,m0),wrkp,wrkq,work,nf)
            endif                                                !LAPACK
!
            if(nf.le.0)go to 500
!
            do nchj=1,nchjt
!
              j=iwrkn(nchj)
              if(j.le.0)go to 210
              l0=iwrkl(nchj)
!
              do nchjp=nchj,nchjt
!
                jp=iwrkn(nchjp)
                if(jp.le.0)go to 205
!
                n=irow(nchj,nchjp,izero,nchjt)
                tp=-2*wrkp(n)                 !real T^rho
                tq=-2*wrkq(n)                 !imag T^rho
!
                if(nchj.eq.nchjp)then
                  t=tpi*pshftx(m,l0)
                  if(bprnt2)then
                    write(mw6,10040)nchj,nchjp,j,jp,pshftx(m,l0),m0,    &
     &                              'phase shift'
                  endif
                  c2t=cos(t)
                  s2t=sin(t)
                  tp1=tp-done
!                  tr=done+c2t*tp1-tq*s2t
!                  ti=s2t*tp1+c2t*tq
!                  tsq=tr*tr+ti*ti
                  tsq=done+(2*c2t+tp1)*tp1-(2*s2t-tq)*tq
                else
                  tsq=tp*tp+tq*tq
                  if(j.eq.jp)tsq=tsq+tsq
                endif
!
                ompw=wait*tsq*nwtj/dtwo
!
                if(bht)ompw=ompw/2      !for bht(1970) comparison
!
                if(j.le.jp)then
                  jl=j
                  jh=jp
                  nchl=nchj
                  nchh=nchjp
                else
                  jl=jp
                  jh=j
                  nchl=nchjp
                  nchh=nchj
                endif
!
                nomt=irow(jl,jh,ione1,nspecj)
! some top-up
                if(jnew.ge.lrglmn)then             !look at top-up
!
                  if(omginf(nomt).gt.dzero)then        !non-dipole
!
                    if(jnew.eq.lrglam)then           !apply top-up
                      de=dspecj(jh)-dspecj(jl)
                      ej=dyy0(m0)
                      ei=ej+de
!
                      ompw0=ompw
                      ompw=ompw/wait
                      if(bprnt3)ompw=-ompw             !flag print
!
                      call top2(itwo,lrglam/2,ei,ej,ompw)
!
                      ompw=ompw+ompw0*(wait-done)/wait     !adjust
!
                    elseif(jnew.gt.lrglam)then
                      ompw=dzero
                    endif
!
                  elseif(omginf(nomt).lt.dzero)then        !dipole
                    if(jnew.gt.lrglam)ompw=dzero
                  endif
!
                endif
!
                omp(m0)=ompw
                omega(m0,nomt)=omega(m0,nomt)+real(ompw,rp)
                if(bprnt2)write(mw6,10030)nchl,nchh,jl,jh,tp,tq,omp(m0)
!
  205         enddo
!
  210       enddo
            if(bprnt2)write(mw6,*)':'
!
          enddo
!
          if(btimet)then
            call nrb_time(timef)
            timeunit=timeunit+timef-timei
          endif
!
          deallocate(rhom,wrkp,wrkq,iwrkn,iwrkl,work,stat=ierr)
!
          if(ierr.ne.0)then
            write(mw0,*)'dwxbp: de-allocation fails for rhom,wrk'
            nf=0
            go to 900
          endif
!
        endif
!
!-----------------------------------------------------------------------
!
        if(btimet)then
          write(iw,*)'  set-up time=',nint(timeset),'sec'
          write(iw,*)'   mixi  time=',nint(timemixi),'sec'
          write(iw,*)'   mixf  time=',nint(timemixf),'sec'
          write(iw,*)'   mixir time=',nint(timemixir),'sec'
          write(iw,*)'   mixfr time=',nint(timemixfr),'sec'
          timemix=timemixi+timemixf+timemixir+timemixfr
          write(iw,*)'  mixing time=',nint(timemix),'sec'
          write(iw,*)'  interp time=',nint(timeint),'sec'
          if(bunit2)write(iw,*)' unitary time=',nint(timeunit),'sec'
        endif
!
        if(btimex)then
          call nrb_time(timef)
          times=timef-timej
!
!par          if(iam.ge.0)then                                      !par
!par            write(iwp,*)'Ending proc',iam                       !par&
!par     &               ,'dwxbp symmetry',kx,':',' nchan='         !par&
!par     &               ,nchsjt,'(',nchjt,')'                      !par&
!par     &               ,'  time=',nint(times),'sec'               !par
!par            call flush(iwp)                                     !par
!par          else                                                  !par
          write(iw,*)'Ending dwxbp symmetry ',kx,':',' nchan=',nchsjt,  &
     &               '(',nchjt,')','  time=',nint(times),'sec'
!par          endif                                                 !par
        endif
!
!-----------------------------------------------------------------------
!
!                                          -----------------------------
      ENDDO                                !END LOOP OVER TOTAL JP SYMMS
!                                          -----------------------------
!
!par!                                                               !par
!par      if(iam.ne.0)then                                          !par
!par        if(btimex)then                                          !par
!par          btimep=.false.                                        !par
!par          call nrb_time(timef)                                  !par
!par          times=timef-time0                                     !par
!par!                                                               !par
!par          write(iw,*)'Ending proc',iam,' for dwxbp:'            !par&
!par     &             ,' time=',nint(times),'sec'                  !par
!par        endif                                                   !par
!par      endif                                                     !par
!par!                                                               !par
!par      ns=0                                                      !par
!par      nr=0                                                      !par
!par      itmp4=int(nomwrt,sp_mpi)                                  !par
!par!                                                               !par
!par      do m0=1,moggy                                             !par
!par!                                                               !par
!par        call pomsend(ns,omega(1,1),nomwrt,omsend)               !par
!par!                                                               !par
!par        call comm_barrier()                                     !par
!par!                                                               !par
!par        call mpi_reduce(omsend,omrecv,itmp4,my_mpi_real,        !par&
!par     &                  mpi_sum,izero_mpi,mpi_comm_world,ier4)  !par
!par!                                                               !par
!par        if(ier4.ne.0)write(mw0,*)'mpi_reduce: iam,ier=',iam,ier4!par
!par!                                                               !par
!par        call comm_barrier()                                     !par
!par!                                                               !par
!par        if(iam.eq.0)call pomrecv(nomwrt,omrecv,nr,omega(1,1))   !par
!par!                                                               !par
!par      enddo                                                     !par
!par!                                                               !par
!par      if(iam.ne.0)go to 5000                                    !par
!par!                                                               !par
!
! APPLY (DIPOLE) TOP-UP (OFF IF BTHRSH)
!
      IF(LRGLAM.GT.1)THEN
!
        WRITE(MW6,10210)LRGLAM
        if(btimex)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Proc',iam,                                !par&
!par     &       'Top-up has been applied: lrglam=',lrglam          !par
!par        else                                                    !par
          write(iw,*)'Top-up has been applied: lrglam=',lrglam
!par        endif                                                   !par
        endif
        IF(BPRNT2)WRITE(MW6,10060)
!
        LITLAM=LRGLAM/2                           !USE GLOBAL VALUE JA=0
        CO2S=D3QRT/LOG(EINF*DZ2)
!
        NOMT=0
        DO I=1,NMETAJ                                       !,NSPECL
!          IF(INDXJ(I).GT.0)THEN                               !NON-CORR
!
          DO J=I+ione1,NSPECJ                                !,NSPECL
!            IF(INDXJ(J).GT.0)THEN                             !NON-CORR
!
            NOMT=NOMT+1
            SS=OMGINF(NOMT)
!
            IF(SS.LT.DZERO)THEN                                  !DIPOLE
              SS=SS*CO2S                       !CONVERT TO LINE STRENGTH
              DE=DSPECJ(J)-DSPECJ(I)
              DE=DE/DZ2
              DO M0=1,MENG0
                EJ=DYY0(M0)/DZ2
                EI=EJ+DE
!
                CALL TOP1(NZA,LITLAM,EI,EJ,SS,OMT)
!
                if(bht)omt=omt/2               !for BHT(1970) comparison
!
                OM=REAL(OMEGA(M0,NOMT),WP)
                OMEGA(M0,NOMT)=OMEGA(M0,NOMT)+REAL(OMT,RP)
!
                IF(BPRNT2)WRITE(MW6,10070)I,J,SS,EI,EJ,DE,OM,OMT,OM+OMT
              ENDDO
            ENDIF
!
!              IF(NOMT.EQ.NOMWRT)GO TO 113                  !WE ARE DONE
!            ENDIF
          ENDDO
!
!          ENDIF
        ENDDO
!
      ELSE
!
        WRITE(MW6,10220)
        if(btimex)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Proc',iam,'Top-up has *NOT* been applied!'!par
!par        else                                                    !par
          write(iw,*)'Top-up has *NOT* been applied!'
!par        endif                                                   !par
        endif
!
      ENDIF
!
! 113  CONTINUE
!
! fix top-up failure on high-e near-degenerate Born allowed transitions
!
      if(btop)then
        NOMT=0
        DO I=1,NMETAJ
          DO J=I+ione1,NSPECJ
            NOMT=NOMT+1
            OMB=OMGINF(NOMT)
            IF(OMB.GT.DZERO)THEN                                   !born
              DE=DSPECJ(J)-DSPECJ(I)
              DE=MAX(DE,D1M30)
              OM=REAL(OMEGA(2,NOMT),WP)
              DO M0=3,MENG0                        !skip threshold point
                RAT=DYY0(M0)/DE
                OM1=OM
                OM=REAL(OMEGA(M0,NOMT),WP)
                IF(RAT.GT.XBTEST.AND.OM.LT.D0PT8*OM1.AND.OM1.LT.OMB)THEN
                  MM=M0-1              !max(2,m0-1) if no threshold skip
                  GO TO 215
                ENDIF
              ENDDO
              M0=MENG0
              MM=M0+1
              IF(OM1.GE.OMB)THEN
                IF(OM.LT.OMB)MM=MENG0
              ELSE
                IF(OM.LT.OM1)MM=MENG0
              ENDIF
  215         IF(BPRNT2.AND.MM.LE.MENG0)THEN
                WRITE(MW6,10110)I,J,DYY0(M0),DE,RAT,                    &
     &                          (OMEGA(M,NOMT),M=1,MENG0),OMB
              ENDIF
              DO M0=MM,MENG0
                OMEGA(M0,NOMT)=REAL(OMB,RP)
              ENDDO
            ENDIF
          ENDDO
        ENDDO
      endif
!
! test convert to cross section
!
      if(bcrossx)then
        nomt=0
        do i=1,nmetaj
          j=indxj(i)
          wi=jn(j)+1
          do j=i+ione1,nspecj
            nomt=nomt+1
            de=dspecj(j)-dspecj(i)
            do m0=1,moggy
              ej=dyy0(m0)
              ei=ej+de
              if(brel)ei=ei+dalf4*ei*ei          !wavenumber
              om=real(omega(m0,nomt),wp)
              om=xconv*om/(ei*wi)
              omega(m0,nomt)=real(om,rp)
            enddo
          enddo
        enddo
      endif
!
!-----------------------------------------------------------------------
!
! WRITE TOTALS
!
      IF(BTHRSH)THEN
        WRITE(MW6,10200)
        IF(BPRNT0)THEN
          WRITE(MW6,10310)((I,J,J=I+ione1,NSPECJ),I=1,NMETAJ)   !ROWWISE
          DO M0=1,MOGGY
            WRITE(MW6,10020)REAL(M0-1+LVMIN),(OMEGA(M0,N),N=1,NOMWRT)
          ENDDO
        ENDIF
      ELSE
        WRITE(MW6,10190)
        IF(BPRNT0)THEN
          WRITE(MW6,10300)((I,J,J=I+ione1,NSPECJ),I=1,NMETAJ)   !ROWWISE
          DO M0=1,MENG0                                         !=MOGGY
            WRITE(MW6,10020)DYY0(M0),(OMEGA(M0,N),N=1,NOMWRT)
          ENDDO
        ENDIF
      ENDIF
!
      IF(IUNIT(MRW24).GT.0)THEN
!        if(iunit(MRW23).lt.0)then                 !same status as MRW24
        OPEN(MRW23,FILE='OMGINFLS',STATUS='OLD')
        CLOSE(MRW23,STATUS='DELETE')                            !tidy-up
        IUNIT(MRW23)=-1
!        endif
        CLOSE(MRW24,STATUS='DELETE')
        IF(BTHRSH.or..not.bomega)THEN
          IUNIT(MRW24)=-1
        ELSE
          OPEN(MRW24,FILE='OMEGAIC',STATUS='REPLACE')      !USE NEW NAME
!TBD     OPEN(MRW24,FILE='OMEGAUIC',STATUS='REPLACE',FORM='UNFORMATTED')
          WRITE(MRW24,*)NZION,MION
          WRITE(MRW24,*)NSPECJ,-(MENG0+1),NOMWRT      !FLAG NO E'S .LT.0
          WRITE(MRW24,*)('  0',IWRK3(I),I=1,NSPECJ)
          WRITE(MRW24,10050)(DWRK(I),I=1,NSPECJ)
          DO M0=1,MENG0                                          !=MOGGY
            WRITE(MRW24,F713)DYY0(M0)/DZ2,(OMEGA(M0,N),N=1,NOMWRT)
          ENDDO
          WRITE(MRW24,F713)EINF,(OMGINF(N),N=1,NOMWRT)
          IUNIT(MRW24)=-1
          CLOSE(MRW24)
        ENDIF
      ENDIF
!
! OVERWRITE PWB ADF04 WITH DW, TAKING ACCOUNT OF THE FACT THAT THE PWB
! DOES NOT CONTAIN (SPIN) FORBIDDEN TRANSITIONS
!
      IF(IUNIT(MRW26).GE.0)THEN         !NO ADF04, LIKELY SINCE RAD='NO'
        WRITE(MW6,*)'NO ADF04 FILE="adf04ic"...'
        WRITE(MW0,*)'NO ADF04 FILE ON UNIT=MRW26'
!        NF=-1
        GO TO 500
      ELSEIF(IUNIT(MRW26).LT.0)THEN
        IUNIT(MRW26)=1
        OPEN(MRW26,FILE='adf04ic',STATUS='OLD',ERR=500)
      ENDIF
!
      BEXP=.FALSE.                              !*MUST* SYNC WITH DIAGFS
      IF(NSPECJ.LT.1000)THEN
        i1=0
        IF(MOGGY.LE.20)THEN
          IF(BEXP)THEN
            F761='(F5.2, I5, 8X,20(1PE10.2))'
            F762='(2I4,22(1PE10.2))'
            F767='(18X,21(F10.5))'
          ELSE
            F761='(A5,A3,I2, 6X, 20(A5, A3))'
            F762='(2I4, 22(A5, A3))'
            F767='(16X,21(F8.5))'
          ENDIF
        ELSE
          IF(BEXP)THEN
            F761='(F5.2, I5, 8X,20(1PE10.2)/(18X,20(1PE10.2)))'
            F762='(2I4,21(1PE10.2)/(18X,20(1PE10.2)))'
          ELSE
            F761='(A5,A3,I2, 6X, 20(A5, A3)/(16X, 20(A5, A3)))'
            F762='(2I4, 21(A5, A3)/(16X, 20(A5, A3)))'  !WRAP LAST POINT
          ENDIF
        ENDIF
      ELSE
        i1=1
        IF(MOGGY.LE.20)THEN
          IF(BEXP)THEN
            F761='(F5.2, I5,10X,20(1PE10.2))'
            F762='(2I5,22(1PE10.2))'
            F767='(20X,21(F10.5))'
          ELSE
            F761='(A5,A3,I2, 8X, 20(A5, A3))'
            F762='(2I5, 22(A5, A3))'
            F767='(18X,21(F8.5))'
          ENDIF
        ELSE
          IF(BEXP)THEN
            F761='(F5.2, I5,10X,20(1PE10.2)/(20X,20(1PE10.2)))'
            F762='(2I5,21(1PE10.2)/(20X,20(1PE10.2)))'
          ELSE
            F761='(A5,A3,I2, 8X, 20(A5, A3)/(18X, 20(A5, A3)))'
            F762='(2I5, 21(A5, A3)/(18X, 20(A5, A3)))'  !WRAP LAST POINT
          ENDIF
        ENDIF
      ENDIF
!
      MSC0=80
      OPEN(MSC0,STATUS='SCRATCH',FORM='FORMATTED')
      IF(.NOT.BEXP)THEN
        MSCP=81
        OPEN(MSCP,STATUS='SCRATCH',FORM='FORMATTED')
      ENDIF
!
      DO N=1,NSPECJ+2
        READ(MRW26,10100)CARD
        WRITE(MSC0,10100)CARD
      ENDDO
!
      NNN=max(NOMWRT,nomwr0)
!
      DO N=1,NNN+2
        READ(MRW26,10100,END=300)CARD
        WRITE(MSC0,10100)CARD
      ENDDO
!
  300 REWIND(MRW26)
      REWIND(MSC0)
!
      DO N=1,NSPECJ+2
        READ(MSC0,10100)CARD
        WRITE(MRW26,10100)CARD
      ENDDO
!
      IF(BTHRSH)THEN
        ITYPE=6
        WRITE(MRW26,F767)(PSHFT0(M-1+LVMIN),M=1,MOGGY)
        IF(BEXP)THEN
          WRITE(MRW26,F761)REAL(NZA+1),ITYPE,(REAL(M-1+LVMIN),M=1,MOGGY)
        ELSE
          WRITE(MSCP,10130)(REAL(M-1+LVMIN),M=1,MOGGY)
        ENDIF
      ELSE
        ITYPE=5
        IF(BEXP)THEN
          WRITE(MRW26,F761)REAL(NZA+1),ITYPE,(DYY0(M),M=1,MENG0) !=MOGGY
        ELSE
          WRITE(MSCP,10130)(DYY0(M),M=1,MENG0)                   !=MOGGY
        ENDIF
      ENDIF
!
      IF(BEXP)THEN
        READ(MSC0,F761)
      ELSE
        BACKSPACE(MSCP)
        READ(MSCP,10140)(XMANT(M),IEXP(M),M=1,MOGGY)
        iexp(0)='   '
        READ(MSC0,F761)XMANT(0)                                !,IEXP(0)
        WRITE(MRW26,F761)XMANT(0),IEXP(0),ITYPE,                        &
     &                   (XMANT(M),IEXP(M),M=1,MOGGY)
      ENDIF
!
      MENG1=MOGGY+1
      IB0=1
      JB0=IB0+IONE1
!
      ntr=0
!
      DO N=1,NNN+1
!
        IF(BEXP)THEN
          READ(MSC0,F762)JB,IB,XB0,(DUM,I=1,MXNXB),XB1
        ELSE
          READ(MSC0,F762)JB,IB,XMANT0,IEXP0,(XMANT(I),IEXP(I),I=1,MXNXB)&
     &                   ,XMANT1,IEXP1
        ENDIF
!
        JB1=JB
        IF(JB.LT.0)THEN
          JB1=NSPECJ
          IB=MIN(JB1-IONE1,NMETAJ)
          IF(BEXP)THEN
            XB0=D1M30
            XB1=DZERO
          ELSE
            XMANT0=' 1.00'
            IEXP0='-30'
            XMANT1=' 0.00'
            IEXP1='+00'
          ENDIF
        ENDIF
!
        IF(BEXP)THEN
          X0=D1M30
          X1=DZERO
        ELSE
          XMANT(0)=' 1.00'
          IEXP(0)='-30'
          XMANT(MENG1)=' 0.00'
          IEXP(MENG1)='+00'
        ENDIF
!
        DO JT=JB0,JB1
          IF(JT.EQ.JB1)THEN
            IB1=IB
          ELSE
            IB1=MIN(JT-IONE1,NMETAJ)
          ENDIF
          DO IT=IB0,IB1
!
!test        if(ione1.eq.0.or.it.ne.jt)then   !catch ione1=0 diagfs only
            ntr=ntr+1
!
            NOMT=IROW(IT,JT,IONE1,NSPECJ)
!                                            !TEST MENG0 STILL IF BTHRSH
            IF(OMEGA(MENG0,NOMT).GT.TOLO)THEN          !SKIP SA-SAP.GT.1
!
!              if(omginf(nomt).lt.dzero)then  !test write reduced dipole
!                do m=1,moggy
!                  de=log(dyy0(m)+2.7183)
!                  omega(m,nomt)=omega(m,nomt)/de
!                enddo
!              endif
!
              IF(BEXP)THEN
                IF(JT.EQ.JB1.AND.IT.EQ.IB1)THEN             !NOW ALLOWED
                  X0=XB0
                  X1=XB1
                ENDIF
                WRITE(MRW26,F762)JT,IT,X0,(OMEGA(M,NOMT),M=1,MOGGY),X1
              ELSE
                BACKSPACE(MSCP)
                WRITE(MSCP,10130)(OMEGA(M,NOMT),M=1,MOGGY)
                BACKSPACE(MSCP)
                READ(MSCP,10140)(XMANT(M),IEXP(M),M=1,MOGGY)
                IF(JT.EQ.JB1.AND.IT.EQ.IB1)THEN             !NOW ALLOWED
                  XMANT(0)=XMANT0
                  IEXP(0)=IEXP0
                  XMANT(MENG1)=XMANT1
                  IEXP(MENG1)=IEXP1
                ENDIF
                WRITE(MRW26,F762)JT,IT,(XMANT(M),IEXP(M),M=0,MENG1)
              ENDIF
!
            ENDIF
!test        endif
          ENDDO
          IB0=1
        ENDDO
!
        IF(JB.LT.0)then
          if(ntr.ne.nomwrt)then                                !checksum
            write(mw6,*)                                                &
     &                 'adf04 no. of transitions mis-match: ntr,nomwrt='&
     &                 ,ntr,nomwrt
            write(mw0,*)'adf04 no. of transitions mis-match'
            nf=-1
            go to 500
          endif
          GO TO 400
        endif
!
        JB0=JB
        IB0=IB+1
!
      ENDDO
!
      WRITE(MW0,*)'SR.DWXBP: HAVE NOT REACHED END OF adf04ic...'
      WRITE(MW6,*)'SR.DWXBP: HAVE NOT REACHED END OF adf04ic...'
      NF=-1
      GO TO 500
!
  400 WRITE(MRW26,F762)-1
      WRITE(MRW26,F762)-1,-1
!
      if(.not.badas)then                             !adas skip comments
        WRITE(MRW26,10080)
!
        NREC=1
  450   NREC=NREC+1
        BACKSPACE(MR5)
        BACKSPACE(MR5)
        READ(MR5,10150)CARD4
        IF(CARD4.NE.'A.S.'.AND.CARD4.NE.'S.S.')GO TO 450
        REWIND(MR5)
!
        DO N=1,NREC
          READ(MR5,10100)CARD
          WRITE(MRW26,10090)CARD
        ENDDO
        DATE='        '
        CALL DATE_AND_TIME(DATE)
        WRITE(MRW26,10120)DATE(7:7),DATE(8:8),DATE(5:5),DATE(6:6),      &
     &                    DATE(3:3),DATE(4:4)
      endif
!
      IUNIT(MRW26)=-1
      CLOSE(MRW26)
!
      CLOSE(MSC0)
      IF(.NOT.BEXP)CLOSE(MSCP)
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par 5000 continue                                                  !par
!
  500 CONTINUE
!
      DEALLOCATE(KACT,KTMP,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXBP: DE-ALLOCATION FAILS FOR KACT,KTMP'
        NF=0
        GO TO 900
      ENDIF
!
  600 CONTINUE
!
      DEALLOCATE(PSHFT0)                                          !SMALL
!
      DEALLOCATE(RHO1,RHO2,TEMP,OMGINF,OMEGA,STAT=IERR)
!par!                                                               !par
!par      deallocate(omsend,omrecv,stat=ierr)                       !par
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXBP: DE-ALLOCATION FAILS FOR RHO,OMEGA,TEMP'
        NF=0
        GO TO 900
      ENDIF
!
  700 DEALLOCATE(TFU,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXBP: DE-ALLOCATION FAILS FOR TFU'
        NF=0
        GO TO 900
      ENDIF
!
  800 CONTINUE
!
      DEALLOCATE(QPX,QPX0,QPOSJ)
      DEALLOCATE(NADRUG,NTGJ)
      DEALLOCATE(TMP,OMP)
      DEALLOCATE(IEXP,XMANT)
      IF(ALLOCATED(DWRK))DEALLOCATE(DWRK,IWRK3,IWRK4)
!
      deallocate(bswap)
      if(allocated(bswapj))deallocate(bswapj)
!par!                                                               !par
!par 5500 continue                                                  !par
!
  900 CONTINUE
!
!-----------------------------------------------------------------------
!
      if(btimep)then
        call nrb_time(timef)
        times=timef-time0
!
!        if(abs(modd).le.1)then
!
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Ending proc',iam,' for dwxbp:'            !par&
!par     &               ,' time=',nint(times),'sec,     '          !par&
!par     &               ,nint(times/60),'min'                      !par
!par          call flush(iw)                                        !par
!par        else                                                    !par
        write(iw,*)'Ending dwxbp: time=',nint(times),'sec,     ',       &
     &             nint(times/60),'min'
!par        endif                                                   !par
!        endif
      endif
!
!-----------------------------------------------------------------------
!
      RETURN
10010 FORMAT(2I5,2x,2I5,1p,10D12.3/(10x,10D12.3))
!
!-----------------------------------------------------------------------
!
10020 FORMAT(F21.3,2X,1P,10(E11.3)/(23X,10(E11.3)))
10030 FORMAT(2I6,3X,2I5,2X,1P,10(E11.3)/(27X,10(E11.3)))
10040 FORMAT(2I6,3X,2I5,2X,1PE11.3,10X,'E(',I2,')   ',A11)
10050 FORMAT(1P,5E16.6)
!10060 FORMAT(1PE14.8,6E11.3/(14X,6E11.3))
10060 FORMAT(3X,'CH',2X,'CHP',9X,'S',14X,'EI',10X,'EJ',10X,'DE',9X,     &
     &       'OMEGA(PAR)',2X,'OMEGA(TOP)',4X,'OMEGA(TOT)')
10070 FORMAT(2I5,3X,1PE11.3,2X,0P,3F12.4,5X,2F12.4,2X,F12.4)
10080 FORMAT('C',79('-')/'C'/'C')
10090 FORMAT('C ',A200)
10100 FORMAT(A200)
10110 FORMAT(2I5,22(1PE10.2))
10120 FORMAT('C'/'C'/'C',79('-')/'C'/'C',1X,                            &
     &       'AUTOSTRUCTURE DISTORTED-WAVE'/'C'/'C NAME:'/'C DATE: ',   &
     &       2(A1),'/',2(A1),'/',2(A1)/'C'/'C',79('-'))
10130 FORMAT(22(1PE9.2))
10140 FORMAT(22(A5,1X,A3))
10150 FORMAT(A4)
10160 FORMAT(1X,3I10,13X,I7,3I5,F19.8)
10170 FORMAT(10X,'K',8X,'LV',8X,' T',17X,'2*S+1  L   2J   CF',9X,       &
     &       '(EK-E1)/RY',15X,'NMETAJ=',I5)
10180 FORMAT(//' *** FULLY UNITARIZED K- TO T-MATRIX CONVERSION ***'//)
10190 FORMAT(///1X,136('-')//51X,                                       &
     &       '*** TOTAL COLLISION STRENGTHS (BP) ***'//1X,136('-')//)
10200 FORMAT(///1X,136('-')//45X,                                       &
     &       '*** THRESHOLD PARTIAL COLLISION STRENGTHS (BP) ***'//1X,  &
     &       136('-')//)
10210 FORMAT(//' *** TOP-UP HAS BEEN APPLIED: LRGLAM=',I5//)
10220 FORMAT(//' *** TOP-UP HAS *NOT* BEEN APPLIED ***'//)
10230 FORMAT(//1X,136('-')///49X,'*** TARGET ENERGIES (IC) ***'/)
10240 FORMAT(//1X,136('-')/)
10250 FORMAT(' SYJ=',I3,5X,'2J P =',I4,I3,5X,'NCHJT=',I6,2X,'(',I6,')')
10260 FORMAT(//' SY1=',I3,5X,'(2S+1) L P =',I3,I4,I3)    !/1X,34('-'))
10270 FORMAT(//' SYJ=',I3,5X,'2J P =',I4,I3/1X,25('-'))
10280 FORMAT(//' SY2=',I3,5X,'(2S+1) L P =',I3,I4,I3)    !/1X,34('-'))
10290 FORMAT(/4X,'CH',3X,'CHP',7X,'K',3X,'KP',4X,'OMEGA(IE=1,MENG):')
10300 FORMAT(74X,'OMEGA(K-KP)'/74X,11('-')/2X,'*FINAL* ENERGY(RYD)',2X, &
     &       10(I5,'-',I5)/(23X,10(I5,'-',I5)))
10310 FORMAT(74X,'OMEGA(K-KP)'/74X,11('-')/1X,'*FINAL* RYDBERG A.M.',2X,&
     &       10(2X,I4,'-',I4)/(23X,10(2X,I4,'-',I4)))
10320 FORMAT(//'Note: Elastic collision strengths maybe somewhat',      &
     &       ' inaccurate as not all phases are present...'/'In-elastic'&
     &       ,' collision strengths are unaffected'//                   &
     &       'Set kutssx.ne.-1 and',                                    &
     &       ' maxjfs=-1 to correct this - if memory allows')
10330 FORMAT(//'Note: R-matrix elements maybe somewhat inaccurate',     &
     &       ' as not all phases are present...'/                       &
     &       'rho-matrix and partial',                                  &
     &       ' collision strengths are unaffected'//                    &
     &       'Set kutssx.ne.-1 and',                                    &
     &       ' maxjfs=-1 to correct this - if memory allows')
10340 FORMAT(//'Note: elastic transitions maybe somewhat inaccurate',   &
     &       ' as not all phases are present...'/                       &
     &       'Inelastic partial collision',                             &
     &       ' strengths maybe affected indirectly'//                   &
     &       'Set kutssx.ne.-1 and',                                    &
     &       ' maxjfs=-1 to correct this - if memory allows')
10350 FORMAT(/'    NCYC SY   CH  CHP     MNF  MNR',                     &
     &       6(3X,'I(R)  F(A,...)'))
10360 FORMAT(i9,i5,2I4,2I5,i9,i6,6(i6,f9.4))
10370 FORMAT(i9,i5,2I4,2I5,i9,i6,6(i6,f9.4)/(47x,6(i6,f9.4)))
10380 FORMAT(/' *** UPDATING SLATER INTEGRALS FOR LTOT=',I3/1X,42('-')/)
10390 FORMAT(/' *** UPDATING MAGNETIC INTEGRALS FOR 2*JTOT=',I3/1X,     &
     &       46('-')/)
10400 FORMAT(7X,'NP',2X,'SYJ',2X,'SY',1X,'SYP',3X,'CH',2X,'CHP',7X,'CN',&
     &       3X,'IND',6(3X,'I(Y)  X(A-D)'))
10410 FORMAT(i8,i3,2I5,i8,i5,6(i6,f11.6))
10420 FORMAT(i8,i3,2I5,i8,i5,6(i6,f11.6)/(34x,6(i6,f11.6)))
10430 FORMAT((34x,6(i6,f11.6)))
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!-----------------------------------------------------------------------
      FUNCTION IROW(ILI,ILF,IONE1,NENG)
!
      INTEGER(SP) ILI,ILF,IONE1,NENG,IROW
!
      IROW=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE1))/2
!
      END FUNCTION IROW
!-----------------------------------------------------------------------
!
      END SUBROUTINE DWXBP_DAXPY
!
!                             *******************
!
      SUBROUTINE DWXBP_DDOT                                             &
     &                (FRX,PSHFTX,DRLX,MDIM0,MDIM1,MDIM2,MDIM3,MDIM4    &
     &                ,MDIM5,DZLX,DXTWOX,DETAX,MDIM6,MDIM7,MDIM8        &
     &                ,DNLX,MDIM9,MDIM10)
!
!-----------------------------------------------------------------------
!
!  SR.DWXBP_DDOT
!    CALCULATES EIE BP (+2FS) COLLISION STRENGTHS IN JK-COUPLING
!
!  IT IS CALLED BY:
!    SR.DWXBP
!
!  IT CALLS:
!    SR.DATE_AND_TIME (SYSTEM)
!    SR.FSINTX
!    FN:NCHAJK
!    SR.NRB_TIME
!    SR.PQ
!    SR.PQLAP
!    FN.QPTLS
!    FN.QPTLSJ
!    SR.RADCNX
!    FN.SJS
!    SR.SLATRX
!    SR.TOP1
!    SR.TOP2
!    FN.XINT
!
!  IT CONTAINS:
!    FN.ICOL
!    FN.IROW
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam,comm_barrier               !par&
!par     &                          ,sp_mpi,izero_mpi               !par
!par      use mpi, only : mpi_real4,mpi_real8,mpi_integer           !par&
!par     &               ,mpi_sum,mpi_comm_world                    !par
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DMQSS3, ONLY: DSS,MSS,QSS,NADR                         &
     &                        ,NL000=>NL,NL=>NL000
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL,NAD
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR
      USE COMMON_MINIM,  ONLY: BECOR
      USE COMMON_MINIM,  ONLY: XMIX
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_QTG,    ONLY: NFI,NFK,NFQ
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      use common_misc,   only: ione1,ione0
      use common_misc,   only: iw,iwp,btime,btimex
      use common_misc,   only: badas
!
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,INAST0=>NASTB                            &
     &                        ,INASTJ0=>NASTJB,LFACT,JFACT              &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDW1, ONLY: MXORB,ma0,mb0
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
      USE COMMON_NRBDW4, ONLY: DSPECE,INDEX,JNDEX,NSPECE,NENERG
      USE COMMON_NRBDW5, ONLY: DYY,MENG,NLAG
      USE COMMON_NRBDW6, ONLY: QPOS,QPOS0
      USE COMMON_NRBDW7, ONLY: MNDEX,MRNDX,MTRAN,mlim
      USE COMMON_NRBDW8, ONLY: DYY0,IYY0,MENG0
      USE COMMON_NRBDW9, ONLY: DSPECJ,INDXJ,JNDXJ,NSPECJ,NENERJ
      USE COMMON_NRBDWJ, ONLY: JSYMM,NCHGJ,NADGJ,NCHSJ
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBDWX, ONLY: LLCH,ITARG,NCHG
      USE COMMON_NRBGRJ, ONLY: NSLJ,NGSLJ
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,INASTJ=>NASTJ                   &
     &                        ,MINJT,MAXJT,NEIGENJ
      USE COMMON_NRBKUT, ONLY: KCUTX,LSKUT,NASTK
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
      USE COMMON_NRBREL, ONLY: BREL
      USE COMMON_NRBRN3, ONLY: MXNXB,MXNXB1
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (MXLEN=200)                                 !CARD LENGTH
!
      PARAMETER (MXD13=500)
!
      INTEGER(SP) QPTLS,QPTLSJ                 !DO NOT USE SHORT INTEGER
!
      INTEGER(SP) SA,SAP
!par!                                                               !par
!par      integer(sp_mpi) itmp4,ier4,my_mpi_real                    !par
!par!                                                               !par
!par      real(rp) omsend,omrecv                                    !par
!
      REAL(RP) OMEGA,E1M10
!
      PARAMETER (E1M10=1.E-10_RP)
      PARAMETER (XBTEST=DFIVE)          !APPLY btop ONLY FOR X.GT.XBTEST
!
      CHARACTER(LEN=3) IEXP,IEXP0,IEXP1
      CHARACTER(LEN=4) CARD4
      CHARACTER(LEN=5) XMANT,XMANT0,XMANT1
      CHARACTER(LEN=8) DATE
      CHARACTER(LEN=15) F767
      CHARACTER(LEN=29) F713
      CHARACTER(LEN=35) F762
      CHARACTER(LEN=44) F761
      CHARACTER(LEN=MXLEN) CARD
!
      ALLOCATABLE :: RHO1(:,:),RHO2(:,:),OMEGA(:,:),TFU(:)              &
     &              ,TEMP(:,:),OMGINF(:),KACT(:,:),KTMP(:)
!par      allocatable :: omsend(:),omrecv(:)                        !par
!
      allocatable :: rhom(:,:),wrkp(:),wrkq(:),iwrkn(:),iwrkl(:)        &
     &              ,work(:)
!
      allocatable :: bswap(:),bswapj(:)
!
      ALLOCATABLE :: IEXP(:),XMANT(:)
      ALLOCATABLE :: NADRUG(:),NTGJ(:),TMP(:,:),OMP(:)                  &
     &              ,DWRK(:),IWRK3(:),IWRK4(:)
!
      ALLOCATABLE :: QPX(:),QPX0(:),QPOSJ(:)
!
      ALLOCATABLE :: PSHFT0(:)
!
      DIMENSION FRX(MDIM1,MDIM2,MDIM3),PSHFTX(MDIM2,MDIM3)              &
     &         ,DRLX(MDIM4,MDIM0,0:MDIM5)                               &
     &         ,DZLX(MDIM7,MDIM6,0:MDIM8)                               &
     &         ,DXTWOX(MDIM7,MDIM6,0:MDIM8)                             &
     &         ,DETAX(MDIM7,MDIM6,0:MDIM8)                              &
     &         ,DNLX(MDIM10,MDIM9)
!
      dimension ntest(1,1)                   !check channel set-up
!
!-----------------------------------------------------------------------
!
!      ICOL(ILI,ILF,IONE1)=((ILF-1)*(ILF-2*IONE1))/2+ILI
!      IROW(ILI,ILF,IONE1,NENG)=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE1))/2
!
!-----------------------------------------------------------------------
!
! flag write of cross sections to adf04ic instead of collision strengths
! - this is for test purposes only.
!
      bcrossx=.false.                !.true.
!
      if(bcrossx)then
!
        write(mw0,*)' *** Attention, adf04ic contains cross sections!'
        write(mw6,*)' *** Attention, adf04ic contains cross sections!'
!
        xconv=done                   !pi*a_0^2
        xconv=xconv*acos(-done)      !a_0^2
        xconv=xconv*28.003D0         !Mbarns
        xconv=xconv*1.D6             !barns
!
      endif
!
! flag write of "OMEGA" file - this is by final scattered energy and so
! *not* directly usable by R-matrix utility codes such as xtrct/adasexj.
! this is somewhat historic as adasexj *does* read/process dw adf04 file
!
      bomega=.false.
!
! elastic switch (normally ione1=1, no elastic. ione1=0 inc elastic)
! now set by user in algeb, and passed thru /nrbdwm/ as needed.
!
!old  ione1=1
!
! test: DO NOT CHANGE!
!old  ione0=0                !algxls/fs ione1, elastic needed for mixing
!
! some test set-up switches that user joe should not need to touch.
!
      bht=.false.                  !.true. for bht(1970) test comparison
!
! set (approx) unitarity switch
!
      bunit=.true.
      if(bht)bunit=.false.
!
! set approximation-ii unitarization switch - needs the full rho-matrix
! (.and.. not.bthrsh, i.e. lvmax.lt.0) only coded for F95.
! currently, in principle, only for use at medium to high energies
! since it still works with the final scattered energy, but seems to
! work well down to low-e as well - strongest coupling with nearby
! states, i.e. ones calculated at the same/similar relative energy.
!
      bunit2=nmetaj.ge.nspecj.and.ione1.eq.0.and.lvmax.lt.0
!
! set print of approx r(tau=0)-matrix as opposed to rho(tau)-matrix
! *MUST* use full T=-2iR/(1-iR) if converting via R-matrix.   (not done)
! can only use weak coupling T=-2i*rho for rho-matrix -see bunit2 above.
!
      brmx=.false.
      if(jprint.eq.4)brmx=.true.
!
! set mixing switch, can test interpolation followed by mixing (false).
!
      bmix=xmix.ge.dzero                !default xmix->.true.
      xmix=abs(xmix)
!
! flag effect of missing phase shifts.
!
      if(kutssx.eq.-1)then
        if(ione1.eq.0)write(mw6,10320)
        if(brmx)write(mw6,10330)
        if(bunit2)write(mw6,10340)
      endif
!
! checks channel set-up (needs ntest dimensioned)
!
      bntest=.false.                    !ione1.eq.0.and.jprint.ge.2
!
      bntest=bntest.and.nmetaj.ge.nspecj
!
! if bcor then we have algebraic correlation, and we know how ordered
!
      bcor=kmax*kcut.ne.kcut*kcut
!
! if becor then we have correlation by energy, and we know not where, so
!
      beqgrpl0=.not.becor                       !false for full li=lf mx
!
! if only algebraic then can reduce memory requirement  NAD/J(NCOR/J)
!
      bcorr=bcor.and..not.becor.and.kcutx.ge.0
!par!                                                               !par
!par      if(rp.eq.4)then                                           !par
!par        my_mpi_real=mpi_real4                                   !par
!par      elseif(rp.eq.8)then                                       !par
!par        my_mpi_real=mpi_real8                                   !par
!par      else                                                      !par
!par        if(iam.eq.0)write(iw,*)'error rp precsion =',rp         !par
!par        go to 5500                                              !par
!par      endif                                                     !par
!
!-----------------------------------------------------------------------
!
      btimep=btimex                                        !for iam.ne.0
      if(btimex)then
!        if(abs(modd).le.1)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Starting proc',iam,' for dwxbp'           !par
!par        else                                                    !par
        write(iw,*)'Starting dwxbp'
!par        endif                                                   !par
!        endif
        call nrb_time(timei)
        time0=timei
      endif
      btimet=btimex  !.false.                             !debug timings
!
! INITIALIZATIONS
!
      PI=ACOS(-DONE)
      TPI=DTWO*PI
!
      NZA2=MAX(NZION-MION,IONE)
      NZA2=NZA2*NZA2
      TOLO=E1M10/NZA2
!
      BPRNT2=JPRINT.GE.2                    !FOR DETAILED OMEGA PRINTOUT
      BPRNT3=JPRINT.GE.3                      !FOR DETAILED RHO PRINTOUT
      BPRNT0=JPRINT.NE.-3
!
      KOLDOO=KUTOOX
      BKUTOO=KUTOOX.NE.0
!
      BKUTSS=KUTSSX.NE.-1
!
      LAPAK=1                                                    !LAPACK
!
      IF(NZION.EQ.MION)THEN
        NZA=0
        DZ2=DONE
      ELSE
        NZA=NZION-MION
        DZ2=NZA*NZA
      ENDIF
!
      LOLD=-1                                          !INITIAL FOR QPOS
      JOLD=-2                                         !INITIAL FOR QPOSJ
!
      IF(MAXJT.GE.0)THEN
        IF(LRGLAM.GT.MAXJT)THEN
          WRITE(MW0,*)'*** SR.DWXBP: LRGLAM.GT.MAXJT, SO NO TOP-UP'
          LRGLAM=-1
        ELSE
          IF(LRGLAM.EQ.-999)LRGLAM=MAXJT
        ENDIF
        IF(LRGLAM.EQ.0)LRGLAM=-1
      ENDIF
!
      IF(LRGLAM.GT.1)THEN        !SET L WHERE DIPOLE TOP-UP NEEDS CHECKS
        LRGLMN=LRGLAM-2*(QCL0+QCS0)
      ELSE
        LRGLMN=1000
      ENDIF
!
      btop=btop.and.lrglam.ge.0
!
      jktest=2*maxlx+QCS0+1                           !max J for K.ne.K'
!
      MPOSC=MXORB+(LCONDWJ-1)/2-(LCONDW-1)/2               !BUFFER SPACE
!
! SMALL LOCAL MEMORY
!
      MXD4=MAX(MENG,10_SP)+3
      ALLOCATE(IEXP(0:MXD4),XMANT(0:MXD4))
      ALLOCATE(TMP(MENG,MENG),OMP(MENG))
      ALLOCATE(NADRUG(NJO),NTGJ(NJO))
      ALLOCATE(QPX(0:MDIM5),QPX0(0:MDIM5),QPOSJ(LCONDWJ))
!
      ixd13=mxd13
      allocate(bswap(ixd13))                                      !small
      if(maxjfs.ge.0)then
        jxd13=2*mxd13
        allocate(bswapj(jxd13))                                   !small
      endif
!
! SET POINTER TO START OF GROUP IN MIXING COEFFICIENT ARRAY TFU,
! AND FOR MAPPING TERMS OF A J-GROUP TO ABSOLUTE LEVEL INDEX.
!
      MC=0
      NCMX=0
      NSUM=0
      DO N=1,NJO
        NADRUG(N)=MC
        NTGJ(N)=NSUM
        NC=NT(N)
        NCMX=MAX(NCMX,NC)
        MC=MC+NC*NC
        NSUM=NSUM+NC
      ENDDO
!
! RECOVER TARGET MIXING COEFFICIENTS
!
      READ(MRW10)NCTOT
!
      if(nctot.ne.mc)stop 'dwxbp:nctot index error'    !shouldn't happen
!
      ALLOCATE(TFU(NCTOT),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXBP: ALLOCATION FAILS FOR TFU'
        NF=0
        GO TO 800
      ENDIF
!
      READ(MRW10)(TFU(I),I=1,NCTOT)
!
! LOOK FOR LAST SPECTROSCOPIC ENERGY
!
!      NSPECL=0
!      DO N=1,NENERJ
!        NSPECL=MAX(NSPECL,JNDXJ(N))
!      ENDDO
!
! USE ROWWISE TO SIMPLY REDUCE NDIM2 IF NMETAJ.LT.NSPECJ
!
      NOMTG=NCMX*NCMX                               !NEED ALL FOR MIXING
      nmin=min(NMETAJ,NSPECJ)
      NOMWRT=IROW(nmin,NSPECJ,ione1,NSPECJ)                     !ROWWISE
      NOMWR0=NOMWRT
!
!test    if(ione1.eq.1)nomwr0=nomwr0+nmin      !incase ione1=0 in diagfs
!
!
      BTHRSH=LVMAX.GE.0
      IF(BTHRSH)THEN
        MOGGY=LVMAX+1-LVMIN
        ALLOCATE(PSHFT0(LVMIN:LVMAX))                             !SMALL
      ELSE
        MOGGY=MENG0
        ALLOCATE(PSHFT0(LVMIN:LVMIN))                             !SMALL
      ENDIF
!
      MX=MTRAN
      if(.not.bmix)mx=meng0
!
      ALLOCATE(RHO1(NOMTG,MX),RHO2(MTRAN,NOMTG),TEMP(NCMX,MX),          &
     &         OMGINF(NOMWR0),OMEGA(MOGGY,NOMWRT),STAT=IERR)
!par!                                                               !par
!par      allocate(omsend(nomwrt),omrecv(nomwrt),stat=ierr)         !par
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXBP: ALLOCATION FAILS FOR RHO,OMEGA,TEMP'
        NF=0
        GO TO 700
      ENDIF
!
      DO N=1,NOMWRT
        OMGINF(N)=DZERO
        DO M=1,MOGGY
          OMEGA(M,N)=0
        ENDDO
      ENDDO
!
! RECOVER INFINITE ENERGY INFO (ROWWISE)
!
      IF(IUNIT(MRW24).EQ.0)THEN                !ADF04 WILL BE INCOMPLETE
        WRITE(MW6,*)'NO INFINITE ENERGY FILE="OMGINFIC"...'
        WRITE(MW0,*)'NO INFINITE ENERGY FILE ON UNIT=',MRW24
        IF(LRGLAM.GE.0)THEN
          WRITE(MW6,*)'NO INFINITE ENERGY FILE INFO, CANNOT TOP-UP'
          WRITE(MW0,*)'NO INFINITE ENERGY FILE INFO, CANNOT TOP-UP'
          NF=-1
          GO TO 600
        ELSE
          GO TO 100
        ENDIF
      ELSEIF(IUNIT(MRW24).LT.0)THEN
        OPEN(MRW24,FILE='OMGINFIC',STATUS='OLD',ERR=100)
        IUNIT(MRW24)=1
      ELSE                               !SERIAL SHOULD NOT BE HERE
        REWIND(MRW24)                       !BUT PAR ALREADY OPEN
!par        if(iam.eq.0)then                                        !par
        stop 'dwxbp: omginfbp confusion'
!par        endif                                                   !par
      ENDIF
!
      READ(MRW24,*)NZDUM,MDUM
      READ(MRW24,*)NSPEC0,MENGB,NOMWR0
!
      IF(NSPEC0.NE.NSPECJ)THEN                   !SHOULD NOT HAPPEN, NOW
        WRITE(MW6,*)'DWXBP: INFINITE ENERGY TARGET MISMATCH',NSPEC0,    &
     &              NSPECJ
        WRITE(MW0,*)'DWXBP: INFINITE ENERGY TARGET MISMATCH'
        NF=-1
        GO TO 600
      ENDIF
!
      ALLOCATE(DWRK(NSPEC0),IWRK3(NSPEC0),IWRK4(NSPEC0))
!
      READ(MRW24,*)(IDUM0,IWRK3(I),I=1,NSPEC0)
      READ(MRW24,10050)(DWRK(I),I=1,NSPEC0)
!
! optionally recover spec energy subset from omginf,
! and retain full-set in denerg back above.
!
!      do i=1,nspec0
!        dwrk0(i)=dwrk0(i)*dz2
!      enddo
!
      iflag=0
      if(nomwrt.ne.nomwr0)then       !should not happen in non-test mode
        if(ione1.eq.0)then                             !elastic in dwxbp
          if(nomwrt-nmin.ne.nomwr0)then
            write(mw6,*)'dwxbp: infinite energy omega mismatch',nomwrt, &
     &                  nomwr0
            write(mw0,*)'dwxbp: infinite energy omega mismatch'
            nf=-1
            go to 600
          else                                   !case ione1=1 in diagfs
            iflag=1
          endif
        else                                         !inelastic in dwxbp
          if(nomwrt+nmin.ne.nomwr0)then
            write(mw6,*)'dwxbp: infinite energy omega mismatch',nomwrt, &
     &                  nomwr0
            write(mw0,*)'dwxbp: infinite energy omega mismatch'
            nf=-1
            go to 600
          else                                   !case ione1=0 in diagfs
            iflag=2
          endif
        endif
      endif
!
      F713='(1PE14.8,6E11.3/(14X,6E11.3))'        !SUPPRESS IFORT REMARK
!
      READ(MRW24,F713)EINF,(OMGINF(I),I=1,NOMWR0)
!par!                                                               !par
!par      if(iam.ne.0)then                                          !par
!par        IUNIT(MRW23)=-1                                         !par
!par        CLOSE(MRW23)                                            !par
!par        IUNIT(MRW24)=-1                                         !par
!par        CLOSE(MRW24)                                            !par
!par      endif                                                     !par
!
      if(iflag.eq.1)then                          !make room for elastic
        n=nomwrt+1
        nshft=nmin
        do i=nmin,1,-1
          do j=nspec0,i+1,-1
            n=n-1
            omginf(n)=omginf(n-nshft)
          enddo
          n=n-1
          omginf(n)=done                             !flag poss. allowed
          nshft=nshft-1
        enddo
        if(n.ne.1)stop 'iflag=1 nshft error'
      elseif(iflag.eq.2)then                               !drop elastic
        n=0
        nshft=1
        do i=1,nmin
          do j=i+1,nspec0
            n=n+1
            omginf(n)=omginf(n+nshft)
          enddo
          nshft=nshft+1
        enddo
        if(n.ne.nomwrt)stop 'iflag=2 nshft error'
      endif
!
!
  100 CONTINUE
!
! WRITE-OUT SPEC. TARGET ENERGIES
!
      im=-1
      if(nmetag(0).ne.0)im=1
!
      WRITE(MW6,10230)
      WRITE(MW6,10170)NMETAJ*im
!
      DO J=1,NSPECJ
        I=INDXJ(J)
        M1=NRR(I)
        II=NFQ(M1)
        IP=(1-QPI(II))*(QSI(II)+1)
        WRITE(MW6,10160)J,I,M1,IP,QLI(II)/2,JN(I),NFK(M1),DSPECJ(J)
      ENDDO
!
      WRITE(MW6,10240)
!
! FLAG ACTIVE ORBITAL PAIR IN INTERACTING CONFIGS C.F. SR.ALGX BXIST0
!
      ALLOCATE(KACT(KMAX,KMAX),KTMP(NF),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXBP: ALLOCATION FAILS FOR KACT,KTMP'
        NF=0
        GO TO 600
      ENDIF
!
      DO KF=1,KMAX
        DO KG=1,KF
          KACT(KF,KG)=0
          KACT(KG,KF)=0
          DO I=1,NF
            KTMP(I)=QCG(I,KG)
          ENDDO
          K=0
          DO I=1,NF
            L0=0
            DO L=1,NF
              IF(IEQ(KTMP(L)).EQ.IEQ(QCG(I,KF)))THEN
                KTMP(L)=0
                GO TO 120
              ELSE
                IF(KTMP(L).NE.0.AND.L0.EQ.0)L0=L
              ENDIF
            ENDDO
            K=K+1
            IF(K.GT.1)GO TO 150
            KACT(KF,KG)=QCG(I,KF)
            KACT(KG,KF)=KTMP(L0)
  120     ENDDO
  150   ENDDO
      ENDDO
!
!-----------------------------------------------------------------------
!
! BEGIN LOOP OVER Jp SCATTERING SYMMETRIES
!
!-----------------------------------------------------------------------
!
      if(bunit2)write(mw6,10180)
      iwait=0
      wait=done
!
      DO KX=1,INASTJ
!
        MTJ=JPI(KX)/10
        MTP=JPI(KX)-MTJ*10
        MTP=MTP+MTP
!
! SEE IF WE NEED TO UPDATE INTEGRALS & CONTINUUM BASIS
!
        JNEW=MTJ
!
        IF(JNEW.NE.JOLD)THEN
!
!-----------------------------------------------------------------------
!
          if(btimex)then
!par            if(iam.ge.0)then                                    !par
!par              write(iwp,*)'Starting proc',iam                   !par&
!par     &                 ,'updating continuum for 2j=',mtj        !par
!par              call flush(iwp)                                   !par
!par            else                                                !par
            write(iw,*)                                                 &
     &             'Begin update of continuum basis & integrals for 2J='&
     &             ,MTJ
!par            endif                                               !par
!
            call nrb_time(timei)
            times=timei
          endif
!
!-----------------------------------------------------------------------
!
          jstep=jnew-jold
          if(jstep.gt.2.and.jfact.gt.200.and.jold.gt.0)then
            if(iwait.eq.2)then
              iwait=1
            else
              iwait=2
            endif
            wait=iwait*jstep
            wait=wait/dthree
          endif
!
! UPDATE CONTINUUM BASIS
!
!  NOTE: IF THE USER HAS RESTRICTED LCONDWJ THEN ANY FINE-STRUCTURE HAS
!        A TRUNCATED PARTIAL WAVE EXPANSION.
!
          IF(BKUTSS)THEN
!
            IF(BTHRSH)LCONDWJ=-LCONDWJ                        !FLAG
!
            CALL RADCNX(FRX,PSHFTX,PSHFT0,MDIM1,MDIM2,MDIM3,JNEW/2,     &
     &                  JOLD/2,LCONDWJ,-MXORB)
!
            IF(NF.LE.0)GO TO 500
!
            DO L=1,LCONDWJ
              QPOSJ(L)=QPOS(L)
            ENDDO
!
          ENDIF
!
! UPDATE FINE-STRUCTURE
!
          IF(JNEW.LE.MAXJFS)THEN
!
! UPDATE EXCHANGE MULTIPOLE
!
            JDIFF=JNEW
            IF(JOLD.GE.0)JDIFF=JDIFF-JOLD
            jdiff=2*(jdiff/2)
!
            DO L=1,NL000
              IF(QSS(1,L).GT.MXORB.AND.QSS(3,L).GT.MXORB.OR.QSS(2,L)    &
     &           .GT.MXORB.AND.QSS(4,L).GT.MXORB)THEN
              ELSE
                QSS(5,L)=QSS(5,L)+INT(JDIFF,QP)                !EXCHANGE
              ENDIF
            ENDDO
!
! UPDATE FINE-STRUCTURE INTEGRALS
!
            IF(BPRNT0)WRITE(MW6,10390)JNEW
!
            DO M=1,MTRAN
              M1=MNDEX(M,1)
              M2=MNDEX(M,2)
              CALL FSINTX(FRX,PSHFTX,MDIM1,MDIM2,MDIM3,DNLX(1,M),M1,M2, &
     &                    JNEW,MXORB)
            ENDDO
!
          ENDIF
!
! PREPARE TO UPDATE NON-FINE-STRUCTURE INTEGRALS:
!   SET POINTERS FOR INTEGRAL STORAGE FOR MULTIPLE LTOT
!
          IF(JOLD.LT.0)THEN                               !FIRST TIME
            DO L=0,QCS0+1
              QPX(L)=INT(L+1,QP)
            ENDDO
          ELSE
            DO L=0,QCS0+1
              QPX0(L)=QPX(L)
              QPX(L)=0
            ENDDO
            L00=(JOLD-INT(QCS0,SP)-1)/2
            K0=(JNEW-JOLD)/2
            DO L=0,QCS0+1
              L0=L00+L
              IF(2*L0.GE.(JNEW-INT(QCS0,SP)-1).AND.                     &
     &           2*L0.LE.(JNEW+INT(QCS0,SP)+1))THEN
                                                          !RE-USE
                K=L-K0
                QPX(K)=-QPX0(L)                           !FLAG OLD
              ELSE
                QPX0(L)=-QPX0(L)                          !NOT WANTED
              ENDIF
            ENDDO
          ENDIF
!
          DO L=0,QCS0+1
            IF(QPX(L).EQ.0)THEN                           !NEW
              DO K=0,QCS0+1                              !LOOK FOR SPACE
                IF(QPX0(K).LT.0)THEN
                  QPX(L)=-QPX0(K)
                  QPX0(K)=0
                  GO TO 160
                ENDIF
              ENDDO
              WRITE(MW6,*)' SR.DWXBP: QPX INDEX ERROR...'
              WRITE(MW0,*)' SR.DWXBP: QPX INDEX ERROR...'
              NF=-1
              GO TO 500
            ENDIF
  160       CONTINUE
!        write(mw0,*)l,qpx(l),qpx0(l)             !debug print
          ENDDO
!
          LPOS=(JNEW-QCS0-1)/2
!
          DO LQ=0,QCS0+1                        !do lq=QCS0+1,0,-1
!
            LNEW=LPOS+LQ
!
!
            IF(LNEW.GE.0.AND.QPX(LQ).GT.0)THEN
!
! UPDATE/RE-LABEL CONTINUUM BASIS FOR THIS LTOT
!
              IF(BKUTSS)THEN
!
! NOTE: CURRENTLY, NO NEW CONTINUUM ORBITALS ARE GENERATED HERE.
!       SO, IF THE USER HAS RESTRICTED LCONDWJ (*NOT A GOOD IDEA*)
!       THEN FLAG & DISCARD PWS.
!
                J=MPOSC-MXORB
                J=J+LNEW-JNEW/2
                MYL2=2*(LNEW-(LCONDW+1)/2)
!
                DO L=1,LCONDW
                  J=J+1
                  MYL2=MYL2+2
                  if(j.le.0.or.j.gt.lcondwj)then !user restricts lcondwj
                    QPOS(L)=0                    !flag not to calculate
                    QL(MPOSC+L)=-99              !flag non-existence
                  else
                    QPOS(L)=ABS(QPOSJ(J))
                    QL(MPOSC+L)=INT(MYL2,QP)
                  endif
                ENDDO
!
              ELSE
!
! UPDATE CONTINUUM BASIS
!
                IF(BTHRSH)LCONDW=-LCONDW                        !FLAG
!
                CALL RADCNX(FRX,PSHFTX,PSHFT0,MDIM1,MDIM2,MDIM3,LNEW,   &
     &                      LOLD,LCONDW,MPOSC)
!
                IF(NF.LE.0)GO TO 500
!
              ENDIF
!
! UPDATE EXCHANGE MULTIPOLE
!
              LDIFF=LNEW
              IF(LOLD.GE.0)LDIFF=LDIFF-LOLD
              LDIFF=LDIFF+LDIFF
!
              DO I=1,IRL
                IF(QRL(2,I).GT.MXORB)QRL(5,I)=QRL(5,I)+INT(LDIFF,QP) !EX
              ENDDO
!
! UPDATE SLATER INTEGRALS (INC. 2NFS IF BKUTOO=.TRUE.)
!
              IF(BKUTOO.AND.LNEW.GT.MAXLOO)THEN
                KUTOOX=0
                BKUTOO=.FALSE.
              ENDIF
!
              IF(BPRNT0)WRITE(MW6,10380)LNEW
              LSTORE=QPX(LQ)-1
!
              DO M=1,MTRAN
                M1=MNDEX(M,1)
                M2=MNDEX(M,2)
                IF(BKUTOO)THEN
                  CALL SLATRX(FRX,PSHFTX,MDIM1,MDIM2,MDIM3,             &
     &                        DRLX(1,M,LSTORE),DZLX(1,M,LSTORE),        &
     &                        DXTWOX(1,M,LSTORE),DETAX(1,M,LSTORE),M1,  &
     &                        M2,LNEW,MPOSC)
                ELSE
                  CALL SLATRX(FRX,PSHFTX,MDIM1,MDIM2,MDIM3,             &
     &                        DRLX(1,M,LSTORE),DZLX(1,1,0),DXTWOX(1,1,0)&
     &                        ,DETAX(1,1,0),M1,M2,LNEW,MPOSC)
                ENDIF
              ENDDO
!
              LOLD=LNEW
              KUTOOX=KOLDOO
              BKUTOO=KUTOOX.NE.0
!
            ENDIF
!
            QPX(LQ)=ABS(QPX(LQ))
!
          ENDDO
!
! RE-SET
!
          JOLD=JNEW
!
! (NOTE: MAKE SURE QL IS SYNCHRONIZED WITH LDIFF USAGE BELOW WHEN
!        TESTING WHETHER "INITIAL" & "FINAL" STATES HAVE BEEN SWAPPED
!        BY FALLING ORDER)
!
          IF(BKUTSS)THEN
            DO J=1,LCONDWJ
              QPOS(J)=QPOSJ(J)
            ENDDO
            JPOS=JNEW
          ELSE
            JPOS=LNEW+LNEW
          ENDIF
!
          MYL2=2*(JPOS/2-(LCONDWJ+1)/2)
          DO L=1,LCONDWJ
            MYL2=MYL2+2
            QL(MXORB+L)=INT(MYL2,QP)
          ENDDO
!
!-----------------------------------------------------------------------
!
          if(btimex)then
            call nrb_time(timef)
            times=timef-times
!
!par            if(iam.ge.0)then                                    !par
!par              write(iwp,*)'Ending proc',iam                     !par&
!par     &                  ,'updating continuum'                   !par&
!par     &                 ,' time=',nint(times),'sec'              !par
!par              call flush(iwp)                                   !par
!par            else                                                !par
            write(iw,*)'End update of continuum basis & integrals',     &
     &                 ', time=',nint(times),'sec'
!par            endif                                               !par
          endif
!
!-----------------------------------------------------------------------
!
        ENDIF
!
! INITIALIZE FOR J-LOOP
!
        IF(BPRNT0)WRITE(MW6,10270)KX,MTJ,MTP/2
!
        NWTJ=MTJ+1
!                                                     WRITE CHANNEL LIST
        NCHJT=NCHAJK(KX,-IONE,-IONE,-IONE,-IONE,NTGJ)
        NCHSJT=NCHSJ
!
        IF(.NOT.BPRNT0)WRITE(MW6,10250)KX,MTJ,MTP/2,NCHSJT,NCHJT
!
        if(bntest)then
          do i=1,nchjt
            do j=1,nchjt
              ntest(j,i)=0
            enddo
          enddo
        endif
!
! initialize for approximation-ii (memory hog)
!
        if(bunit2)then
!
          nx=(nchjt*(nchjt+1))/2
!
          ALLOCATE(rhom(nx,meng0),wrkp(nx),wrkq(nx),iwrkn(nchjt),       &
     &             iwrkl(nchjt),work(nchjt),stat=ierr)
!
          if(ierr.ne.0)then
            write(mw0,*)'dwxbp: allocation fails for rhom,wrk'
            nf=0
            go to 500
          endif
!
          do i=1,nchjt
            iwrkn(i)=-1
            iwrkl(i)=-1
          enddo
!
          do m=1,meng0
            n=0
            do i=1,nchjt
              n=n+1
              rhom(n,m)=done
              do j=i+1,nchjt
                n=n+1
                rhom(n,m)=dzero
              enddo
            enddo
          enddo
!
        endif
!
! detailed print
!
        if(jprint.eq.6)then
          write(mw6,10350)
          if(maxjfs.ge.0)write(mw6,10400)
        endif
!
        IF(BPRNT2)WRITE(MW6,10290)
!
!-----------------------------------------------------------------------
!
        if(btimex)then
!par          if(iam.ge.0)then                                      !par
!par            write(iwp,*)'Starting proc',iam                     !par&
!par     &                ,'dwxbp symmetry',kx,':',mtj,mtp/2        !par
!par            call flush(iwp)                                     !par
!par          else                                                  !par
          write(iw,*)'Starting dwxbp symmetry',kx,' :',mtj,mtp/2
!par          endif                                                 !par
!par!                                                               !par
          call nrb_time(timei)
          timej=timei
        endif
!
        if(btimet)then
          timeset=dzero
          timemix=dzero
          timemixi=dzero
          timemixf=dzero
          timemixir=dzero
          timemixfr=dzero
          timeunit=dzero
          timeint=dzero
        endif
!
!-----------------------------------------------------------------------
!
        INASTX=NCHGJ(KX)                    !NO. OF LS-SYMMS FOR THIS JP
!
! BEGIN K-LOOPS
!
        KAY2=MTJ+1
        IF(MTJ.GT.0)THEN
          KAY1=MTJ-1
        ELSE
          KAY1=KAY2
        ENDIF
!
        if(mtj.le.jktest)then       !exchange present so K.ne.K' allowed
          kay1p=kay1
          kay2p=kay2
        endif
!
        DO KAYI=KAY1,KAY2,2                  !LOOP OVER INTIAL CHANNEL K
!
          if(mtj.gt.jktest)then                !no-exchange so K=K' only
            kay1p=kayi
            kay2p=kayi
          endif
!
          DO KAYF=KAY1p,KAY2p,2               !LOOP OVER FINAL CHANNEL K
!
! BEGIN TARGET JP LOOPS (CURRENTLY, WE HAVE NOT YET SELECTED SUBSET
!                        THAT CONTRIBUTE TO THE TOTAL JP SYMMETRY,
!                        SO LOOP OVER ALL AND DISCARD ON-THE-FLY.)
!
            DO JIG=1,NJO             !LOOP OVER INITIAL TARGET JP GROUPS
!
              NC=NSLJ(1,JIG)
              JIP=QPI(NC)
              JI=NTGJ(JIG)+1
              JI=JN(JI)
              SJKI=SQRT(REAL((JI+1)*(KAYI+1),WP))
              L1=ABS(KAYI-JI)
              IF(MOD(JIP+L1,IFOUR).NE.MTP)L1=L1+2
              L2=KAYI+JI
              IF(MOD(JIP+L2,IFOUR).NE.MTP)L2=L2-2
!
              NCJ0=NT(JIG)
              NCN0=NGSLJ(JIG)
!
              jf2=jig
              if(kayf.gt.kayi)jf2=jig-1
!
              DO JFG=1,jf2             !LOOP OVER FINAL TARGET JP GROUPS
!
                ND=NSLJ(1,JFG)
                JFP=QPI(ND)
                JF=NTGJ(JFG)+1
                JF=JN(JF)
                SJKF=SQRT(REAL((JF+1)*(KAYF+1),WP))
                L1P=ABS(KAYF-JF)
                IF(MOD(JFP+L1P,IFOUR).NE.MTP)L1P=L1P+2
                L2P=KAYF+JF
                IF(MOD(JFP+L2P,IFOUR).NE.MTP)L2P=L2P-2
!
                NCJP0=NT(JFG)
                NCNP0=NGSLJ(JFG)
!
! get lambda for non-dipole infnite energy top-up
!
                if(jnew.ge.lrglam)then
                  if(ji+jf.ne.0)then
                    litlam=abs(ji-jf)/2
                    if(jip.ne.jfp)then
                      if(litlam.le.1)then          !for case of octupole
                        litlam=3
                      elseif(1.gt.2*mod(abs(litlam),itwo))then
                        litlam=litlam+1
                      endif
                    else
                      if(litlam.eq.0)then
                        litlam=2
                      elseif(1.lt.2*mod(abs(litlam),itwo))then
                        litlam=litlam+1
                      endif
                    endif
                    if(litlam.gt.(ji+jf)/2)litlam=0
                  else
                    litlam=0
                  endif
                else
                  litlam=0
                endif
!
!                beqgrpj=jig.eq.jfg                  !not currently used
!
                DO LI=L1,L2,4               !LOOP OVER INITIAL CHANNEL L
!
! set position of phase shift for this li
! only required by  elastic case for diagonal rho
! or if printing usual reactance matrix
!
                  if(ione1.eq.0.or.brmx)then
                    L=(LCONDWJ+1)/2-JPOS/2+LI/2
!                    if(l.gt.lcondwj.or.l.lt.1)stop 'phase error'
                    l=min(l,lcondwj)   !case user has restricted lcondwj
                    l=max(l,ione)     !then we don't have all the phases
                    L0=ABS(QPOS(L))
                  endif
!
                  DO LF=L1P,L2P,4             !LOOP OVER FINAL CHANNEL L
!
! set position of phase shift for this lf
! only need if printing usual reactance matrix, not needed by rho matrix
!
                    if(brmx)then
                      L=(LCONDWJ+1)/2-JPOS/2+LF/2
!                      if(l.gt.lcondwj.or.l.lt.1)stop 'phase error'
                      l=min(l,lcondwj) !case user has restricted lcondwj
                      l=max(l,ione)   !then we don't have all the phases
                      L00=ABS(QPOS(L))
                    endif
!
!-----------------------------------------------------------------------
!
! NOW FORM JK INTERACTION (BY TARGET SYMMETRY GROUP)
!*************************
!
! THIS IS IN THE RHO-I REPRESENTATION, WHERE
! |T^R(V,V')|=|T^RHO(V,V')| FOR CHANNELS V.NE.V'.
! WE USE T^RHO(V,V')=-2I*RHO(V,V'), WITH A 2X2 UNITARITY CONDITION.
! FOR V.EQ.V' T^R(V,V)~-2*TAN(TAU(V)), FOR RHO(V,V) SMALL.
! (IN GENERAL, WE ARE NOT INTERESTED IN ELASTIC TRANSITIONS.)
!
!
                    if(btimet)call nrb_time(timei)
!
                    NOMTG=NCJ0*NCJP0
                    DO N=1,NOMTG
                      DO M=1,MTRAN
                        RHO2(M,N)=DZERO
                      ENDDO
                    ENDDO
!
                    NCI0=0
                    DO NC00=1,NCN0    !BEGIN LOOP OVER INITIAL SL GROUPS
                      NC=NSLJ(NC00,JIG)
                      MC=NSL(NC)
                      SA=QSI(NC)
                      LA=QLI(NC)
                      MCI=NGRPI(NC)
!
                      NCIP0=0
                      DO ND00=1,NCNP0   !BEGIN LOOP OVER FINAL SL GROUPS
                        ND=NSLJ(ND00,JFG)
                        MCP=NSL(ND)
                        SAP=QSI(ND)
!                        IF(ABS(SA-SAP).GT.2)GO TO 68   !unnecessary...
                        IF(NMETAG(NC)+NMETAG(ND).EQ.2)GO TO 178
                        LAP=QLI(ND)
                        MCIP=NGRPI(ND)
!
                        DO IXX=1,INASTX      !LOOP OVER INITIAL LS SYMMS
!
                          IX=JSYMM(IXX,KX)
                          NCN=NCHG(IX)
!
                          nchi=0
                          DO NC0=1,NCN               !FIND INITIAL GROUP
                            LL1=LLCH(1,NC0,IX)
                            LL2=LLCH(2,NC0,IX)
                            nchi=nchi+((ll2-ll1)/4+1)*mc
                            IF(NC.EQ.ITARG(NC0,IX))THEN         !MATCHED
                              IF(LI.LT.LL1.OR.LI.GT.LL2)GO TO 162
                              nchi=nchi-((ll2-li)/4+1)*mc
                              GO TO 164
                            ENDIF
                          ENDDO
!
  162                     CONTINUE
!                    write(mw6,*)'NO CONTRIB. FROM LS SYM',IXX,' IX=',IX
                          GO TO 176             !SLP DOES NOT CONTRIBUTE
!
  164                     IS=LSPI(IX)/10000
                          IP=LSPI(IX)-IS*10000
                          IL=IP/10
                          IP=IP-IL*10
!
                          IF(MTP.NE.IP+IP)STOP 'IXX ERROR'       !REMOVE
                          MTS=IS-1
                          MTL=IL+IL
!
                          IF(KAYI.LT.ABS(MTL-SA).OR.KAYI.GT.MTL+SA)     &
     &                       GO TO 176                    !LAST TRIANGLE
!
                          IF(BKUTOO.AND.IL.GT.MAXLOO)THEN
                            KUTOOX=0
                            BKUTOO=.FALSE.
                          ENDIF
!
                          bnx=il.gt.maxlx
!
                          if(jprint.ge.5)then
                            if(bnx)then
                              nwt=-2*is+2
                            else
                              nwt=is
                            endif
                            write(mw6,10260)ix,nwt,il,ip
                          endif
!
! must be synchronized with current values of l placed in ql(i) for
! orbital and integral evaluations.
!
                          ldiff=2*(jpos/2)-mtl      !for adjust of ql(i)
!
! DETERMINE INITIAL STATE RECOUPLING COEFFICIENT
!
                          W=SJS(LA,LI,MTL,KAYI,SA,JI)
                          ISGN=(LI+MTL+SA+JI)/2
                          isgn=1-2*mod(abs(ISGN),ITWO)
                                                      !(-1)**isgn
                          W=W*ISGN
                          W2=SJS(MTS,MTL,MTJ,KAYI,IONE,SA)
                          ISGN=(MTL+MTJ+1+SA)/2
                          isgn=1-2*mod(abs(ISGN),ITWO)
                                                      !(-1)**isgn
                          W2=W*W2*ISGN
                          W2=W2*SQRT(REAL((MTL+1)*(MTS+1),WP))*SJKI
!
                          if(bnx)then
                            mts=mts-2
                            if(mts.ge.abs(mtj-mtl))then
                              x2=sjs(mts,mtl,mtj,kayi,ione,sa)
!                              isgn=(mtl+mtj+1+sa)/2
!                              isgn=1-2*mod(abs(isgn),2)!(-1)**isgn
                              x2=w*x2*isgn
                              x2=x2*sqrt(real((mtl+1)*(mts+1),wp))*sjki
                            endif
                          else
                            x2=dzero
                          endif
!
                          if(abs(w2)+abs(x2).lt.1.D-70)go to 176
!
                          JX1=1                            !FS
                          IF(MTJ.GT.MAXJFS)JX1=IXX         !NO-FS
!
                          DO JXX=JX1,IXX       !LOOP OVER FINAL LS SYMMS
!
                            JX=JSYMM(JXX,KX)
                            NCNP=NCHG(JX)
!
                            nchip=0
                            DO ND0=1,NCNP              !FIND FINAL GROUP
                              LL1P=LLCH(1,ND0,JX)
                              LL2P=LLCH(2,ND0,JX)
                              nchip=nchip+((ll2p-ll1p)/4+1)*mcp
                              IF(ND.EQ.ITARG(ND0,JX))THEN       !MATCHED
                                IF(LF.LT.LL1P.OR.LF.GT.LL2P)GO TO 166
                                nchip=nchip-((ll2p-lf)/4+1)*mcp
                                GO TO 168
                              ENDIF
                            ENDDO
!
  166                       CONTINUE
!                   write(mw6,*)'NO CONTRIB. FROM LS SYM',JXX,' JX=',JX
                            GO TO 174              !SLP DOES NOT CONTRIB
!
  168                       ISP=LSPI(JX)/10000
                            IPP=LSPI(JX)-ISP*10000
                            ILP=IPP/10
                            IPP=IPP-ILP*10
!
                            IF(MTP.NE.IPP+IPP)STOP 'JXX ERROR'   !REMOVE
                            MTSP=ISP-1
                            MTLP=ILP+ILP
!
                            IF(KAYF.LT.ABS(MTLP-SAP).OR.                &
     &                         KAYF.GT.MTLP+SAP)GO TO 174 !LAST TRIANGLE
!
                            BLS=IX.EQ.JX
!
                            btest1=(IS+ISP-2)*(IL+ILP).GT.0
                            btest2=abs(NMETAG(NC))+abs(NMETAG(ND)).lt.2
                            b2fs=mtj.le.maxjfs.and.btest1.and.btest2
!
                            if(jprint.ge.5)then
                              if(bnx)then
                                nwtp=-2*isp+2
                              else
                                nwtp=isp
                              endif
                              write(mw6,10280)jx,nwtp,ilp,ipp
                            endif
!
! DETERMINE FINAL STATE RECOUPLING COEFFICIENT
!
                            W=SJS(LAP,LF,MTLP,KAYF,SAP,JF)
                            ISGN=(LF+MTLP+SAP+JF)/2
                            isgn=1-2*mod(abs(ISGN),ITWO)
                                                        !(-1)**isgn
                            W=W*ISGN
                            W2P=SJS(MTSP,MTLP,MTJ,KAYF,IONE,SAP)
                            ISGN=(MTLP+MTJ+1+SAP)/2
                            isgn=1-2*mod(abs(ISGN),ITWO)
                                                        !(-1)**isgn
                            W2P=W*W2P*ISGN
                            W2P=W2P*SQRT(REAL((MTLP+1)*(MTSP+1),WP))    &
     &                          *SJKF
!
                            W4=W2*W2P
!
                            if(bnx)then
                              mtsp=mtsp-2
                              if(mtsp.ge.abs(mtj-mtlp))then
                                x2p=sjs(mtsp,mtlp,mtj,kayf,ione,sap)
!                                isgn=(mtlp+mtj+1+sap)/2
!                                isgn=1-2*mod(abs(isgn),2)!(-1)**isgn
                                x2p=w*x2p*isgn
                                x2p=x2p*sqrt(real((mtlp+1)*(mtsp+1),wp))&
     &                              *sjkf
                                w4=w4+x2*x2p
                              endif
                            endif
!
                            if(abs(w4).lt.1.D-70)go to 174
!
! set pointers to ls and fs interactions
!
!
                            beqgrp=bls.and.nc0.eq.nd0     !ls equal grps
!                                                          !to fill rho2
                            beqgrpl=beqgrpl0.and.beqgrp.and.li.eq.lf
!
                            if(bls)then
                              ncor=qptls(ix,nc0,nd0,li,lf)
                              if(ncor.ge.0)then
                                nun=0
                              else             !reverse
                                nun=mc-1
!                       write(mw6,*)ix,nc0,nd0,li,lf,ncor+1
                              endif
                              ncor0=ncor
                              LSTORE=IL-LPOS
                              LSTORE=QPX(LSTORE)-1
                            else
                              ncor0=0
                            endif
!
                            if(b2fs)then
                              ncorj=qptlsj(kx,ixx,jxx,nc0,nd0,li,lf)
                              if(ncorj.ge.0)then
                                nunj=0
                              else             !reverse
                                nunj=mc-1
!                      write(mw6,*)kx,ixx,jxx,nc0,nd0,li,lf,ncorj+1
                              endif
                              ncorj0=ncorj
                            else
                              ncorj0=0
                            endif
!
                            icl0=0
                            btest=ncor0.lt.0.or.ncorj0.lt.0
                            if(bcorr.and.btest)then
                              do md1=1,mc
                                j1=md1+mci
                                j=jndex(j1)
                                if(j.lt.0)icl0=icl0+1
                              enddo
                            endif
!
! POPULATE UNMIXED RHO INTERACTION MATRIX
!
                            icl=0
                            DO MD1=1,MC        !LOOP OVER INITIAL LEVELS
                              J1=MD1+MCI
!
                              j=jndex(j1)
                              if(kcutx.lt.0)j=abs(j)  !keep corr.-corr.
                              if(bcorr.and.j.lt.0)icl=icl+1
                              KF=NFK(J1)
                              NCJ=NCI0+MD1
!
                              if(ncor0.lt.0)ncor=-ncor0-1+md1-1
                              if(ncorj0.lt.0)ncorj=-ncorj0-1+md1-1
!
                              iclp=0
                              DO MDP1=1,MCP      !LOOP OVER FINAL LEVELS
                                J1P=MDP1+MCIP
!
                                jp=jndex(j1p)
                                if(bcorr.and.jp.lt.0)iclp=iclp+1
                                if(j.lt.0.and.jp.lt.0)then      !cor-cor
                                  if(becor)then
                                    if(bls)ncor=ncor+1
                                    if(b2fs)ncorj=ncorj+1
                                    go to 170
                                  endif
                                  go to 172
                                endif
!
                                KG=NFK(J1P)
                                NCJP=NCIP0+MDP1
!
                                NOMTG=(NCJP-1)*NCJ0+NCJ     !rho2 (orig)
!
! LS ALGEBRA
!
                                IF(BLS)THEN
!                                           since ls only stores half...
                                  if(beqgrpl.and.j1p.gt.j1-ione0)then
                                    ncor=ncor0+icol(md1,mdp1,ione0)-1
                                    IF(bcorr)                           &
     &                                 ncor=ncor-icol(iclp-1,iclp-1,    &
     &                                 ione0)
                                  endif
!
                                  N1=NAD(NCOR)+1
                                  NCOR=NCOR+1
                                  N2=NAD(NCOR)
! debug write
                                  if(jprint.eq.6.and.n1.le.n2)then
                                    nch=nchi+md1
                                    nchp=nchip+mdp1
                                    if(n2-n1.eq.5)then
                                      write(mw6,10410)ncor,ix,nch,nchp, &
     &                                  0,0,(nrk(n),drk(n),n=n1,n2)
                                    else
                                      write(mw6,10420)ncor,ix,nch,nchp, &
     &                                  0,0,(nrk(n),drk(n),n=n1,n2)
                                    endif
                                    IF(bkutoo)write(mw6,10430)          &
     &                                 (nrk(n),dek(n),n=n1,n2)
                                    write(mw6,10420)
                                  endif
!
! need to find if Slater integral initial and final states are swapped
! because of falling order. this also picks-up any case that needs
! swapping because initial and final algebraic states are swapped.
! it doesn't pick-up all cases of ncor0.lt.0 but the symmetry of the
! Slater integrals means that such cases are unchanged by a swap.
!
                                  ixxx=n2-n1+1
                                  if(ixxx.gt.ixd13)then
                                    deallocate(bswap)
                                    ixd13=ixxx
                                    allocate(bswap(ixd13))
                                  endif
!
                                  ks=0
                                  do n=n1,n2
                                    ks=ks+1
                                    bswap(ks)=.false.
                                    n0=int(nrk(n),sp)
                                    m0=qrl(1,n0)
                                    if(li.eq.ql(m0)-ldiff)then
                                      if(li.eq.lf.and.kf.ne.kg)then
                                        m0=qrl(3,n0)
                                        if(qn(m0).gt.0)then    !exchange
                                          if(m0.ne.kact(kg,kf))then   !f
                                            bswap(ks)=.true.       !swap
                                          endif
!                                       else    !direct - doesn't matter
                                        endif
!                                     else      !distinct/kf=kg so can't
                                      endif
                                    else           !trivially, they were
                                      bswap(ks)=.true.
                                    endif
                                  enddo
!
                                ELSE
                                  N1=1
                                  N2=0
                                ENDIF
!
! FS ALGEBRA
!
                                if(b2fs)then
!                                           since ls only stores half...
                                  if(beqgrpl.and.j1p.gt.j1-ione0)then
                                    ncorj=ncorj0+icol(md1,mdp1,ione0)-1
                                    IF(bcorr)ncorj=ncorj-               &
     &                                 icol(iclp-1,iclp-1,ione0)
                                  endif
!
                                  k1=nadr(ncorj)+1
                                  ncorj=ncorj+1
                                  k2=nadr(ncorj)
! debug write
                                  if(jprint.eq.6.and.k1.le.k2)then
                                    nch=nchi+md1
                                    nchp=nchip+mdp1
                                    if(k2-k1.eq.5)then
                                      write(mw6,10360)ncorj,kx,ix,jx,   &
     &                                  nch,nchp,0,0,                   &
     &                                  (mss(n),dss(n),n=k1,k2)
                                    else
                                      write(mw6,10370)ncorj,kx,ix,jx,   &
     &                                  nch,nchp,0,0,                   &
     &                                  (mss(n),dss(n),n=k1,k2)
                                    endif
                                    write(mw6,10360)
                                  endif
!
! need to find if n & v integral initial and final states are swapped
! because of falling order.
!
! this does *not* pick-up all cases that need swapping because initial
! and final algebraic states are swapped (ncorj0.lt.0) hence additional
! test on ncorj0.
!
                                  jxxx=k2-k1+1
                                  if(jxxx.gt.jxd13)then
                                    deallocate(bswapj)
                                    jxd13=jxxx
                                    allocate(bswapj(jxd13))
                                  endif
!
! **********************************************************************
! currently, swapping of indexes due to falling order has been
! suppressed in sr.resx1 (see also sr.fsintx) because of the lesser
! symmetry compared to Slater integrals which means that an additional
! flag is needed.
! **********************************************************************
!
! so, we simply have:
                                  ksj=0
                                  do k=k1,k2
                                    ksj=ksj+1
                                    bswapj(ksj)=ncorj0.lt.0
                                  enddo
!! instead of:
!                                  ksj=0
!                                  do k=k1,k2
!                                    ksj=ksj+1
!                                    bswapj(ksj)=.false.
!                                    k0=int(mss(k),sp)
!!
!                                    i1=qss(1,k0)
!                                    i3=qss(3,k0)
!                                    i2=qss(2,k0)
!                                    i4=qss(4,k0)
!                                    if(qn(i1).lt.0)then
!                                      ic=i1
!                                      if(qn(i3).lt.0)then       !direct
!                                        ib=i4
!                                      else                    !exchange
!                                        ib=i3
!                                      endif
!                                    else
!                                      ic=i2
!                                      if(qn(i4).lt.0)then       !direct
!                                        ib=i3
!                                      else                    !exchange
!                                        ib=i4
!                                      endif
!                                    endif
!                                    if(li.eq.ql(ic))then
!                                      if(li.eq.lf)then
!                                        if(kf.ne.kg)then
!                                          if(ib.ne.kact(kg,kf))then  !f
!                                            bswapj(ksj)=.true.
!                                          endif
!                                        else
!! tbd for exchange falling order (see also sr.resx1 and sr.fsintx):
!! the case of N(C'C;BB)=N(BC;C'B) for Bound and Continuum needs a
!! further flag so as to distinguish it from N(C'C;BB)=N(C'B;BC),
!! since in the former we need C'=M2 while in the latter C'=M1, so
!!                                           if(former)then
!!                                           bswapj(ksj)=.true.
!!           since unlike slater we cannot interchange 1 & 3 with 2 & 4
!!         - this also means that we need
!                                          if(ncorj0.lt.0)
!     &                                    bswapj(ksj)=.not.bswapj(ksj)
!                                        endif
!                                      else           !distinct so can't
!                                      endif
!                                    else          !trivially, they were
!                                      bswapj(ksj)=.true.
!                                    endif
!!
!!                           nj=ntgj(jig)
!!                           njp=ntgj(jfg)
!!                           n1=ncj+nj
!!                           n=jndxj(n1)
!!                           n1p=ncjp+njp
!!                           np=jndxj(n1p)
!!          write(mw6,*)ixx,jxx,nc0,nd0,n,np,li,lf,ncorj0,k0,bswapj(ksj)
!!          bswapt=ncorj0.lt.0
!!          if(bswapt.neqv.bswapj(ksj))
!!     &    write(mw0,*)ixx,jxx,nc0,nd0,n,np,li,lf,ncorj0,k0,bswapj(ksj)
!!
!!                                  enddo
!
                                else
                                  k1=1
                                  k2=0
                                endif
!
! LOOP OVER ENERGIES
!
                                DO M=1,MTRAN
                                  M1=MNDEX(M,1)
                                  M2=MNDEX(M,2)
!
! LS CONTRIBUTION:
!
                                  DD=DZERO
                                  ks=0
                                  DO N=N1,N2
                                    ks=ks+1
!
                                    if(bswap(ks))then              !swap
                                      mm=mrndx(m)
                                    else
                                      mm=m
                                    endif
!
                                    N0=INT(NRK(N),SP)
!
                                    DD=DD+DRLX(N0,mm,LSTORE)*DRK(N)
!
                                    IF(BKUTOO)THEN
                                      DS=DZLX(N0,mm,LSTORE)
                                      IF(BFALL(N))DS=-DS
                                      DS=DS+DXTWOX(N0,mm,LSTORE)*DRK(N) &
     &                                   +DETAX(N0,mm,LSTORE)*DEK(N)
                                      DD=DD+DS
                                    ENDIF
                                  ENDDO
!
! FS CONTRIBUTION:
!
!                                  dd=dzero !test fs, switch-off coulomb
!
                                  DDJ=DZERO
                                  ksj=0
                                  DO K=K1,K2
                                    ksj=ksj+1
!
                                    if(bswapj(ksj))then            !swap
                                      mm=mrndx(m)
                                    else
                                      mm=m
                                    endif
!
                                    K0=INT(MSS(K),SP)
!
                                    DDJ=DDJ+DNLX(K0,mm)*DSS(K)
                                  ENDDO
!
                                  DEE=DD+DDJ
!                                                               !UNMIXED
                                  RHO2(M,NOMTG)=RHO2(M,NOMTG)+DEE*W4
!
                                ENDDO
!
                                if(jprint.eq.6)then
                                  nchj=nchajk(kx,kayi,jig,li,ncj,ntgj)
                                  nchjp=nchajk(kx,kayf,jfg,lf,ncjp,ntgj)
                                  nj=ntgj(jig)
                                  njp=ntgj(jfg)
                                  n1=ncj+nj
                                  n=jndxj(n1)
                                  n1p=ncjp+njp
                                  np=jndxj(n1p)
                                  write(mw6,10010)nchj,nchjp,n,np,      &
     &                                  (rho2(m,nomtg),m=1,mtran)
                                endif
!
  170                           if(ncor0.lt.0)then
                                  ncor=ncor+nun
                                  if(jp.lt.0)ncor=ncor-icl0
                                endif
                                if(ncorj0.lt.0)then
                                  ncorj=ncorj+nunj
                                  if(jp.lt.0)ncorj=ncorj-icl0
                                endif
!
                              ENDDO          !END LOOP OVER FINAL LEVELS
!
  172                         if(beqgrpl)then
                                if(bls)then
                                  ncor=ncor0+icol(md1,md1,ione0)
                                  if(bcorr)ncor=ncor-icol(icl,icl,ione0)
                                endif
                                if(b2fs)then
                                  ncorj=ncorj0+icol(md1,md1,ione0)
                                  IF(bcorr)ncorj=ncorj-                 &
     &                               icol(icl,icl,ione0)
                                endif
                              endif
!
                            ENDDO          !END LOOP OVER INITIAL LEVELS
!
  174                     ENDDO            !END LOOP OVER FINAL LS SYMMS
!
                          KUTOOX=KOLDOO
                          BKUTOO=KUTOOX.NE.0
!
  176                   ENDDO            !END LOOP OVER INITIAL LS SYMMS
!
  178                   CONTINUE
!
                        NCIP0=NCIP0+MCP
                      ENDDO               !END LOOP OVER FINAL SL GROUPS
                      if(ncip0.ne.ncjp0)then
                        stop 'ncip0.ne.nt(jfg)'               !temp test
                      endif
!
                      NCI0=NCI0+MC
                    ENDDO               !END LOOP OVER INITIAL SL GROUPS
                    if(nci0.ne.ncj0)stop 'nci0.ne.nt(jig)'   !temp test
!
                    if(jprint.ge.5)then
                      write(mw6,*)'unmixed rho-matrix:'
                      nj=ntgj(jig)
                      njp=ntgj(jfg)
                      do ncjp=1,ncjp0      !begin loop over final levels
                        nchjp=nchajk(kx,kayf,jfg,lf,ncjp,ntgj)
                        j1p=ncjp+njp
                        jp=jndxj(j1p)
                        nomtg0=(ncjp-1)*ncj0
                        do ncj=1,ncj0    !begin loop over initial levels
                          nchj=nchajk(kx,kayi,jig,li,ncj,ntgj)
                          j1=ncj+nj
                          j=jndxj(j1)
                          nomtg=nomtg0+ncj
                          write(mw6,10010)nchj,nchjp,j,jp,              &
     &                                    (rho2(m,nomtg),m=1,mtran)
                        enddo
                      enddo
                    endif
!
                    if(btimet)then
                      call nrb_time(timef)
                      timeset=timeset+timef-timei
                      timei=timef
                    endif
!
!-----------------------------------------------------------------------
!
                    MX=MTRAN
!
! INTERP THEN MIX (APPROX)
!
                    if(.not.bmix)then
!
                      NJ=NTGJ(JIG)
                      NJP=NTGJ(JFG)
!
                      DO NCJP=1,NCJP0      !BEGIN LOOP OVER FINAL LEVELS
!
                        J1P=NCJP+NJP
                        JP=JNDXJ(J1P)
!
                        NOMTG0=(NCJP-1)*NCJ0
!
                        DO NCJ=1,NCJ0    !BEGIN LOOP OVER INITIAL LEVELS
!
                          J1=NCJ+NJ
                          J=JNDXJ(J1)
!
                          NOMTG=NOMTG0+NCJ            !rho2 nomtg (orig)
!
                          IF(J.LE.JP)THEN
                                        !INITIAL ALGEBRAIC IS LOWER ENRG
!
                            JL=J
                            JH=JP
!
                            DO M=1,MX
                              M1=MNDEX(M,1)
                              M2=MNDEX(M,2)
                              TMP(M1,M2)=RHO2(M,NOMTG)
                            ENDDO
!
                          ELSE          !FINAL ALGEBRAIC IS LOWER ENERGY
!
                            JL=JP
                            JH=J
!
                            DO M=1,MX
                              M1=MNDEX(M,1)
                              M2=MNDEX(M,2)
                              TMP(M2,M1)=RHO2(M,NOMTG)
                            ENDDO
!
                          ENDIF
!
                          DE=DSPECJ(JH)-DSPECJ(JL)
!
                          NOMT=IROW(JL,JH,ione1,NSPECJ)         !ROWWISE
!
                          bdip=.false.
                          if(jl.le.nmetaj.and.jl.lt.jh)then !need exists
                            bdip=omginf(nomt).lt.dzero      !flag dipole
                          endif
!
! LOOP-OVER MENG0 UPPER STATE SCATTERING ENERGIES
!
                          DO M0=1,MENG0
!
                            M=IYY0(M0)
!
                            ml=mlim(m,1)
                            mu=mlim(m,2)
!
                            if(bdip)mu=-mu                  !flag dipole
!
                            RHO=-2*XINT(DE,DYY,NLAG,TMP(1,M),M,ml,mu)
                                                                   !A.U.
!
                            RHO2(M0,NOMTG)=RHO
!
                          ENDDO                  !END LOOP OVER ENERGIES
!
                        ENDDO              !END LOOP OVER INITIAL LEVELS
!
                      ENDDO                  !END LOOP OVER FINAL LEVELS
!
                      if(btimet)then
                        call nrb_time(timef)
                        timeint=timeint+timef-timei
                        timei=timef
                      endif
!
                      mx=meng0                                   !re-set
!
                    endif
!
                    NOMTG=NCJ0*NCJP0
                    DO M=1,MX
                      DO N=1,NOMTG
                        RHO1(N,M)=RHO2(M,N)
                      ENDDO
                    ENDDO
!
                    if(btimet)then
                      call nrb_time(timef)
                      timeset=timeset+timef-timei
                      timei=timef
                    endif
!
!-----------------------------------------------------------------------
!
! NOW MIX (INITIAL)
!
                    N0=NADRUG(JIG)
                    N0P=NADRUG(JFG)
                    NJ=NTGJ(JIG)
                    NJP=NTGJ(JFG)
!                    NCJ0=NT(JIG)
!                    NCJP0=NT(JFG)
!
                    DO NCJ=1,NCJ0        !BEGIN LOOP OVER INITIAL LEVELS
!
                      J1=NCJ+NJ
                      j=jndxj(j1)
                      if(j.lt.0)go to 184                     !omit corr
                      if(j.gt.nmetaj)go to 184      !omit non-metastable
!
                      if(bcorr.or.kayi.eq.kayf)then
                        DO NCJP=1,NCJP0    !SEE IF WE HAVE A FINAL LEVEL
                          J1P=NCJP+NJP
                          IF(J1P.GT.J1.and.kayi.eq.kayf)GO TO 184
                          jp=jndxj(j1p)
                          if(jp.gt.0)go to 180                    !we do
                        ENDDO
                        GO TO 184                              !WE DON'T
                      endif
!
  180                 N1=N0+(NCJ-1)*NCJ0                    !tfu pointer
!
                      DO M=1,MX
!
                        DO NCJP=1,NCJP0            !FOR EACH FINAL LEVEL
!
                          NG0=(NCJP-1)*NCJ0              !for rho1 nomtg
!
                          IF(LAPAK.GT.0)THEN                     !LAPACK
                DD=DDOT(NCJ0,RHO1(NG0+1,M),IONE,TFU(N1+1),IONE)  !LAPACK
                          ELSE                                   !LAPACK
                          DD=DZERO
                          DO LD1=1,NCJ0            !BEGIN INITIAL MIXING
!x                             IF(ABS(TFU(N1+LD1)).GT.XMIX)THEN
                            DD=DD+RHO1(NG0+LD1,M)*TFU(N1+LD1)
!x                             ENDIF
                          ENDDO                      !END INITIAL MIXING
                          ENDIF                                  !LAPACK
!
                          TEMP(NCJP,M)=DD
!
!                        j1p=ncjp+njp
!                        write(mw6,777)j1,j1p,temp(ncjp,m)
                        ENDDO                      !FOR EACH FINAL LEVEL
!
                      ENDDO
!
                      if(btimet)then
                        call nrb_time(timef)
                        timemixi=timemixi+timef-timei
                        timei=timef
                      endif
!
! NOW MIX (FINAL)
!
                      NOMTG0=(NCJ-1)*NCJP0               !for rho1 (new)
!
                      DO NCJP=1,NCJP0      !BEGIN LOOP OVER FINAL LEVELS
!
                        J1P=NCJP+NJP
                        if(j1.eq.j1p.and.ione1.ne.0)go to 182
                        if(kayi.eq.kayf)then
                          IF(J1P.GT.J1)GO TO 184
                          if(j1.eq.j1p.and.lf.gt.li)go to 182
                        endif
!
                        jp=jndxj(j1p)
                        if(jp.lt.0)go to 182                  !omit corr
!                        if(min(j,jp).gt.nmetaj)go to 10 !non-metastable
!
                        N1P=N0P+(NCJP-1)*NCJP0              !tfu pointer
!
                        NOMTG=NOMTG0+NCJP                    !rho1 (new)
!
                        DO M=1,MX
!
                          IF(LAPAK.GT.0)THEN                     !LAPACK
                  DD=DDOT(NCJP0,TEMP(1,M),IONE,TFU(N1P+1),IONE)  !LAPACK
                          ELSE                                   !LAPACK
                          DD=DZERO
                          DO LDP1=1,NCJP0            !BEGIN FINAL MIXING
!x                             IF(ABS(TFU(N1P+LDP1)).GT.XMIX)THEN
                            DD=DD+TEMP(LDP1,M)*TFU(N1P+LDP1)
!x                             ENDIF
                          ENDDO                        !END FINAL MIXING
                          ENDIF                                  !LAPACK
!
                          RHO2(M,NOMTG)=DD
!
                        ENDDO
!
!                        write(mw6,777)j1,j1p,(rho2(m,nomtg),m=1,mx)
  182                 ENDDO                  !END LOOP OVER FINAL LEVELS
!
                      if(btimet)then
                        call nrb_time(timef)
                        timemixf=timemixf+timef-timei
                        timei=timef
                      endif
!
  184               ENDDO                  !END LOOP OVER INITIAL LEVELS
!
! FIRST SEE IF WE NEED REVERSE CASE:
!----------------------------------
!
!  INITIAL & FINAL ARE ALGEBRAIC AND SO NMETA CAN BE IN EITHER/BOTH/NONE
!  BUT WE WANT THE FIRST MIXING MATRIX MULT TO BE FOR NMETAJ SO WE DON'T
!  NEED TO MULTIPLY BY THE ZERO BLOCK. THUS, WE MAKE A DOUBLE PASS. OF
!  COURSE, IF NMETAJ=NSPECJ THEN THE SECOND PASS IS "SKIPPED".
!
                    DO NCJP=1,NT(JIG)              !CHECK INITIAL LEVELS
                      J1P=NCJP+NTGJ(JIG)
                      jp=jndxj(j1p)
                      if(jp.gt.nmetaj)go to 186                  !needed
                    ENDDO
                    GO TO 196                                  !ALL DONE
!
! NOW MIX (FINAL) - REVERSE CASE
!
  186               N0=NADRUG(JFG)
                    N0P=NADRUG(JIG)
                    NJ=NTGJ(JFG)
                    NJP=NTGJ(JIG)
                    NCJ0=NT(JFG)
                    NCJP0=NT(JIG)
!
                    DO NCJ=1,NCJ0          !BEGIN LOOP OVER FINAL LEVELS
!
                      J1=NCJ+NJ
                      j=jndxj(j1)
                      if(j.lt.0)go to 194                     !omit corr
                      if(j.gt.nmetaj)go to 194      !omit non-metastable
!
                      DO NCJP=1,NCJP0      !SEE IF WE HAVE INITIAL LEVEL
                        J1P=NCJP+NJP
                        IF(J1P.LT.J1.and.kayi.eq.kayf)GO TO 188
                        jp=jndxj(j1p)
                        if(jp.gt.nmetaj)go to 190                 !we do
  188                 ENDDO
                      GO TO 194                                !WE DON'T
!
  190                 N1=N0+(NCJ-1)*NCJ0                    !tfu pointer
!
                      DO M=1,MX
!
                        DO NCJP=1,NCJP0          !FOR EACH INITIAL LEVEL
!
                          IF(LAPAK.GT.0)THEN                     !LAPACK
                DD=DDOT(NCJ0,RHO1(NCJP,M),NCJP0,TFU(N1+1),IONE)  !LAPACK
                          ELSE                                   !LAPACK
                          NG0=NCJP-NCJP0                 !for rho1 nomtg
                          DD=DZERO
                          DO LD1=1,NCJ0              !BEGIN FINAL MIXING
!x                              IF(ABS(TFU(N1+LD1)).GT.XMIX)THEN
                            DD=DD+RHO1(NG0+LD1*NCJP0,M)*TFU(N1+LD1)
!x                              ENDIF
                          ENDDO                        !END FINAL MIXING
                          ENDIF                                  !LAPACK
!
                          TEMP(NCJP,M)=DD
!
!                        j1p=ncjp+njp
!                        write(mw6,777)j1,j1p,temp(ncjp,m)
                        ENDDO                    !FOR EACH INITIAL LEVEL
!
                      ENDDO
!
                      if(btimet)then
                        call nrb_time(timef)
                        timemixfr=timemixfr+timef-timei
                        timei=timef
                      endif
!
! NOW MIX (INITIAL) - REVERSE CASE
!
                      DO NCJP=1,NCJP0    !BEGIN LOOP OVER INITIAL LEVELS
!
                        J1P=NCJP+NJP
                        if(j1.eq.j1p.and.ione1.ne.0)go to 192
                        if(kayi.eq.kayf)then
                          IF(J1P.LT.J1)GO TO 192
                          if(j1.eq.j1p.and.lf.gt.li)go to 192
                        endif
!
                        jp=jndxj(j1p)
!                        if(jp.lt.0)go to 12                  !omit corr
                        if(jp.le.nmetaj)go to 192        !already gotten
!
                        N1P=N0P+(NCJP-1)*NCJP0              !tfu pointer
!
                        NOMTG=NCJ+(NCJP-1)*NCJ0        !rho1 nomtg (new)
!
                        DO M=1,MX
!
                          IF(LAPAK.GT.0)THEN                     !LAPACK
                  DD=DDOT(NCJP0,TEMP(1,M),IONE,TFU(N1P+1),IONE)  !LAPACK
                          ELSE                                   !LAPACK
                          DD=DZERO
                          DO LDP1=1,NCJP0          !BEGIN INITIAL MIXING
!x                              IF(ABS(TFU(N1P+LDP1)).GT.XMIX)THEN
                            DD=DD+TEMP(LDP1,M)*TFU(N1P+LDP1)
!x                              ENDIF
                          ENDDO                      !END INITIAL MIXING
                          ENDIF                                  !LAPACK
!
                          RHO2(M,NOMTG)=DD
!
                        ENDDO
!
!                        write(mw6,777)j1,j1p,(rho2(m,nomtg),m=1,mx)
  192                 ENDDO                !END LOOP OVER INITIAL LEVELS
!
                      if(btimet)then
                        call nrb_time(timef)
                        timemixir=timemixir+timef-timei
                        timei=timef
                      endif
!
  194               ENDDO                    !END LOOP OVER FINAL LEVELS
!
! RE-SET
                    NJ=NTGJ(JIG)
                    NJP=NTGJ(JFG)
                    NCJ0=NT(JIG)
                    NCJP0=NT(JFG)
!
  196               CONTINUE
!
!-----------------------------------------------------------------------
!
! (IF bmix INTERPOLATE MIXED RHO2.) CONVERT TO TMX AND ADD TO OMEGA
! NOTE, RHO2 IS IN "A.U"
! ALLOW FOR ANY INITIAL ALGEBRAIC LEVELS NOT BEING LOWEST IN ENERGY.
!
                    if(.not.bmix)mx=-mx              !skip interp set-up
!
                    DO NCJ=1,NCJ0        !BEGIN LOOP OVER INITIAL LEVELS
!
                      J1=NCJ+NJ
                      j=jndxj(j1)
                      if(j.lt.0)go to 202                     !omit corr
!
                      IF(BPRNT2.or.bunit2.or.bntest)THEN
                        NCHJ=NCHAJK(KX,KAYI,JIG,LI,NCJ,NTGJ)
                      ENDIF
! hold
                      if(bunit2)then
                        iwrkn(nchj)=j
                        iwrkl(nchj)=l0
                      endif
!
                      NOMTG0=(NCJ-1)*NCJP0
                      DO NCJP=1,NCJP0      !BEGIN LOOP OVER FINAL LEVELS
!
                        J1P=NCJP+NJP
                        if(j1.eq.j1p.and.ione1.ne.0)go to 200
                        if(kayi.eq.kayf)then
                          IF(J1P.GT.J1)GO TO 202
                          if(j1.eq.j1p.and.lf.gt.li)go to 200
                        endif
!
                        JP=JNDXJ(J1P)
                        if(jp.lt.0)go to 200                  !omit corr
                        if(min(j,jp).gt.nmetaj)go to 200 !non-metastable
!
                        IF(BPRNT2.or.bunit2.or.bntest)THEN
                          NCHJP=NCHAJK(KX,KAYF,JFG,LF,NCJP,NTGJ)
                        ENDIF
!
!                        write(mw6,*)nchj,nchjp,j1,j1p,j,jp
!
                        if(bntest)ntest(nchj,nchjp)=ntest(nchj,nchjp)+1
!
! "undefined" should not be accessed by xint...
!                        do m2=1,meng
!                          do m1=1,meng
!                            tmp(m1,m2)=1.d70 !dzero              !test
!                          enddo
!                        enddo
!
                        NOMTG=NOMTG0+NCJP              !rho2 nomtg (new)
!
                        IF(J.LE.JP)THEN !INITIAL ALGEBRAIC IS LOWER ENRG
!
                          JL=J
                          JH=JP
                          NCHL=NCHJ
                          NCHH=NCHJP
                          LUP=LF
!
                          DO M=1,MX
                            M1=MNDEX(M,1)
                            M2=MNDEX(M,2)
                            TMP(M1,M2)=RHO2(M,NOMTG)
                          ENDDO
!
                        ELSE            !FINAL ALGEBRAIC IS LOWER ENERGY
!
                          JL=JP
                          JH=J
                          NCHL=NCHJP
                          NCHH=NCHJ
                          LUP=LI
!
                          DO M=1,MX
                            M1=MNDEX(M,1)
                            M2=MNDEX(M,2)
                            TMP(M2,M1)=RHO2(M,NOMTG)
                          ENDDO
!
                        ENDIF
!
                        DE=DSPECJ(JH)-DSPECJ(JL)
!
                        NOMT=IROW(JL,JH,ione1,NSPECJ)           !ROWWISE
!
                        if(nomt.gt.nomwrt)then    !shouldn't happen, now
                          write(mw0,*)jl,jh,nmetaj,nspecj,nomt,nomwrt
                          stop 'omega prob.'
                        endif
!
                        bdip=omginf(nomt).lt.dzero          !flag dipole
!
                        if(bunit2)then
                          if(nchjp.le.nchj)then
                            nchl=nchjp
                            nchh=nchj
                          else
                            nchl=nchj
                            nchh=nchjp
                          endif
                        endif
!
! LOOP-OVER MENG0 UPPER STATE SCATTERING ENERGIES
!
                        DO M0=1,MENG0
!
                          M=IYY0(M0)
!
                          if(mx.gt.0)then                        !interp
!
                            ml=mlim(m,1)
                            mu=mlim(m,2)
!
                            if(bdip)mu=-mu                  !flag dipole
!
                            RHO=-2*XINT(DE,DYY,NLAG,TMP(1,M),M,ml,mu)
                                                                   !A.U.
!
                          else                             !already have
!
                            RHO=RHO2(M0,NOMTG)
!
                          endif
!
                          RHOSQ=RHO*RHO
! store for ii
                          if(bunit2)then
                            bst=j1.eq.j1p.and.li.eq.lf.and.kayi.eq.kayf
                            if(bst.neqv.(nchj.eq.nchjp))then
                              stop 'dwbp: diagonal index issue?'
                            endif
                            nx=irow(nchl,nchh,izero,nchjt)
                            rhom(nx,m0)=rho
                            go to 198
                          endif
!
!                          IF(NCHJ.eq.NCHJP)THEN            !DIAGONAL MX
!
                          btest=j1.eq.j1p.and.li.eq.lf.and.kayi.eq.kayf
                          if(btest)then
!
                            IF(BRMX)THEN                !USUAL REACTANCE
                              T=PI*PSHFTX(M,L0)
                              CT=COS(T)
                              ST=SIN(T)
                              RMX=(ST+RHO*CT)/(CT+RHO*ST)
                            ENDIF
!
                            IF(BPRNT3)WRITE(MW6,10040)NCHL,NCHH,JL,JH,  &
     &                         PSHFTX(M,L0),M0,'PHASE SHIFT'
                            T=TPI*PSHFTX(M,L0)
                            C2T=COS(T)
                            S2T=SIN(T)
!
                            if(bunit)then                   !2x2 UNITARY
                              TSQ=DONE+(C2T*(RHOSQ-DONE)+DTWO*S2T*RHO)  &
     &                            /(RHOSQ+DONE)
                            else                            !non-unitary
                              tsq=done+(dtwo*s2t*rho-c2t)
                            endif
!
                            TSQ=TSQ+TSQ     ! T^R=1+EXP(2I*TAU)(T^RHO-1)
!
                          ELSE                             !OFF DIAGONAL
!
                            IF(BRMX)THEN                !USUAL REACTANCE
                              T1=TPI*PSHFTX(M,L0)
                              T2=TPI*PSHFTX(M,L00)
                              DET=COS(T1)*COS(T2)-RHOSQ*SIN(T1)*SIN(T2)
                              RMX=RHO/DET
                            ENDIF
!
                            TSQ=4*RHOSQ      ! |T^R(V,V')|=|T^RHO(V,V')|
!
                            if(bunit)TSQ=TSQ/(DONE+RHOSQ)**2 !~UNITARITY
!
!                                    !FOR ELASTIC LI.NE.LF .OR. KI.NE.KF
                            IF(J1.EQ.J1P)TSQ=TSQ+TSQ
!
                          ENDIF
!
                          if(tsq.lt.d1m20)tsq=dzero
!
                          IF(BPRNT3)THEN
                            IF(BRMX)THEN
                              WRITE(MW6,10040)NCHL,NCHH,JL,JH,RMX,M0,   &
     &                              'R-MATRIX  '
                            ELSE
                              WRITE(MW6,10040)NCHL,NCHH,JL,JH,RHO,M0,   &
     &                              'RHO-MATRIX'
                            ENDIF
                          ENDIF
!
                          OMPW=wait*TSQ*NWTJ/DTWO
!
                          if(bht)ompw=ompw/2   !for BHT(1970) comparison
!
! LOOK AT TOP-UP ISSUES, IF L LARGE ENOUGH TO WARRANT IT (OFF IF BTHRSH)
!
                          IF(JNEW.GE.LRGLMN)THEN
!                                                     !NON-DIPOLE TOP-UP
                            IF(OMGINF(NOMT).GT.DZERO.AND.litlam.GT.0)   &
     &                         THEN
!
                              IF(JNEW.EQ.LRGLAM)THEN       !APPLY TOP-UP
                                EJ=DYY0(M0)
                                EI=EJ+DE
!
                                ompw0=ompw
                                ompw=ompw/wait
                                IF(BPRNT3)OMPW=-OMPW         !FLAG PRINT
!
                                CALL TOP2(LITLAM,LRGLAM/2,EI,EJ,OMPW)
!
                                ompw=ompw+ompw0*(wait-done)/wait !adjust
!
                              ELSEIF(JNEW.GT.LRGLAM)THEN
                                OMPW=DZERO
                              ENDIF
!                                                  !DIPOLE:LITLAM=LRGLAM
                            ELSEIF(bdip)THEN              !POSS ZERO-OUT
!                                            !ZERO-OUT AS INC. IN TOP-UP
                              IF(MAX(LI,LF).GT.LRGLAM)OMPW=DZERO
!
                            ENDIF
!
                          ENDIF
!
! ARCHIVE PARTIAL/TOTAL COLLISION STRENGTHS
!
                          IF(BTHRSH)THEN
                            M00=LUP/2+1-LVMIN
                            IF(M00.LT.1.OR.M00.GT.MOGGY)GO TO 200
                          ELSE               !CASE NOT XCLUDED BY ALGXLS
                            M00=M0
                          ENDIF
!
                          OMP(M0)=OMPW
!                                                    !UPDATE TOTAL OMEGA
                          OMEGA(M00,NOMT)=OMEGA(M00,NOMT)+REAL(OMPW,RP)
!
  198                   ENDDO                    !END LOOP OVER ENERGIES
!                                                         !PARTIAL OMEGA
                        IF(BPRNT2.and..not.bunit2)THEN
                          WRITE(MW6,10030)NCHL,NCHH,JL,JH,              &
     &                                    (OMP(M0),M0=1,MENG0)
                        ENDIF
!
  200                 ENDDO                  !END LOOP OVER FINAL LEVELS
!
  202               ENDDO                  !END LOOP OVER INITIAL LEVELS
!
                    if(btimet)then
                      call nrb_time(timef)
                      timeint=timeint+timef-timei
                      timei=timef
                    endif
!
                  ENDDO                           !END LOOP OVER FINAL L
!
                ENDDO                           !END LOOP OVER INITIAL L
!
              ENDDO                       !END LOOP OVER FINAL JP GROUPS
!
            ENDDO                       !END LOOP OVER INITIAL JP GROUPS
!
          ENDDO                                   !END LOOP OVER FINAL K
!
        ENDDO                                   !END LOOP OVER INITIAL K
!
        if(bntest)then
          do i=1,nchjt
            if(ntest(i,i).ne.1)then
              write(mw0,*)'checksum wrong for nchj,nchj ',i,' :',       &
     &                    ntest(i,i)
            endif
            do j=i+1,nchjt
              if(ntest(i,j)+ntest(j,i).ne.1)then
                write(mw0,*)'checksum wrong for nchj,nchjp',i,j,' :',   &
     &                      ntest(i,j),ntest(j,i)
              endif
            enddo
          enddo
        endif
!
! now determine t-matrix from full rho-matrix for approximation-ii:
!
        if(bunit2)then
!
          do m0=1,meng0
            m=iyy0(m0)
!
            if(m0.gt.0)then                                      !LAPACK
             call pqlap(nchjt,rhom(1,m0),wrkp,wrkq,work,nf)      !LAPACK
            else                                                 !LAPACK
            call pq(nchjt,rhom(1,m0),wrkp,wrkq,work,nf)
            endif                                                !LAPACK
!
            if(nf.le.0)go to 500
!
            do nchj=1,nchjt
!
              j=iwrkn(nchj)
              if(j.le.0)go to 210
              l0=iwrkl(nchj)
!
              do nchjp=nchj,nchjt
!
                jp=iwrkn(nchjp)
                if(jp.le.0)go to 205
!
                n=irow(nchj,nchjp,izero,nchjt)
                tp=-2*wrkp(n)                 !real T^rho
                tq=-2*wrkq(n)                 !imag T^rho
!
                if(nchj.eq.nchjp)then
                  t=tpi*pshftx(m,l0)
                  if(bprnt2)then
                    write(mw6,10040)nchj,nchjp,j,jp,pshftx(m,l0),m0,    &
     &                              'phase shift'
                  endif
                  c2t=cos(t)
                  s2t=sin(t)
                  tp1=tp-done
!                  tr=done+c2t*tp1-tq*s2t
!                  ti=s2t*tp1+c2t*tq
!                  tsq=tr*tr+ti*ti
                  tsq=done+(2*c2t+tp1)*tp1-(2*s2t-tq)*tq
                else
                  tsq=tp*tp+tq*tq
                  if(j.eq.jp)tsq=tsq+tsq
                endif
!
                ompw=wait*tsq*nwtj/dtwo
!
                if(bht)ompw=ompw/2      !for bht(1970) comparison
!
                if(j.le.jp)then
                  jl=j
                  jh=jp
                  nchl=nchj
                  nchh=nchjp
                else
                  jl=jp
                  jh=j
                  nchl=nchjp
                  nchh=nchj
                endif
!
                nomt=irow(jl,jh,ione1,nspecj)
! some top-up
                if(jnew.ge.lrglmn)then             !look at top-up
!
                  if(omginf(nomt).gt.dzero)then        !non-dipole
!
                    if(jnew.eq.lrglam)then           !apply top-up
                      de=dspecj(jh)-dspecj(jl)
                      ej=dyy0(m0)
                      ei=ej+de
!
                      ompw0=ompw
                      ompw=ompw/wait
                      if(bprnt3)ompw=-ompw             !flag print
!
                      call top2(itwo,lrglam/2,ei,ej,ompw)
!
                      ompw=ompw+ompw0*(wait-done)/wait     !adjust
!
                    elseif(jnew.gt.lrglam)then
                      ompw=dzero
                    endif
!
                  elseif(omginf(nomt).lt.dzero)then        !dipole
                    if(jnew.gt.lrglam)ompw=dzero
                  endif
!
                endif
!
                omp(m0)=ompw
                omega(m0,nomt)=omega(m0,nomt)+real(ompw,rp)
                if(bprnt2)write(mw6,10030)nchl,nchh,jl,jh,tp,tq,omp(m0)
!
  205         enddo
!
  210       enddo
            if(bprnt2)write(mw6,*)':'
!
          enddo
!
          if(btimet)then
            call nrb_time(timef)
            timeunit=timeunit+timef-timei
          endif
!
          deallocate(rhom,wrkp,wrkq,iwrkn,iwrkl,work,stat=ierr)
!
          if(ierr.ne.0)then
            write(mw0,*)'dwxbp: de-allocation fails for rhom,wrk'
            nf=0
            go to 900
          endif
!
        endif
!
!-----------------------------------------------------------------------
!
        if(btimet)then
          write(iw,*)'  set-up time=',nint(timeset),'sec'
          write(iw,*)'   mixi  time=',nint(timemixi),'sec'
          write(iw,*)'   mixf  time=',nint(timemixf),'sec'
          write(iw,*)'   mixir time=',nint(timemixir),'sec'
          write(iw,*)'   mixfr time=',nint(timemixfr),'sec'
          timemix=timemixi+timemixf+timemixir+timemixfr
          write(iw,*)'  mixing time=',nint(timemix),'sec'
          write(iw,*)'  interp time=',nint(timeint),'sec'
          if(bunit2)write(iw,*)' unitary time=',nint(timeunit),'sec'
        endif
!
        if(btimex)then
          call nrb_time(timef)
          times=timef-timej
!
!par          if(iam.ge.0)then                                      !par
!par            write(iwp,*)'Ending proc',iam                       !par&
!par     &               ,'dwxbp symmetry',kx,':',' nchan='         !par&
!par     &               ,nchsjt,'(',nchjt,')'                      !par&
!par     &               ,'  time=',nint(times),'sec'               !par
!par            call flush(iwp)                                     !par
!par          else                                                  !par
          write(iw,*)'Ending dwxbp symmetry ',kx,':',' nchan=',nchsjt,  &
     &               '(',nchjt,')','  time=',nint(times),'sec'
!par          endif                                                 !par
        endif
!
!-----------------------------------------------------------------------
!
!                                          -----------------------------
      ENDDO                                !END LOOP OVER TOTAL JP SYMMS
!                                          -----------------------------
!
!par!                                                               !par
!par      if(iam.ne.0)then                                          !par
!par        if(btimex)then                                          !par
!par          btimep=.false.                                        !par
!par          call nrb_time(timef)                                  !par
!par          times=timef-time0                                     !par
!par!                                                               !par
!par          write(iw,*)'Ending proc',iam,' for dwxbp:'            !par&
!par     &             ,' time=',nint(times),'sec'                  !par
!par        endif                                                   !par
!par      endif                                                     !par
!par!                                                               !par
!par      ns=0                                                      !par
!par      nr=0                                                      !par
!par      itmp4=int(nomwrt,sp_mpi)                                  !par
!par!                                                               !par
!par      do m0=1,moggy                                             !par
!par!                                                               !par
!par        call pomsend(ns,omega(1,1),nomwrt,omsend)               !par
!par!                                                               !par
!par        call comm_barrier()                                     !par
!par!                                                               !par
!par        call mpi_reduce(omsend,omrecv,itmp4,my_mpi_real,        !par&
!par     &                  mpi_sum,izero_mpi,mpi_comm_world,ier4)  !par
!par!                                                               !par
!par        if(ier4.ne.0)write(mw0,*)'mpi_reduce: iam,ier=',iam,ier4!par
!par!                                                               !par
!par        call comm_barrier()                                     !par
!par!                                                               !par
!par        if(iam.eq.0)call pomrecv(nomwrt,omrecv,nr,omega(1,1))   !par
!par!                                                               !par
!par      enddo                                                     !par
!par!                                                               !par
!par      if(iam.ne.0)go to 5000                                    !par
!par!                                                               !par
!
! APPLY (DIPOLE) TOP-UP (OFF IF BTHRSH)
!
      IF(LRGLAM.GT.1)THEN
!
        WRITE(MW6,10210)LRGLAM
        if(btimex)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Proc',iam,                                !par&
!par     &       'Top-up has been applied: lrglam=',lrglam          !par
!par        else                                                    !par
          write(iw,*)'Top-up has been applied: lrglam=',lrglam
!par        endif                                                   !par
        endif
        IF(BPRNT2)WRITE(MW6,10060)
!
        LITLAM=LRGLAM/2                           !USE GLOBAL VALUE JA=0
        CO2S=D3QRT/LOG(EINF*DZ2)
!
        NOMT=0
        DO I=1,NMETAJ                                       !,NSPECL
!          IF(INDXJ(I).GT.0)THEN                               !NON-CORR
!
          DO J=I+ione1,NSPECJ                                !,NSPECL
!            IF(INDXJ(J).GT.0)THEN                             !NON-CORR
!
            NOMT=NOMT+1
            SS=OMGINF(NOMT)
!
            IF(SS.LT.DZERO)THEN                                  !DIPOLE
              SS=SS*CO2S                       !CONVERT TO LINE STRENGTH
              DE=DSPECJ(J)-DSPECJ(I)
              DE=DE/DZ2
              DO M0=1,MENG0
                EJ=DYY0(M0)/DZ2
                EI=EJ+DE
!
                CALL TOP1(NZA,LITLAM,EI,EJ,SS,OMT)
!
                if(bht)omt=omt/2               !for BHT(1970) comparison
!
                OM=REAL(OMEGA(M0,NOMT),WP)
                OMEGA(M0,NOMT)=OMEGA(M0,NOMT)+REAL(OMT,RP)
!
                IF(BPRNT2)WRITE(MW6,10070)I,J,SS,EI,EJ,DE,OM,OMT,OM+OMT
              ENDDO
            ENDIF
!
!              IF(NOMT.EQ.NOMWRT)GO TO 113                  !WE ARE DONE
!            ENDIF
          ENDDO
!
!          ENDIF
        ENDDO
!
      ELSE
!
        WRITE(MW6,10220)
        if(btimex)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Proc',iam,'Top-up has *NOT* been applied!'!par
!par        else                                                    !par
          write(iw,*)'Top-up has *NOT* been applied!'
!par        endif                                                   !par
        endif
!
      ENDIF
!
! 113  CONTINUE
!
! fix top-up failure on high-e near-degenerate Born allowed transitions
!
      if(btop)then
        NOMT=0
        DO I=1,NMETAJ
          DO J=I+ione1,NSPECJ
            NOMT=NOMT+1
            OMB=OMGINF(NOMT)
            IF(OMB.GT.DZERO)THEN                                   !born
              DE=DSPECJ(J)-DSPECJ(I)
              DE=MAX(DE,D1M30)
              OM=REAL(OMEGA(2,NOMT),WP)
              DO M0=3,MENG0                        !skip threshold point
                RAT=DYY0(M0)/DE
                OM1=OM
                OM=REAL(OMEGA(M0,NOMT),WP)
                IF(RAT.GT.XBTEST.AND.OM.LT.D0PT8*OM1.AND.OM1.LT.OMB)THEN
                  MM=M0-1              !max(2,m0-1) if no threshold skip
                  GO TO 215
                ENDIF
              ENDDO
              M0=MENG0
              MM=M0+1
              IF(OM1.GE.OMB)THEN
                IF(OM.LT.OMB)MM=MENG0
              ELSE
                IF(OM.LT.OM1)MM=MENG0
              ENDIF
  215         IF(BPRNT2.AND.MM.LE.MENG0)THEN
                WRITE(MW6,10110)I,J,DYY0(M0),DE,RAT,                    &
     &                          (OMEGA(M,NOMT),M=1,MENG0),OMB
              ENDIF
              DO M0=MM,MENG0
                OMEGA(M0,NOMT)=REAL(OMB,RP)
              ENDDO
            ENDIF
          ENDDO
        ENDDO
      endif
!
! test convert to cross section
!
      if(bcrossx)then
        nomt=0
        do i=1,nmetaj
          j=indxj(i)
          wi=jn(j)+1
          do j=i+ione1,nspecj
            nomt=nomt+1
            de=dspecj(j)-dspecj(i)
            do m0=1,moggy
              ej=dyy0(m0)
              ei=ej+de
              if(brel)ei=ei+dalf4*ei*ei          !wavenumber
              om=real(omega(m0,nomt),wp)
              om=xconv*om/(ei*wi)
              omega(m0,nomt)=real(om,rp)
            enddo
          enddo
        enddo
      endif
!
!-----------------------------------------------------------------------
!
! WRITE TOTALS
!
      IF(BTHRSH)THEN
        WRITE(MW6,10200)
        IF(BPRNT0)THEN
          WRITE(MW6,10310)((I,J,J=I+ione1,NSPECJ),I=1,NMETAJ)   !ROWWISE
          DO M0=1,MOGGY
            WRITE(MW6,10020)REAL(M0-1+LVMIN),(OMEGA(M0,N),N=1,NOMWRT)
          ENDDO
        ENDIF
      ELSE
        WRITE(MW6,10190)
        IF(BPRNT0)THEN
          WRITE(MW6,10300)((I,J,J=I+ione1,NSPECJ),I=1,NMETAJ)   !ROWWISE
          DO M0=1,MENG0                                         !=MOGGY
            WRITE(MW6,10020)DYY0(M0),(OMEGA(M0,N),N=1,NOMWRT)
          ENDDO
        ENDIF
      ENDIF
!
      IF(IUNIT(MRW24).GT.0)THEN
!        if(iunit(MRW23).lt.0)then                 !same status as MRW24
        OPEN(MRW23,FILE='OMGINFLS',STATUS='OLD')
        CLOSE(MRW23,STATUS='DELETE')                            !tidy-up
        IUNIT(MRW23)=-1
!        endif
        CLOSE(MRW24,STATUS='DELETE')
        IF(BTHRSH.or..not.bomega)THEN
          IUNIT(MRW24)=-1
        ELSE
          OPEN(MRW24,FILE='OMEGAIC',STATUS='REPLACE')      !USE NEW NAME
!TBD     OPEN(MRW24,FILE='OMEGAUIC',STATUS='REPLACE',FORM='UNFORMATTED')
          WRITE(MRW24,*)NZION,MION
          WRITE(MRW24,*)NSPECJ,-(MENG0+1),NOMWRT      !FLAG NO E'S .LT.0
          WRITE(MRW24,*)('  0',IWRK3(I),I=1,NSPECJ)
          WRITE(MRW24,10050)(DWRK(I),I=1,NSPECJ)
          DO M0=1,MENG0                                          !=MOGGY
            WRITE(MRW24,F713)DYY0(M0)/DZ2,(OMEGA(M0,N),N=1,NOMWRT)
          ENDDO
          WRITE(MRW24,F713)EINF,(OMGINF(N),N=1,NOMWRT)
          IUNIT(MRW24)=-1
          CLOSE(MRW24)
        ENDIF
      ENDIF
!
! OVERWRITE PWB ADF04 WITH DW, TAKING ACCOUNT OF THE FACT THAT THE PWB
! DOES NOT CONTAIN (SPIN) FORBIDDEN TRANSITIONS
!
      IF(IUNIT(MRW26).GE.0)THEN         !NO ADF04, LIKELY SINCE RAD='NO'
        WRITE(MW6,*)'NO ADF04 FILE="adf04ic"...'
        WRITE(MW0,*)'NO ADF04 FILE ON UNIT=MRW26'
!        NF=-1
        GO TO 500
      ELSEIF(IUNIT(MRW26).LT.0)THEN
        IUNIT(MRW26)=1
        OPEN(MRW26,FILE='adf04ic',STATUS='OLD',ERR=500)
      ENDIF
!
      BEXP=.FALSE.                              !*MUST* SYNC WITH DIAGFS
      IF(NSPECJ.LT.1000)THEN
        i1=0
        IF(MOGGY.LE.20)THEN
          IF(BEXP)THEN
            F761='(F5.2, I5, 8X,20(1PE10.2))'
            F762='(2I4,22(1PE10.2))'
            F767='(18X,21(F10.5))'
          ELSE
            F761='(A5,A3,I2, 6X, 20(A5, A3))'
            F762='(2I4, 22(A5, A3))'
            F767='(16X,21(F8.5))'
          ENDIF
        ELSE
          IF(BEXP)THEN
            F761='(F5.2, I5, 8X,20(1PE10.2)/(18X,20(1PE10.2)))'
            F762='(2I4,21(1PE10.2)/(18X,20(1PE10.2)))'
          ELSE
            F761='(A5,A3,I2, 6X, 20(A5, A3)/(16X, 20(A5, A3)))'
            F762='(2I4, 21(A5, A3)/(16X, 20(A5, A3)))'  !WRAP LAST POINT
          ENDIF
        ENDIF
      ELSE
        i1=1
        IF(MOGGY.LE.20)THEN
          IF(BEXP)THEN
            F761='(F5.2, I5,10X,20(1PE10.2))'
            F762='(2I5,22(1PE10.2))'
            F767='(20X,21(F10.5))'
          ELSE
            F761='(A5,A3,I2, 8X, 20(A5, A3))'
            F762='(2I5, 22(A5, A3))'
            F767='(18X,21(F8.5))'
          ENDIF
        ELSE
          IF(BEXP)THEN
            F761='(F5.2, I5,10X,20(1PE10.2)/(20X,20(1PE10.2)))'
            F762='(2I5,21(1PE10.2)/(20X,20(1PE10.2)))'
          ELSE
            F761='(A5,A3,I2, 8X, 20(A5, A3)/(18X, 20(A5, A3)))'
            F762='(2I5, 21(A5, A3)/(18X, 20(A5, A3)))'  !WRAP LAST POINT
          ENDIF
        ENDIF
      ENDIF
!
      MSC0=80
      OPEN(MSC0,STATUS='SCRATCH',FORM='FORMATTED')
      IF(.NOT.BEXP)THEN
        MSCP=81
        OPEN(MSCP,STATUS='SCRATCH',FORM='FORMATTED')
      ENDIF
!
      DO N=1,NSPECJ+2
        READ(MRW26,10100)CARD
        WRITE(MSC0,10100)CARD
      ENDDO
!
      NNN=max(NOMWRT,nomwr0)
!
      DO N=1,NNN+2
        READ(MRW26,10100,END=300)CARD
        WRITE(MSC0,10100)CARD
      ENDDO
!
  300 REWIND(MRW26)
      REWIND(MSC0)
!
      DO N=1,NSPECJ+2
        READ(MSC0,10100)CARD
        WRITE(MRW26,10100)CARD
      ENDDO
!
      IF(BTHRSH)THEN
        ITYPE=6
        WRITE(MRW26,F767)(PSHFT0(M-1+LVMIN),M=1,MOGGY)
        IF(BEXP)THEN
          WRITE(MRW26,F761)REAL(NZA+1),ITYPE,(REAL(M-1+LVMIN),M=1,MOGGY)
        ELSE
          WRITE(MSCP,10130)(REAL(M-1+LVMIN),M=1,MOGGY)
        ENDIF
      ELSE
        ITYPE=5
        IF(BEXP)THEN
          WRITE(MRW26,F761)REAL(NZA+1),ITYPE,(DYY0(M),M=1,MENG0) !=MOGGY
        ELSE
          WRITE(MSCP,10130)(DYY0(M),M=1,MENG0)                   !=MOGGY
        ENDIF
      ENDIF
!
      IF(BEXP)THEN
        READ(MSC0,F761)
      ELSE
        BACKSPACE(MSCP)
        READ(MSCP,10140)(XMANT(M),IEXP(M),M=1,MOGGY)
        iexp(0)='   '
        READ(MSC0,F761)XMANT(0)                                !,IEXP(0)
        WRITE(MRW26,F761)XMANT(0),IEXP(0),ITYPE,                        &
     &                   (XMANT(M),IEXP(M),M=1,MOGGY)
      ENDIF
!
      MENG1=MOGGY+1
      IB0=1
      JB0=IB0+IONE1
!
      ntr=0
!
      DO N=1,NNN+1
!
        IF(BEXP)THEN
          READ(MSC0,F762)JB,IB,XB0,(DUM,I=1,MXNXB),XB1
        ELSE
          READ(MSC0,F762)JB,IB,XMANT0,IEXP0,(XMANT(I),IEXP(I),I=1,MXNXB)&
     &                   ,XMANT1,IEXP1
        ENDIF
!
        JB1=JB
        IF(JB.LT.0)THEN
          JB1=NSPECJ
          IB=MIN(JB1-IONE1,NMETAJ)
          IF(BEXP)THEN
            XB0=D1M30
            XB1=DZERO
          ELSE
            XMANT0=' 1.00'
            IEXP0='-30'
            XMANT1=' 0.00'
            IEXP1='+00'
          ENDIF
        ENDIF
!
        IF(BEXP)THEN
          X0=D1M30
          X1=DZERO
        ELSE
          XMANT(0)=' 1.00'
          IEXP(0)='-30'
          XMANT(MENG1)=' 0.00'
          IEXP(MENG1)='+00'
        ENDIF
!
        DO JT=JB0,JB1
          IF(JT.EQ.JB1)THEN
            IB1=IB
          ELSE
            IB1=MIN(JT-IONE1,NMETAJ)
          ENDIF
          DO IT=IB0,IB1
!
!test        if(ione1.eq.0.or.it.ne.jt)then   !catch ione1=0 diagfs only
            ntr=ntr+1
!
            NOMT=IROW(IT,JT,IONE1,NSPECJ)
!                                            !TEST MENG0 STILL IF BTHRSH
            IF(OMEGA(MENG0,NOMT).GT.TOLO)THEN          !SKIP SA-SAP.GT.1
!
!              if(omginf(nomt).lt.dzero)then  !test write reduced dipole
!                do m=1,moggy
!                  de=log(dyy0(m)+2.7183)
!                  omega(m,nomt)=omega(m,nomt)/de
!                enddo
!              endif
!
              IF(BEXP)THEN
                IF(JT.EQ.JB1.AND.IT.EQ.IB1)THEN             !NOW ALLOWED
                  X0=XB0
                  X1=XB1
                ENDIF
                WRITE(MRW26,F762)JT,IT,X0,(OMEGA(M,NOMT),M=1,MOGGY),X1
              ELSE
                BACKSPACE(MSCP)
                WRITE(MSCP,10130)(OMEGA(M,NOMT),M=1,MOGGY)
                BACKSPACE(MSCP)
                READ(MSCP,10140)(XMANT(M),IEXP(M),M=1,MOGGY)
                IF(JT.EQ.JB1.AND.IT.EQ.IB1)THEN             !NOW ALLOWED
                  XMANT(0)=XMANT0
                  IEXP(0)=IEXP0
                  XMANT(MENG1)=XMANT1
                  IEXP(MENG1)=IEXP1
                ENDIF
                WRITE(MRW26,F762)JT,IT,(XMANT(M),IEXP(M),M=0,MENG1)
              ENDIF
!
            ENDIF
!test        endif
          ENDDO
          IB0=1
        ENDDO
!
        IF(JB.LT.0)then
          if(ntr.ne.nomwrt)then                                !checksum
            write(mw6,*)                                                &
     &                 'adf04 no. of transitions mis-match: ntr,nomwrt='&
     &                 ,ntr,nomwrt
            write(mw0,*)'adf04 no. of transitions mis-match'
            nf=-1
            go to 500
          endif
          GO TO 400
        endif
!
        JB0=JB
        IB0=IB+1
!
      ENDDO
!
      WRITE(MW0,*)'SR.DWXBP: HAVE NOT REACHED END OF adf04ic...'
      WRITE(MW6,*)'SR.DWXBP: HAVE NOT REACHED END OF adf04ic...'
      NF=-1
      GO TO 500
!
  400 WRITE(MRW26,F762)-1
      WRITE(MRW26,F762)-1,-1
!
      if(.not.badas)then                             !adas skip comments
        WRITE(MRW26,10080)
!
        NREC=1
  450   NREC=NREC+1
        BACKSPACE(MR5)
        BACKSPACE(MR5)
        READ(MR5,10150)CARD4
        IF(CARD4.NE.'A.S.'.AND.CARD4.NE.'S.S.')GO TO 450
        REWIND(MR5)
!
        DO N=1,NREC
          READ(MR5,10100)CARD
          WRITE(MRW26,10090)CARD
        ENDDO
        DATE='        '
        CALL DATE_AND_TIME(DATE)
        WRITE(MRW26,10120)DATE(7:7),DATE(8:8),DATE(5:5),DATE(6:6),      &
     &                    DATE(3:3),DATE(4:4)
      endif
!
      IUNIT(MRW26)=-1
      CLOSE(MRW26)
!
      CLOSE(MSC0)
      IF(.NOT.BEXP)CLOSE(MSCP)
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par 5000 continue                                                  !par
!
  500 CONTINUE
!
      DEALLOCATE(KACT,KTMP,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXBP: DE-ALLOCATION FAILS FOR KACT,KTMP'
        NF=0
        GO TO 900
      ENDIF
!
  600 CONTINUE
!
      DEALLOCATE(PSHFT0)                                          !SMALL
!
      DEALLOCATE(RHO1,RHO2,TEMP,OMGINF,OMEGA,STAT=IERR)
!par!                                                               !par
!par      deallocate(omsend,omrecv,stat=ierr)                       !par
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXBP: DE-ALLOCATION FAILS FOR RHO,OMEGA,TEMP'
        NF=0
        GO TO 900
      ENDIF
!
  700 DEALLOCATE(TFU,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXBP: DE-ALLOCATION FAILS FOR TFU'
        NF=0
        GO TO 900
      ENDIF
!
  800 CONTINUE
!
      DEALLOCATE(QPX,QPX0,QPOSJ)
      DEALLOCATE(NADRUG,NTGJ)
      DEALLOCATE(TMP,OMP)
      DEALLOCATE(IEXP,XMANT)
      IF(ALLOCATED(DWRK))DEALLOCATE(DWRK,IWRK3,IWRK4)
!
      deallocate(bswap)
      if(allocated(bswapj))deallocate(bswapj)
!par!                                                               !par
!par 5500 continue                                                  !par
!
  900 CONTINUE
!
!-----------------------------------------------------------------------
!
      if(btimep)then
        call nrb_time(timef)
        times=timef-time0
!
!        if(abs(modd).le.1)then
!
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Ending proc',iam,' for dwxbp:'            !par&
!par     &               ,' time=',nint(times),'sec,     '          !par&
!par     &               ,nint(times/60),'min'                      !par
!par          call flush(iw)                                        !par
!par        else                                                    !par
        write(iw,*)'Ending dwxbp: time=',nint(times),'sec,     ',       &
     &             nint(times/60),'min'
!par        endif                                                   !par
!        endif
      endif
!
!-----------------------------------------------------------------------
!
      RETURN
10010 FORMAT(2I5,2x,2I5,1p,10D12.3/(10x,10D12.3))
!
!-----------------------------------------------------------------------
!
10020 FORMAT(F21.3,2X,1P,10(E11.3)/(23X,10(E11.3)))
10030 FORMAT(2I6,3X,2I5,2X,1P,10(E11.3)/(27X,10(E11.3)))
10040 FORMAT(2I6,3X,2I5,2X,1PE11.3,10X,'E(',I2,')   ',A11)
10050 FORMAT(1P,5E16.6)
!10060 FORMAT(1PE14.8,6E11.3/(14X,6E11.3))
10060 FORMAT(3X,'CH',2X,'CHP',9X,'S',14X,'EI',10X,'EJ',10X,'DE',9X,     &
     &       'OMEGA(PAR)',2X,'OMEGA(TOP)',4X,'OMEGA(TOT)')
10070 FORMAT(2I5,3X,1PE11.3,2X,0P,3F12.4,5X,2F12.4,2X,F12.4)
10080 FORMAT('C',79('-')/'C'/'C')
10090 FORMAT('C ',A200)
10100 FORMAT(A200)
10110 FORMAT(2I5,22(1PE10.2))
10120 FORMAT('C'/'C'/'C',79('-')/'C'/'C',1X,                            &
     &       'AUTOSTRUCTURE DISTORTED-WAVE'/'C'/'C NAME:'/'C DATE: ',   &
     &       2(A1),'/',2(A1),'/',2(A1)/'C'/'C',79('-'))
10130 FORMAT(22(1PE9.2))
10140 FORMAT(22(A5,1X,A3))
10150 FORMAT(A4)
10160 FORMAT(1X,3I10,13X,I7,3I5,F19.8)
10170 FORMAT(10X,'K',8X,'LV',8X,' T',17X,'2*S+1  L   2J   CF',9X,       &
     &       '(EK-E1)/RY',15X,'NMETAJ=',I5)
10180 FORMAT(//' *** FULLY UNITARIZED K- TO T-MATRIX CONVERSION ***'//)
10190 FORMAT(///1X,136('-')//51X,                                       &
     &       '*** TOTAL COLLISION STRENGTHS (BP) ***'//1X,136('-')//)
10200 FORMAT(///1X,136('-')//45X,                                       &
     &       '*** THRESHOLD PARTIAL COLLISION STRENGTHS (BP) ***'//1X,  &
     &       136('-')//)
10210 FORMAT(//' *** TOP-UP HAS BEEN APPLIED: LRGLAM=',I5//)
10220 FORMAT(//' *** TOP-UP HAS *NOT* BEEN APPLIED ***'//)
10230 FORMAT(//1X,136('-')///49X,'*** TARGET ENERGIES (IC) ***'/)
10240 FORMAT(//1X,136('-')/)
10250 FORMAT(' SYJ=',I3,5X,'2J P =',I4,I3,5X,'NCHJT=',I6,2X,'(',I6,')')
10260 FORMAT(//' SY1=',I3,5X,'(2S+1) L P =',I3,I4,I3)    !/1X,34('-'))
10270 FORMAT(//' SYJ=',I3,5X,'2J P =',I4,I3/1X,25('-'))
10280 FORMAT(//' SY2=',I3,5X,'(2S+1) L P =',I3,I4,I3)    !/1X,34('-'))
10290 FORMAT(/4X,'CH',3X,'CHP',7X,'K',3X,'KP',4X,'OMEGA(IE=1,MENG):')
10300 FORMAT(74X,'OMEGA(K-KP)'/74X,11('-')/2X,'*FINAL* ENERGY(RYD)',2X, &
     &       10(I5,'-',I5)/(23X,10(I5,'-',I5)))
10310 FORMAT(74X,'OMEGA(K-KP)'/74X,11('-')/1X,'*FINAL* RYDBERG A.M.',2X,&
     &       10(2X,I4,'-',I4)/(23X,10(2X,I4,'-',I4)))
10320 FORMAT(//'Note: Elastic collision strengths maybe somewhat',      &
     &       ' inaccurate as not all phases are present...'/'In-elastic'&
     &       ,' collision strengths are unaffected'//                   &
     &       'Set kutssx.ne.-1 and',                                    &
     &       ' maxjfs=-1 to correct this - if memory allows')
10330 FORMAT(//'Note: R-matrix elements maybe somewhat inaccurate',     &
     &       ' as not all phases are present...'/                       &
     &       'rho-matrix and partial',                                  &
     &       ' collision strengths are unaffected'//                    &
     &       'Set kutssx.ne.-1 and',                                    &
     &       ' maxjfs=-1 to correct this - if memory allows')
10340 FORMAT(//'Note: elastic transitions maybe somewhat inaccurate',   &
     &       ' as not all phases are present...'/                       &
     &       'Inelastic partial collision',                             &
     &       ' strengths maybe affected indirectly'//                   &
     &       'Set kutssx.ne.-1 and',                                    &
     &       ' maxjfs=-1 to correct this - if memory allows')
10350 FORMAT(/'    NCYC SY   CH  CHP     MNF  MNR',                     &
     &       6(3X,'I(R)  F(A,...)'))
10360 FORMAT(i9,i5,2I4,2I5,i9,i6,6(i6,f9.4))
10370 FORMAT(i9,i5,2I4,2I5,i9,i6,6(i6,f9.4)/(47x,6(i6,f9.4)))
10380 FORMAT(/' *** UPDATING SLATER INTEGRALS FOR LTOT=',I3/1X,42('-')/)
10390 FORMAT(/' *** UPDATING MAGNETIC INTEGRALS FOR 2*JTOT=',I3/1X,     &
     &       46('-')/)
10400 FORMAT(7X,'NP',2X,'SYJ',2X,'SY',1X,'SYP',3X,'CH',2X,'CHP',7X,'CN',&
     &       3X,'IND',6(3X,'I(Y)  X(A-D)'))
10410 FORMAT(i8,i3,2I5,i8,i5,6(i6,f11.6))
10420 FORMAT(i8,i3,2I5,i8,i5,6(i6,f11.6)/(34x,6(i6,f11.6)))
10430 FORMAT((34x,6(i6,f11.6)))
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!-----------------------------------------------------------------------
      FUNCTION IROW(ILI,ILF,IONE1,NENG)
!
      INTEGER(SP) ILI,ILF,IONE1,NENG,IROW
!
      IROW=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE1))/2
!
      END FUNCTION IROW
!-----------------------------------------------------------------------
!
      END SUBROUTINE DWXBP_DDOT
!
!                             *******************
!
      SUBROUTINE DWXLS(FRX,PSHFTX,DRLX,MDIM0,MDIM1,MDIM2,MDIM3,MDIM4    &
     &                ,MDIM5,DZLX,DXTWOX,DETAX,MDIM6,MDIM7,MDIM8)
!
!-----------------------------------------------------------------------
!
!  SR.DWXLS WRAPPER
!
!  IT IS CALLED BY:
!    SR.DWX
!
!  IT CALLS:
!    SR.DWXLS_DAXPY
!    SR.DWXLS_DDOT
!
!-----------------------------------------------------------------------
!
      USE COMMON_MINIM,  ONLY: XMIX
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION FRX(MDIM1,MDIM2,MDIM3),PSHFTX(MDIM2,MDIM3)              &
     &         ,DRLX(MDIM4,MDIM0,0:MDIM5)                               &
     &         ,DZLX(MDIM7,MDIM6,0:MDIM8)                               &
     &         ,DXTWOX(MDIM7,MDIM6,0:MDIM8)                             &
     &         ,DETAX(MDIM7,MDIM6,0:MDIM8)
!
!
!-----------------------------------------------------------------------
!
      IF(XMIX.LT.DZERO)THEN
        CALL DWXLS_DDOT(FRX,PSHFTX,DRLX,MDIM0,MDIM1,MDIM2,MDIM3,MDIM4,  &
     &                  MDIM5,DZLX,DXTWOX,DETAX,MDIM6,MDIM7,MDIM8)
      ELSE
        CALL DWXLS_DAXPY(FRX,PSHFTX,DRLX,MDIM0,MDIM1,MDIM2,MDIM3,MDIM4, &
     &                   MDIM5,DZLX,DXTWOX,DETAX,MDIM6,MDIM7,MDIM8)
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE DWXLS
!
!                             *******************
!
      SUBROUTINE DWXLS_DAXPY                                            &
     &                (FRX,PSHFTX,DRLX,MDIM0,MDIM1,MDIM2,MDIM3,MDIM4    &
     &                ,MDIM5,DZLX,DXTWOX,DETAX,MDIM6,MDIM7,MDIM8)
!
!-----------------------------------------------------------------------
!
!  SR.DWXLS_DAXPY
!    CALCULATES EIE 2-BODY NFS COLLISION STRENGTHS IN LS-COUPLING
!
!  IT IS CALLED BY:
!    SR.DWXLS
!
!  IT CALLS:
!    SR.DATE_AND_TIME (SYSTEM)
!    SR.NRB_TIME
!    SR.PQ
!    SR.PQLAP
!    FN.QPTLS
!    SR.RADCNX
!    SR.SLATRX
!    SR.TOP1
!    SR.TOP2
!    FN.XINT
!
!  IT CONTAINS:
!    FN.IROW
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam,comm_barrier               !par&
!par     &                          ,sp_mpi,izero_mpi               !par
!par      use mpi, only : mpi_real4,mpi_real8,mpi_integer           !par&
!par     &               ,mpi_sum,mpi_comm_world                    !par
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL,NAD
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_MINIM,  ONLY: BECOR
      USE COMMON_MINIM,  ONLY: XMIX
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_QTG,    ONLY: NFI,NFK,NFQ
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      use common_misc,   only: ione1,ione0
      use common_misc,   only: iw,iwp,btime,btimex
      use common_misc,   only: badas
!
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,INAST0=>NASTB                            &
     &                        ,INASTJ0=>NASTJB,LFACT,JFACT              &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDW1, ONLY: MXORB,ma0,mb0
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
      USE COMMON_NRBDW4, ONLY: DSPECE,INDEX,JNDEX,NSPECE,NENERG
      USE COMMON_NRBDW5, ONLY: DYY,MENG,NLAG
      USE COMMON_NRBDW6, ONLY: QPOS,QPOS0
      USE COMMON_NRBDW7, ONLY: MNDEX,MRNDX,MTRAN,mlim
      USE COMMON_NRBDW8, ONLY: DYY0,IYY0,MENG0
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBDWX, ONLY: LLCH,ITARG,NCHG
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBIAD, ONLY: IADD
      USE COMMON_NRBKUT, ONLY: KCUTX,LSKUT,NASTK
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
      USE COMMON_NRBREL, ONLY: BREL
      USE COMMON_NRBRN3, ONLY: MXNXB,MXNXB1
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (MXLEN=200)                                 !CARD LENGTH
!
      PARAMETER (MXD13=500)
!
      INTEGER(SP) QPTLS                        !DO NOT USE SHORT INTEGER
!
      INTEGER(SP) SA,SAP
!par!                                                               !par
!par      integer(sp_mpi) itmp4,ier4,my_mpi_real                    !par
!par!                                                               !par
!par      real(rp) omsend,omrecv                                    !par
!
      REAL(RP) OMEGA,E1M30
!
      PARAMETER (E1M30=1.E-30_RP)
      PARAMETER (XBTEST=DFIVE)          !APPLY btop ONLY FOR X.GT.XBTEST
!
      CHARACTER(LEN=3) IEXP,IEXP0,IEXP1
      CHARACTER(LEN=4) CARD4
      CHARACTER(LEN=5) XMANT,XMANT0,XMANT1
      CHARACTER(LEN=8) DATE
      CHARACTER(LEN=15) F767
      CHARACTER(LEN=29) F713
      CHARACTER(LEN=35) F762
      CHARACTER(LEN=44) F761
      CHARACTER(LEN=MXLEN) CARD
!
      ALLOCATABLE :: RHO1(:,:),RHO2(:,:),OMEGA(:,:),TFU(:)              &
     &              ,TEMP(:,:),OMGINF(:),KACT(:,:),KTMP(:)
!par      allocatable :: omsend(:),omrecv(:)                        !par
!
      allocatable :: rhom(:,:),wrkp(:),wrkq(:),iwrkn(:),iwrkl(:)        &
     &              ,work(:)
!
      allocatable :: bswap(:)
!
      ALLOCATABLE :: IEXP(:),XMANT(:)
      ALLOCATABLE :: NADRUG(:),TMP(:,:),OMP(:)                          &
     &              ,DWRK(:),IWRK3(:),IWRK4(:)
!
      ALLOCATABLE :: PSHFT0(:)
!
      DIMENSION FRX(MDIM1,MDIM2,MDIM3),PSHFTX(MDIM2,MDIM3)              &
     &         ,DRLX(MDIM4,MDIM0,0:MDIM5)                               &
     &         ,DZLX(MDIM7,MDIM6,0:MDIM8)                               &
     &         ,DXTWOX(MDIM7,MDIM6,0:MDIM8)                             &
     &         ,DETAX(MDIM7,MDIM6,0:MDIM8)
!
      dimension ntest(1,1)                     !check channel set-up
!
!-----------------------------------------------------------------------
!
!      IROW(ILI,ILF,IONE1,NENG)=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE1))/2
!
!-----------------------------------------------------------------------
!
! flag write of cross sections to adf04ls instead of collision strengths
! - this is for test purposes only.
!
      bcrossx=.false.                !.true.
!
      if(bcrossx)then
!
        write(mw0,*)' *** Attention, adf04ls contains cross sections!'
        write(mw6,*)' *** Attention, adf04ls contains cross sections!'
!
        xconv=done                   !pi*a_0^2
        xconv=xconv*acos(-done)      !a_0^2
        xconv=xconv*28.003D0         !Mbarns
        xconv=xconv*1.D6             !barns
!
      endif
!
! flag write of "OMEGA" file - this is by final scattered energy and so
! *not* directly usable by R-matrix utility codes such as xtrct/adasexj.
! this is somewhat historic as adasexj *does* read/process dw adf04 file
!
      bomega=.false.
!
! elastic switch (normally ione1=1, no elastic. ione1=0 inc elastic)
! now set by user in algeb, and passed thru /nrbdwm/ as needed.
!
!old  ione1=1
!
! test: DO NOT CHANGE!
!old  ione0=0                   !algxls ione1, elastic needed for mixing
!
! some test set-up switches that user joe should not need to touch.
!
      bht=.false.                  !.true. for bht(1970) test comparison
!
! set (approx) unitarity switch
!
      bunit=.true.
      if(bht)bunit=.false.
!
! set approximation-ii unitarization switch - needs the full rho-matrix
! (.and.. not.bthrsh, i.e. lvmax.lt.0) only coded for F95.
! currently, in principle, only for use at medium to high energies
! since it still works with the final scattered energy, but seems to
! work well down to low-e as well - strongest coupling with nearby
! states, i.e. ones calculated at the same/similar relative energy.
!
      bunit2=nmeta.ge.nspece.and.ione1.eq.0.and.lvmax.lt.0
!
! set print of approx r(tau=0)-matrix as opposed to rho(tau)-matrix
! *MUST* use full T=-2iR/(1-iR) if converting via R-matrix.   (not done)
! can only use weak coupling T=-2i*rho for rho-matrix -see bunit2 above.
!
      brmx=.false.
      if(jprint.eq.4)brmx=.true.
!
! set mixing switch, can test interpolation followed by mixing (false).
!
      bmix=xmix.ge.dzero                !default xmix->.true.
      xmix=abs(xmix)
!
! checks channel set-up (needs ntest dimensioned)
!
      bntest=.false.                    !ione1.eq.0.and.jprint.ge.2
!
      bntest=bntest.and.nmeta.ge.nspece
!
! if bcor then we have algebraic correlation, and we know how ordered
!
      bcor=kmax*kcut.ne.kcut*kcut
!
! if becor then we have correlation by energy, and we know not where, so
!
      beqgrpl0=.not.becor                       !false for full li=lf mx
!
! if only algebraic then can reduce memory requirement  NAD(NCOR)
!
      bcorr=bcor.and..not.becor.and.kcutx.ge.0
!par!                                                               !par
!par      if(rp.eq.4)then                                           !par
!par        my_mpi_real=mpi_real4                                   !par
!par      elseif(rp.eq.8)then                                       !par
!par        my_mpi_real=mpi_real8                                   !par
!par      else                                                      !par
!par        if(iam.eq.0)write(iw,*)'error rp precsion =',rp         !par
!par        go to 5500                                              !par
!par      endif                                                     !par
!
!-----------------------------------------------------------------------
!
      btimep=btimex                                        !for iam.ne.0
      if(btimex)then
!        if(abs(modd).le.1)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Starting proc',iam,' for dwxls'           !par
!par        else                                                    !par
        write(iw,*)'Starting dwxls'
!par        endif                                                   !par
!        endif
        call nrb_time(timei)
        time0=timei
      endif
      btimet=btimex  !.false.                             !debug timings
!
! INITIALIZATIONS
!
      PI=ACOS(-DONE)
      TPI=DTWO*PI
!
      BPRNT1=JPRINT.GE.1                       !PRINT CHANNEL INFO AGAIN
      BPRNT2=JPRINT.GE.2                    !FOR DETAILED OMEGA PRINTOUT
      BPRNT3=JPRINT.GE.3                      !FOR DETAILED RHO PRINTOUT
      BPRNT0=JPRINT.NE.-3
!
      KOLDOO=KUTOOX
      BKUTOO=KUTOOX.NE.0
!
      LAPAK=1                                                    !LAPACK
!
      IF(NZION.EQ.MION)THEN
        NZA=0
        DZ2=DONE
      ELSE
        NZA=NZION-MION
        DZ2=NZA*NZA
      ENDIF
!
      LOLD=-1                                          !INITIAL FOR QPOS
      LSTORE=0                                 !TRIVIAL INTEGRAL STORAGE
!
      IF(MAXLT.GE.0)THEN
        IF(LRGLAM.GT.MAXLT)THEN
          WRITE(MW0,*)'*** SR.DWXLS: LRGLAM.GT.MAXLT, SO NO TOP-UP'
          LRGLAM=-1
        ELSE
          IF(LRGLAM.EQ.-999)LRGLAM=MAXLT
        ENDIF
        IF(LRGLAM.EQ.0)LRGLAM=-1
      ENDIF
!
      IF(LRGLAM.GE.0)THEN        !SET L WHERE DIPOLE TOP-UP NEEDS CHECKS
        LRGLMN=LRGLAM-QCL0
      ELSE
        LRGLMN=1000
      ENDIF
!
      btop=btop.and.lrglam.ge.0
!
! SMALL LOCAL MEMORY
!
      MXD4=MAX(MENG,10_SP)+3
      ALLOCATE(IEXP(0:MXD4),XMANT(0:MXD4))
      ALLOCATE(TMP(MENG,MENG),OMP(MENG))
      ALLOCATE(NADRUG(NSL0))
!
      ixd13=mxd13
      allocate(bswap(ixd13))                                      !small
!
! SET POINTER TO START OF GROUP IN MIXING COEFFICIENT ARRAY TFU
!
      MC=0
      NCMX=0
      DO N0=1,NSL0
        NADRUG(N0)=MC
        NC=NSL(N0)
        NCMX=MAX(NCMX,NC)                        !MAX NO TERMS IN GROUP
        MC=MC+NC*NC
      ENDDO
!
! RECOVER TARGET MIXING COEFFICIENTS
!
      READ(MRW10)NCTOT
!
      if(nctot.ne.mc)stop 'dwxls:nctot index error'    !shouldn't happen
!
      ALLOCATE(TFU(NCTOT),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXLS: ALLOCATION FAILS FOR TFU'
        NF=0
        GO TO 700
      ENDIF
!
      READ(MRW10)(TFU(I),I=1,NCTOT)
!
! LOOK FOR LAST SPECTROSCOPIC ENERGY
!
!      NSPECL=0
!      DO N=1,NENERG
!        NSPECL=MAX(NSPECL,JNDEX(N))
!      ENDDO
!
! USE ROWWISE TO SIMPLY REDUCE NDIM2 IF NMETA.LT.NSPECE
!
      NOMTG=NCMX*NCMX                               !NEED ALL FOR MIXING
      nmin=min(NMETA,NSPECE)
      NOMWRT=IROW(nmin,NSPECE,ione1,NSPECE)                     !ROWWISE
      NOMWR0=NOMWRT
!test    if(ione1.eq.1)nomwr0=nomwr0+nmin      !incase ione1=0 in diagon
!
!
      BTHRSH=LVMAX.GE.0
      IF(BTHRSH)THEN
        MOGGY=LVMAX+1-LVMIN
        ALLOCATE(PSHFT0(LVMIN:LVMAX))                             !SMALL
      ELSE
        MOGGY=MENG0
        ALLOCATE(PSHFT0(LVMIN:LVMIN))                             !SMALL
      ENDIF
!
      MX=MTRAN
      if(.not.bmix)mx=meng0
!
      ALLOCATE(RHO1(MTRAN,NOMTG),RHO2(MX,NOMTG),TEMP(MX,NCMX),          &
     &         OMGINF(NOMWR0),OMEGA(MOGGY,NOMWRT),STAT=IERR)
!par!                                                               !par
!par      allocate(omsend(nomwrt),omrecv(nomwrt),stat=ierr)         !par
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXLS: ALLOCATION FAILS FOR RHO,OMEGA,TEMP'
        NF=0
        GO TO 600
      ENDIF
!
      DO N=1,NOMWRT
        OMGINF(N)=DZERO
        DO M=1,MOGGY
          OMEGA(M,N)=0
        ENDDO
      ENDDO
!
! RECOVER INFINITE ENERGY INFO (ROWWISE)
!
      IF(IUNIT(MRW23).EQ.0)THEN                !ADF04 WILL BE INCOMPLETE
        WRITE(MW6,*)'NO INFINITE ENERGY FILE="OMGINFLS"...'
        WRITE(MW0,*)'NO INFINITE ENERGY FILE ON UNIT=',MRW23
        IF(LRGLAM.GE.0)THEN
          WRITE(MW6,*)'NO INFINITE ENERGY FILE INFO, CANNOT TOP-UP'
          WRITE(MW0,*)'NO INFINITE ENERGY FILE INFO, CANNOT TOP-UP'
          NF=-1
          GO TO 500
        ELSE
          GO TO 100
        ENDIF
      ELSEIF(IUNIT(MRW23).LT.0)THEN
        OPEN(MRW23,FILE='OMGINFLS',STATUS='OLD',ERR=100)
        IUNIT(MRW23)=1
      ELSE                               !SERIAL SHOULD NOT BE HERE
        REWIND(MRW23)                       !BUT PAR ALREADY OPEN
!par        if(iam.eq.0)then                                        !par
        stop 'dwxls: omginfls confusion'
!par        endif                                                   !par
      ENDIF
!
      READ(MRW23,*)NZDUM,MDUM
      READ(MRW23,*)NSPEC0,MENGB,NOMWR0
!
      IF(NSPEC0.NE.NSPECE)THEN                   !SHOULD NOT HAPPEN, NOW
        WRITE(MW6,*)'DWXLS: INFINITE ENERGY TARGET MISMATCH',NSPEC0,    &
     &              NSPECE
        WRITE(MW0,*)'DWXLS: INFINITE ENERGY TARGET MISMATCH'
        NF=-1
        GO TO 500
      ENDIF
!
      ALLOCATE(DWRK(NSPEC0),IWRK3(NSPEC0),IWRK4(NSPEC0))
!
      READ(MRW23,*)(IWRK3(I),IWRK4(I),I=1,NSPEC0)
      READ(MRW23,10040)(DWRK(I),I=1,NSPEC0)
!
! optionally recover spec energy subset from omginf,
! and retain full-set in denerg back in algx.
!
!      do i=1,nspec0
!        dwrk(i)=dwrk(i)*dz2
!      enddo
!
      iflag=0
      if(nomwrt.ne.nomwr0)then       !should not happen in non-test mode
        if(ione1.eq.0)then                             !elastic in dwxls
          if(nomwrt-nmin.ne.nomwr0)then
            write(mw6,*)'dwxls: infinite energy omega mismatch',nomwrt, &
     &                  nomwr0
            write(mw0,*)'dwxls: infinite energy omega mismatch'
            nf=-1
            go to 500
          else                                   !case ione1=1 in diagon
            iflag=1
          endif
        else                                         !inelastic in dwxls
          if(nomwrt+nmin.ne.nomwr0)then
            write(mw6,*)'dwxls: infinite energy omega mismatch',nomwrt, &
     &                  nomwr0
            write(mw0,*)'dwxls: infinite energy omega mismatch'
            nf=-1
            go to 500
          else                                   !case ione1=0 in diagon
            iflag=2
          endif
        endif
      endif
!
      F713='(1PE14.8,6E11.3/(14X,6E11.3))'        !SUPPRESS IFORT REMARK
!
      READ(MRW23,F713)EINF,(OMGINF(I),I=1,NOMWR0)
!par!                                                               !par
!par      if(iam.ne.0)then                                          !par
!par        IUNIT(MRW23)=-1                                         !par
!par        CLOSE(MRW23)                                            !par
!par      endif                                                     !par
!
      if(iflag.eq.1)then                          !make room for elastic
        n=nomwrt+1
        nshft=nmin
        do i=nmin,1,-1
          do j=nspec0,i+1,-1
            n=n-1
            omginf(n)=omginf(n-nshft)
          enddo
          n=n-1
          omginf(n)=done                             !flag poss. allowed
          nshft=nshft-1
        enddo
        if(n.ne.1)stop 'iflag=1 nshft error'
      elseif(iflag.eq.2)then                               !drop elastic
        n=0
        nshft=1
        do i=1,nmin
          do j=i+1,nspec0
            n=n+1
            omginf(n)=omginf(n+nshft)
          enddo
          nshft=nshft+1
        enddo
        if(n.ne.nomwrt)stop 'iflag=2 nshft error'
      endif
!
  100 CONTINUE
!
! WRITE-OUT SPEC. TARGET ENERGIES
!
      WRITE(MW6,10220)
      WRITE(MW6,10160)NMETA
!
      DO J=1,NSPECE
        I=INDEX(J)
        JJ=NFQ(I)
        II=(1-QPI(JJ))*(QSI(JJ)+1)
        WRITE(MW6,10150)J,I,II,QLI(JJ)/2,NFK(I),DSPECE(J)
      ENDDO
!
      WRITE(MW6,10230)
!
! FLAG ACTIVE ORBITAL PAIR IN INTERACTING CONFIGS C.F. SR.ALGX BXIST0
!
      ALLOCATE(KACT(KMAX,KMAX),KTMP(NF),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXLS: ALLOCATION FAILS FOR KACT,KTMP'
        NF=0
        GO TO 500
      ENDIF
!
      DO KF=1,KMAX
        DO KG=1,KF
          KACT(KF,KG)=0
          KACT(KG,KF)=0
          DO I=1,NF
            KTMP(I)=QCG(I,KG)
          ENDDO
          K=0
          DO I=1,NF
            L0=0
            DO L=1,NF
              IF(IEQ(KTMP(L)).EQ.IEQ(QCG(I,KF)))THEN
                KTMP(L)=0
                GO TO 120
              ELSE
                IF(KTMP(L).NE.0.AND.L0.EQ.0)L0=L
              ENDIF
            ENDDO
            K=K+1
            IF(K.GT.1)GO TO 150
            KACT(KF,KG)=QCG(I,KF)
            KACT(KG,KF)=KTMP(L0)
  120     ENDDO
  150   ENDDO
      ENDDO
!
!-----------------------------------------------------------------------
!
! BEGIN LOOP OVER SCATTERING SYMMETRIES
!
!-----------------------------------------------------------------------
!
      NCOR=0
!
      if(bunit2)write(mw6,10170)
      iwait=0
      wait=done
!
      DO IX=1,INAST
!
        IS=LSPI(IX)/10000
        IP=LSPI(IX)-IS*10000
        IL=IP/10
        IP=IP-IL*10
!
        LNEW=IL
!
        IF(BKUTOO.AND.LNEW.GT.MAXLOO)THEN
          KUTOOX=0
          BKUTOO=.FALSE.
        ENDIF
!
! SEE IF WE NEED TO UPDATE INTEGRALS & CONTINUUM BASIS
!
        IF(LNEW.NE.LOLD)THEN
!
!-----------------------------------------------------------------------
!
          if(btimex)then
!!        if(abs(modd).gt.1)then   ADD IC FLAG
!par            if(iam.ge.0)then                                    !par
!par              write(iwp,*)'Starting proc',iam                   !par&
!par     &                  ,'updating continuum for l=',il         !par
!par              call flush(iwp)                                   !par
!par            else                                                !par
            write(iw,*)                                                 &
     &              'Begin update of continuum basis & integrals for L='&
     &              ,lnew
!par            endif                                               !par
!!        endif
!
            call nrb_time(timei)
            times=timei
          endif
!
!-----------------------------------------------------------------------
!
          lstep=lnew-lold
          if(lstep.gt.1.and.lfact.gt.100.and.lold.gt.0)then
            if(iwait.eq.4)then
              iwait=2
            else
              iwait=4
            endif
            wait=iwait*lstep
            wait=wait/dthree
          endif
!
! UPDATE CONTINUUM BASIS
!
          IF(BTHRSH)LCONDW=-LCONDW                            !FLAG
!
          CALL RADCNX(FRX,PSHFTX,PSHFT0,MDIM1,MDIM2,MDIM3,LNEW,LOLD,    &
     &                LCONDW,MXORB)
!
          IF(NF.LE.0)GO TO 400
!
! UPDATE EXCHANGE MULTIPOLE
!
          LDIFF=LNEW
          IF(LOLD.GE.0)LDIFF=LDIFF-LOLD
          LDIFF=LDIFF+LDIFF
!
          DO I=1,IRL
            IF(QRL(2,I).GT.MXORB)QRL(5,I)=QRL(5,I)+INT(LDIFF,QP)  !EXCHN
          ENDDO
!
! UPDATE SLATER INTEGRALS (INC. 2NFS IF BKUTOO=.TRUE.)
!
          IF(BPRNT0)WRITE(MW6,10320)LNEW
!
          DO M=1,MTRAN
            M1=MNDEX(M,1)
            M2=MNDEX(M,2)
            IF(BKUTOO)THEN
              CALL SLATRX(FRX,PSHFTX,MDIM1,MDIM2,MDIM3,DRLX(1,M,LSTORE),&
     &                    DZLX(1,M,LSTORE),DXTWOX(1,M,LSTORE),          &
     &                    DETAX(1,M,LSTORE),M1,M2,LNEW,MXORB)
            ELSE
              CALL SLATRX(FRX,PSHFTX,MDIM1,MDIM2,MDIM3,DRLX(1,M,LSTORE),&
     &                    DZLX(1,1,0),DXTWOX(1,1,0),DETAX(1,1,0),M1,M2, &
     &                    LNEW,MXORB)
            ENDIF
          ENDDO
!
          LOLD=LNEW
!
!-----------------------------------------------------------------------
!
          if(btimex)then
            call nrb_time(timef)
            times=timef-times
!
!!        if(abs(modd).gt.1)then
!par            if(iam.ge.0)then                                    !par
!par              write(iwp,*)'Ending proc',iam                     !par&
!par     &                  ,'updating continuum'                   !par&
!par     &                 ,' time=',nint(times),'sec'              !par
!par              call flush(iwp)                                   !par
!par            else                                                !par
            write(iw,*)'End update of continuum basis & integrals',     &
     &                 ', time=',nint(times),'sec'
!par            endif                                               !par
!!        endif
          endif
!
!-----------------------------------------------------------------------
!
        ENDIF
!
!
! INITIALIZE FOR LS-LOOP
!
        nwt=is
        if(il.gt.maxlx)nwt=-2*is+2
!
        IF(BPRNT1)WRITE(MW6,10270)IX,nwt,IL,IP
!
! count channels
!
        if(bprnt1)write(mw6,10240)
!
        nchlt=0
        nchs=0
!
        do n=1,nchg(ix)
          nc=itarg(n,ix)
          mc=nsl(nc)
          mci=ngrpi(nc)
          l1=llch(1,n,ix)
          l2=llch(2,n,ix)
          do l=l1,l2,4
            do m=1,mc
              j1=m+mci
              nchlt=nchlt+1
              if(jndex(j1).gt.0)then
                if(bprnt1)write(mw6,10250)nchlt,j1,l/2
                nchs=nchs+1
              endif
            enddo
          enddo
        enddo
!
        if(bntest)then
          do i=1,nchlt
            do j=1,nchlt
              ntest(j,i)=0
            enddo
          enddo
        endif
!
! initialize for approximation-ii (memory hog)
!
        if(bunit2)then
!
          nx=(nchlt*(nchlt+1))/2
!
          ALLOCATE(rhom(nx,meng0),wrkp(nx),wrkq(nx),iwrkn(nchlt),       &
     &             iwrkl(nchlt),work(nchlt),stat=ierr)
!
          if(ierr.ne.0)then
            write(mw0,*)'dwxls: allocation fails for rhom,wrk'
            nf=0
            go to 400
          endif
!
          do i=1,nchlt
            iwrkn(i)=-1
            iwrkl(i)=-1
          enddo
!
          do m=1,meng0
            n=0
            do i=1,nchlt
              n=n+1
              rhom(n,m)=done
              do j=i+1,nchlt
                n=n+1
                rhom(n,m)=dzero
              enddo
            enddo
          enddo
!
        endif
!
        IF(.NOT.BPRNT0)then
          WRITE(MW6,10260)IX,nwt,IL,IP,nchs,nchlt
        ELSEIF(.not.BPRNT1)then
          WRITE(MW6,10310)IX,nwt,IL,IP,nchs,nchlt
        ENDIF
        IF(BPRNT2)WRITE(MW6,10280)
!
!-----------------------------------------------------------------------
!
        if(btimex)then
!!        if(abs(modd).gt.1)then
!par          if(iam.ge.0)then                                      !par
!par            write(iwp,*)'Starting proc',iam                     !par&
!par     &                ,'dwxls symmetry',ix,':',nwt,il,ip        !par
!par            call flush(iwp)                                     !par
!par          else                                                  !par
          write(iw,*)'Starting dwxls symmetry',ix,':',nwt,il,ip
!par          endif                                                 !par
!!        endif
!
          call nrb_time(timei)
          times=timei
        endif
!
        if(btimet)then
          timeset=dzero
          timemix=dzero
          timemixi=dzero
          timemixf=dzero
          timemixir=dzero
          timemixfr=dzero
          timeunit=dzero
          timeint=dzero
        endif
!
!-----------------------------------------------------------------------
!
        nwt=abs(nwt)*(2*il+1)
!
        NCN=NCHG(IX)
!
        NCHI=0
        NCHI0=0
!
        DO NC0=1,NCN                     !BEGIN LOOP OVER INITIAL GROUPS
          L1=LLCH(1,NC0,IX)
          L2=LLCH(2,NC0,IX)
          NC=ITARG(NC0,IX)
          MC=NSL(NC)
          SA=QSI(NC)
          LA=QLI(NC)
          MCI=NGRPI(NC)
!
          NCHIP=0
          NCHIP0=0
!
          DO ND0=1,NC0                     !BEGIN LOOP OVER FINAL GROUPS
            L1P=LLCH(1,ND0,IX)
            L2P=LLCH(2,ND0,IX)
            ND=ITARG(ND0,IX)
            MCP=NSL(ND)
            SAP=QSI(ND)
!            IF(ABS(SA-SAP).GT.2)GO TO 68   !unnecessary...
            IF(NMETAG(NC)+NMETAG(ND).EQ.2)THEN
              NCHI=NCHI0+((L2-L1)/4+1)*MC
              NCHIP=NCHIP0+((L2P-L1P)/4+1)*MCP
              GO TO 180
            ENDIF
            LAP=QLI(ND)
            MCIP=NGRPI(ND)
!
            beqgrp=nc.eq.nd          !flag equal groups for filling rho1
!
! get lambda for non-dipole infnite energy top-up
!
            if(lnew.ge.lrglam)then
              if(sa.eq.sap)then
                litlam=0
                if(qpi(nc).ne.qpi(nd))then
                  litlam=3                         !for case of octupole
                else
                  if(la.eq.lap)then
                    if(la+lap.ge.4)litlam=2
                  else
                    litlam=abs(la-lap)/2
                  endif
                endif
              else
                litlam=-1
              endif
            else
              litlam=0
            endif
!
            NCHI=NCHI0
            DO LI=L1,L2,4                   !LOOP OVER INITIAL CHANNEL L
!
! set position of phase shift for this li
! only required by  elastic case for diagonal rho
! or if printing usual reactance matrix
!
              if(ione1.eq.0.or.brmx)then
                L=LCONDW/2+1-LNEW+LI/2
                L0=ABS(QPOS(L))
              endif
!
              lf2=l2p
              if(beqgrp)lf2=li
!
              NCHIP=NCHIP0
              DO LF=L1P,lf2,4                 !LOOP OVER FINAL CHANNEL L
!
                beqgrpl=beqgrpl0.and.beqgrp.and.li.eq.lf
!
                ncort=qptls(ix,nc0,nd0,li,lf)
!
                if(ncort.ne.ncor)then
                  write(mw0,*)ix,nc0,nd0,li,lf,ncor,ncort
                  stop 'ncor mis-match'
                endif
!
! set position of phase shift for this lf
! only need if printing usual reactance matrix, not needed by rho matrix
!
                if(brmx)then
                  L=LCONDW/2+1-LNEW+LF/2
                  L00=ABS(QPOS(L))
                endif
!
!-----------------------------------------------------------------------
!
! NOW FORM LS INTERACTION (BY TARGET SYMMETRY GROUP)
!*************************
!
! THIS IS IN THE RHO-I REPRESENTATION, WHERE
! |T^R(V,V')|=|T^RHO(V,V')| FOR CHANNELS V.NE.V'.
! WE USE T^RHO(V,V')=-2I*RHO(V,V'), WITH A 2X2 UNITARITY CONDITION.
! FOR V.EQ.V' T^R(V,V)~-2*TAN(TAU(V)), FOR RHO(V,V) SMALL.
! (IN GENERAL, WE ARE NOT INTERESTED IN ELASTIC TRANSITIONS.)
!
!
                if(btimet)call nrb_time(timei)
!
                NOMTG=MC*MCP
                DO N=1,NOMTG
                  DO M=1,MTRAN
                    RHO1(M,N)=DZERO
                  ENDDO
                ENDDO
!
                DO MD1=1,MC               !BEGIN LOOP OVER INITIAL TERMS
                  J1=MD1+MCI
                  j=jndex(j1)
                  if(kcutx.lt.0)j=abs(j)                !keep corr-corr
                  KF=NFK(J1)
!
                  DO MDP1=1,MCP             !BEGIN LOOP OVER FINAL TERMS
                    J1P=MDP1+MCIP
                    IF(beqgrpl.and.J1P.GT.J1-ione0)GO TO 154 !syncalgxls
!
                    jp=jndex(j1p)
                    if(j.lt.0.and.jp.lt.0)then  !omit cor-cor, as algxls
                      if(becor)then
                        ncor=ncor+1
                        go to 152
                      endif
                      go to 154
                    endif
!
                    N1=NAD(NCOR)+1
                    NCOR=NCOR+1
                    N2=NAD(NCOR)
!                                    write(73,*)ix,md1,mdp1,j,jp,ncor,n2
                    IF(N1.GT.N2)GO TO 152
                    KG=NFK(J1P)
!
! need to find if Slater integral initial and final states are swapped
! because of falling order. (algebraic are not swapped in LS.)
!
                    ixxx=n2-n1+1
                    if(ixxx.gt.ixd13)then
                      deallocate(bswap)
                      ixd13=ixxx
                      allocate(bswap(ixd13))
                    endif
!
                    ks=0
                    do n=n1,n2
                      ks=ks+1
                      bswap(ks)=.false.
                      n0=int(nrk(n),sp)
                      m0=qrl(1,n0)
                      if(li.eq.ql(m0))then
                        if(li.eq.lf.and.kf.ne.kg)then
                          m0=qrl(3,n0)
                          if(qn(m0).gt.0)then                  !exchange
                            if(m0.ne.kact(kg,kf))then              !swap
                              bswap(ks)=.true.
                            endif
!                         else             !direct and it doesn't matter
                          endif
!                       else           !distinct or kf=kg, so they can't
                        endif
                      else                         !trivially, they were
                        bswap(ks)=.true.
                      endif
                    enddo
!
                    NOMTG=(MDP1-1)*MC+MD1                   !rho1 (orig)
                    if(beqgrpl)nmteq=(md1-1)*mcp+mdp1
!
                    DO M=1,MTRAN
!
                      DD=DZERO
                      ks=0
                      DO N=N1,N2
                        ks=ks+1
!
                        if(bswap(ks))then !swap because of falling order
                          mm=mrndx(m)
                        else
                          mm=m
                        endif
!
                        N0=INT(NRK(N),SP)
!
                        DD=DD+DRLX(N0,mm,LSTORE)*DRK(N)
                        IF(BKUTOO)THEN
                          DS=DZLX(N0,mm,LSTORE)
                          IF(BFALL(N))DS=-DS
                          DS=DS+DXTWOX(N0,mm,LSTORE)*DRK(N)             &
     &                       +DETAX(N0,mm,LSTORE)*DEK(N)
                          DD=DD+DS
                        ENDIF
                      ENDDO
!
                      RHO1(M,NOMTG)=RHO1(M,NOMTG)+DD            !UNMIXED
!
                      if(beqgrpl.and.nomtg.ne.nmteq)then  !pop lower tri
                        mm=mrndx(m)                        !need reverse
                        rho1(mm,nmteq)=rho1(mm,nmteq)+dd
                      endif
!
                    ENDDO
!
!                    write(mw6,777)j1,j1p,(rho1(m,nomtg),m=1,mtran)
!  777               format(2i5,1p,10d12.3/(10x,10d12.3))
!
  152             ENDDO                       !END LOOP OVER FINAL TERMS
!
  154           ENDDO                       !END LOOP OVER INITIAL TERMS
!
                if(btimet)then
                  call nrb_time(timef)
                  timeset=timeset+timef-timei
                  timei=timef
                endif
!
!-----------------------------------------------------------------------
!
                MX=MTRAN
!
! INTERP THEN MIX (APPROX)
!
                if(.not.bmix)then
!
                  DO MDP1=1,MCP             !BEGIN LOOP OVER FINAL TERMS
!
                    J1P=MDP1+MCIP
                    JP=JNDEX(J1P)
!
                    NOMTG0=(MDP1-1)*MC
!
                    DO MD1=1,MC           !BEGIN LOOP OVER INITIAL TERMS
!
                      J1=MD1+MCI
                      J=JNDEX(J1)
!
                      NOMTG=NOMTG0+MD1                !rho1 nomtg (orig)
!
                      IF(J.LE.JP)THEN !INITIAL ALGEBRAIC IS LOWER ENERGY
!
                        JL=J
                        JH=JP
!
                        DO M=1,MX
                          M1=MNDEX(M,1)
                          M2=MNDEX(M,2)
                          TMP(M1,M2)=RHO1(M,NOMTG)
                        ENDDO
!
                      ELSE              !FINAL ALGEBRAIC IS LOWER ENERGY
!
                        JL=JP
                        JH=J
!
                        DO M=1,MX
                          M1=MNDEX(M,1)
                          M2=MNDEX(M,2)
                          TMP(M2,M1)=RHO1(M,NOMTG)
                        ENDDO
!
                      ENDIF
!
                      DE=DSPECE(JH)-DSPECE(JL)
!
                      NOMT=IROW(JL,JH,ione1,NSPECE)             !ROWWISE
!
                      bdip=.false.
                      if(jl.le.nmeta.and.jl.lt.jh)then      !need exists
                        bdip=omginf(nomt).lt.dzero          !flag dipole
                      endif
!
! LOOP-OVER MENG0 UPPER STATE SCATTERING ENERGIES
!
                      DO M0=1,MENG0
!
                        M=IYY0(M0)
!
                        ml=mlim(m,1)
                        mu=mlim(m,2)
!
                        if(bdip)mu=-mu                      !flag dipole
!
                        RHO=-2*XINT(DE,DYY,NLAG,TMP(1,M),M,ml,mu)
                                                                !AS A.U.
!
                        RHO1(M0,NOMTG)=RHO
!
                      ENDDO
!
                    ENDDO                   !END LOOP OVER INITIAL TERMS
!
                  ENDDO                       !END LOOP OVER FINAL TERMS
!
                  if(btimet)then
                    call nrb_time(timef)
                    timeint=timeint+timef-timei
                    timei=timef
                  endif
!
                  mx=meng0                                       !re-set
!
                endif
!
!-----------------------------------------------------------------------
!
! NOW MIX (INITIAL)
!
                N0=NADRUG(NC)
                N0P=NADRUG(ND)
!                MCI=NGRPI(NC)
!                MCIP=NGRPI(ND)
!                MC=NSL(NC)
!                MCP=NSL(ND)
!
                DO MD1=1,MC               !BEGIN LOOP OVER INITIAL TERMS
!
                  J1=MD1+MCI
                  j=jndex(j1)
                  if(j.lt.0)go to 160                         !omit corr
                  if(j.gt.nmeta)go to 160           !omit non-metastable
!
                  if(bcorr.or.li.eq.lf)then
                    DO MDP1=1,MCP           !SEE IF WE HAVE A FINAL TERM
                      J1P=MDP1+MCIP
                      IF(J1P.GT.J1.and.li.eq.lf)GO TO 160
                      jp=jndex(j1p)
                      if(jp.gt.0)go to 156                        !we do
                    ENDDO
                    GO TO 160                                  !WE DON'T
                  endif
!
  156             N1=N0+(MD1-1)*MC                          !tfu pointer
!
                  DO MDP1=1,MCP                     !FOR EACH FINAL TERM
!
                    DO M=1,MX
                      TEMP(M,MDP1)=DZERO
                    ENDDO
!
                    NG0=(MDP1-1)*MC
                    DO LD1=1,MC                    !BEGIN INITIAL MIXING
!
                      NG=NG0+LD1                             !rho1 nomtg
                      N2=N1+LD1
                      TF=TFU(N2)
!
                      IF(ABS(TF).GT.XMIX)THEN
                      IF(LAPAK.GT.0)THEN                         !LAPACK
           CALL DAXPY(MX,TF,RHO1(1,NG),IONE,TEMP(1,MDP1),IONE)   !LAPACK
                      ELSE                                       !LAPACK
                        DO M=1,MX
                          TEMP(M,MDP1)=TEMP(M,MDP1)+RHO1(M,NG)*TF
                        ENDDO
                      ENDIF                                      !LAPACK
                      ENDIF
!
                    ENDDO                            !END INITIAL MIXING
!
!                    j1p=mdp1+mcip
!                    write(mw6,777)j1,j1p,(temp(m,mdp1),m=1,mx)
!
                  ENDDO                             !FOR EACH FINAL TERM
!
                  if(btimet)then
                    call nrb_time(timef)
                    timemixi=timemixi+timef-timei
                    timei=timef
                  endif
!
! NOW MIX (FINAL)
!
                  NOMTG0=(MD1-1)*MCP                     !for rho2 (new)
!
                  DO MDP1=1,MCP             !BEGIN LOOP OVER FINAL TERMS
!
                    J1P=MDP1+MCIP
                    IF(J1P.GT.J1.and.li.eq.lf)GO TO 160
                    if(j1.eq.j1p.and.ione1.ne.0)go to 158
!
                    jp=jndex(j1p)
                    if(jp.lt.0)go to 158                      !omit corr
!                    if(min(j,jp).gt.nmeta)go to 10      !non-metastable
!
                    N1P=N0P+(MDP1-1)*MCP                    !tfu pointer
!
                    NOMTG=NOMTG0+MDP1                        !rho2 (new)
                    DO M=1,MX
                      RHO2(M,NOMTG)=DZERO
                    ENDDO
!
                    DO LDP1=1,MCP                    !BEGIN FINAL MIXING
!
                      N2P=N1P+LDP1
                      TF=TFU(N2P)
!
                      IF(ABS(TF).GT.XMIX)THEN
                      IF(LAPAK.GT.0)THEN                         !LAPACK
        CALL DAXPY(MX,TF,TEMP(1,LDP1),IONE,RHO2(1,NOMTG),IONE)   !LAPACK
                      ELSE                                       !LAPACK
                        DO M=1,MX
                          RHO2(M,NOMTG)=RHO2(M,NOMTG)+TEMP(M,LDP1)*TF
                        ENDDO
                      ENDIF                                      !LAPACK
                      ENDIF
!
                    ENDDO                              !END FINAL MIXING
!
!                    write(mw6,777)j1,j1p,(rho2(m,nomtg),m=1,mx)
  158             ENDDO                       !END LOOP OVER FINAL TERMS
!
                  if(btimet)then
                    call nrb_time(timef)
                    timemixf=timemixf+timef-timei
                    timei=timef
                  endif
!
  160           ENDDO                       !END LOOP OVER INITIAL TERMS
!
! FIRST SEE IF WE NEED REVERSE CASE:
!----------------------------------
!
!  INITIAL & FINAL ARE ALGEBRAIC AND SO NMETA CAN BE IN EITHER/BOTH/NONE
!  BUT WE WANT THE FIRST MIXING MATRIX MULT TO BE FOR NMETA SO WE DON'T
!  NEED TO MULTIPLY BY THE ZERO BLOCK. THUS, WE MAKE A DOUBLE PASS. OF
!  COURSE, IF NMETA=NSPECE THEN THE SECOND PASS IS "SKIPPED".
!
                DO MDP1=1,NSL(NC)                   !CHECK INITIAL TERMS
                  J1P=MDP1+NGRPI(NC)
                  jp=jndex(j1p)
                  if(jp.gt.nmeta)go to 162                       !needed
                ENDDO
                GO TO 172                                      !ALL DONE
!
! NOW MIX (FINAL) - REVERSE CASE
!
  162           N0=NADRUG(ND)
                N0P=NADRUG(NC)
                MCI=NGRPI(ND)
                MCIP=NGRPI(NC)
                MC=NSL(ND)
                MCP=NSL(NC)
!
                DO MD1=1,MC                 !BEGIN LOOP OVER FINAL TERMS
!
                  J1=MD1+MCI
                  j=jndex(j1)
                  if(j.lt.0)go to 170                         !omit corr
                  if(j.gt.nmeta)go to 170           !omit non-metastable
!
                  DO MDP1=1,MCP             !SEE IF WE HAVE INITIAL TERM
                    J1P=MDP1+MCIP
                    IF(J1P.LT.J1.and.li.eq.lf)GO TO 164
                    jp=jndex(j1p)
                    if(jp.gt.nmeta)go to 166                      !we do
  164             ENDDO
                  GO TO 170                                    !WE DON'T
!
  166             N1=N0+(MD1-1)*MC                          !tfu pointer
!
                  DO MDP1=1,MCP                   !FOR EACH INITIAL TERM
!
                    DO M=1,MX
                      TEMP(M,MDP1)=DZERO
                    ENDDO
!
                    DO LD1=1,MC                      !BEGIN FINAL MIXING
!
                      NG=MDP1+(LD1-1)*MCP                    !rho1 nomtg
                      N2=N1+LD1
                      TF=TFU(N2)
!
                      IF(ABS(TF).GT.XMIX)THEN
                      IF(LAPAK.GT.0)THEN                         !LAPACK
           CALL DAXPY(MX,TF,RHO1(1,NG),IONE,TEMP(1,MDP1),IONE)   !LAPACK
                      ELSE                                       !LAPACK
                        DO M=1,MX
                          TEMP(M,MDP1)=TEMP(M,MDP1)+RHO1(M,NG)*TF
                        ENDDO
                      ENDIF                                      !LAPACK
                      ENDIF
!
                    ENDDO                              !END FINAL MIXING
!
!                    j1p=mdp1+mcip
!                    write(mw6,777)j1,j1p,(temp(m,mdp1),m=1,mx)
!
                  ENDDO                           !FOR EACH INITIAL TERM
!
                  if(btimet)then
                    call nrb_time(timef)
                    timemixfr=timemixfr+timef-timei
                    timei=timef
                  endif
!
! NOW MIX (INITIAL) - REVERSE CASE
!
                  DO MDP1=1,MCP           !BEGIN LOOP OVER INITIAL TERMS
!
                    J1P=MDP1+MCIP
                    IF(J1P.LT.J1.and.li.eq.lf)GO TO 168
                    if(j1.eq.j1p.and.ione1.ne.0)go to 168
!
                    jp=jndex(j1p)
!                    if(jp.lt.0)go to 12                      !omit corr
                    if(jp.le.nmeta)go to 168             !already gotten
!
                    N1P=N0P+(MDP1-1)*MCP                    !tfu pointer
!
                    NOMTG=MD1+(MDP1-1)*MC              !rho2 nomtg (new)
                    DO M=1,MX
                      RHO2(M,NOMTG)=DZERO
                    ENDDO
!
                    DO LDP1=1,MCP                  !BEGIN INITIAL MIXING
!
                      N2P=N1P+LDP1
                      TF=TFU(N2P)
!
                      IF(ABS(TF).GT.XMIX)THEN
                      IF(LAPAK.GT.0)THEN                         !LAPACK
        CALL DAXPY(MX,TF,TEMP(1,LDP1),IONE,RHO2(1,NOMTG),IONE)   !LAPACK
                      ELSE                                       !LAPACK
                        DO M=1,MX
                          RHO2(M,NOMTG)=RHO2(M,NOMTG)+TEMP(M,LDP1)*TF
                        ENDDO
                      ENDIF                                      !LAPACK
                      ENDIF
!
                    ENDDO                            !END INITIAL MIXING
!
!                    write(mw6,777)j1,j1p,(rho2(m,nomtg),m=1,mx)
  168             ENDDO                     !END LOOP OVER INITIAL TERMS
!
                  if(btimet)then
                    call nrb_time(timef)
                    timemixir=timemixir+timef-timei
                    timei=timef
                  endif
!
  170           ENDDO                         !END LOOP OVER FINAL TERMS
!
! RE-SET
                MCI=NGRPI(NC)
                MCIP=NGRPI(ND)
                MC=NSL(NC)
                MCP=NSL(ND)
!
  172           CONTINUE
!
!-----------------------------------------------------------------------
!
! (IF bmix INTERPOLATE MIXED RHO2.) CONVERT TO TMX AND ADD TO OMEGA
! NOTE, RHO2 IS IN "A.U"
! ALLOW FOR ANY INITIAL ALGEBRAIC TERMS NOT BEING LOWEST IN ENERGY.
!
                if(.not.bmix)mx=-mx                  !skip interp set-up
!
                DO MD1=1,MC               !BEGIN LOOP OVER INITIAL TERMS
!
                  J1=MD1+MCI
                  J=JNDEX(J1)
                  if(j.lt.0)go to 178                         !omit corr
!
                  NCH=NCHI+MD1
! hold
                  if(bunit2)then
                    iwrkn(nch)=j
                    iwrkl(nch)=l0
                  endif
!
                  NOMTG0=(MD1-1)*MCP
!
                  DO MDP1=1,MCP             !BEGIN LOOP OVER FINAL TERMS
!
                    J1P=MDP1+MCIP
!
                    IF(J1P.GT.J1.and.li.eq.lf)GO TO 178
                    if(j1.eq.j1p.and.ione1.ne.0)go to 176
!
                    JP=JNDEX(J1P)
                    if(jp.lt.0)go to 176                      !omit corr
                    if(min(j,jp).gt.nmeta)go to 176      !non-metastable
!
                    NCHP=NCHIP+MDP1
!
!                    write(mw6,*)nch,nchp,j1,j1p,j,jp
!
                    if(bntest)ntest(nch,nchp)=ntest(nch,nchp)+1
!
! "undefined" should not be accessed by xint...
!                    do m2=1,meng
!                      do m1=1,meng
!                        tmp(m1,m2)=1.d70 !dzero      !test
!                      enddo
!                    enddo
!
                    NOMTG=NOMTG0+MDP1                  !rho2 nomtg (new)
!
                    IF(J.LE.JP)THEN   !INITIAL ALGEBRAIC IS LOWER ENERGY
!
                      JL=J
                      JH=JP
                      NCHL=NCH
                      NCHH=NCHP
                      LUP=LF
!
                      DO M=1,MX
                        M1=MNDEX(M,1)
                        M2=MNDEX(M,2)
                        TMP(M1,M2)=RHO2(M,NOMTG)
                      ENDDO
!
                    ELSE                !FINAL ALGEBRAIC IS LOWER ENERGY
!
                      JL=JP
                      JH=J
                      NCHL=NCHP
                      NCHH=NCH
                      LUP=LI
!
                      DO M=1,MX
                        M1=MNDEX(M,1)
                        M2=MNDEX(M,2)
                        TMP(M2,M1)=RHO2(M,NOMTG)
                      ENDDO
!
                    ENDIF
!
                    DE=DSPECE(JH)-DSPECE(JL)
!
                    NOMT=IROW(JL,JH,ione1,NSPECE)               !ROWWISE
!
                    if(nomt.gt.nomwrt)then        !shouldn't happen, now
                      write(mw0,*)jl,jh,nmeta,nspece,nomt,nomwrt
                      stop 'omega prob.'
                    endif
!
                    bdip=omginf(nomt).lt.dzero              !flag dipole
!
! LOOP-OVER MENG0 UPPER STATE SCATTERING ENERGIES
!
                    DO M0=1,MENG0
!
                      M=IYY0(M0)
!
                      if(bmix)then                               !interp
!
                        ml=mlim(m,1)
                        mu=mlim(m,2)
!
                        if(bdip)mu=-mu                      !flag dipole
!
                        RHO=-2*XINT(DE,DYY,NLAG,TMP(1,M),M,ml,mu)
                                                                !AS A.U.
!
                      else                                 !already have
!
                        RHO=RHO2(M0,NOMTG)
!
                      endif
!
                      RHOSQ=RHO*RHO
! store for ii
                      if(bunit2)then
                        if(nchp.gt.nch)stop 'dwxls: channel reversal'
                        nx=irow(nchp,nch,izero,nchlt)
                        rhom(nx,m0)=rho
                        go to 174
                      endif
!
                      IF(NCH.eq.NCHP)THEN                   !DIAGONAL MX
!                        if(j1.ne.j1p.or.li.ne.lf)stop 'not diag'
!
                        IF(BRMX)THEN                    !USUAL REACTANCE
                          T=PI*PSHFTX(M,L0)
                          CT=COS(T)
                          ST=SIN(T)
                          RMX=(ST+RHO*CT)/(CT+RHO*ST)
                        ENDIF
!
                        IF(BPRNT3)WRITE(MW6,10030)NCHL,NCHH,JL,JH,      &
     &                                  PSHFTX(M,L0),M0,'PHASE SHIFT'
                        T=TPI*PSHFTX(M,L0)
                        C2T=COS(T)
                        S2T=SIN(T)
!
                        if(bunit)then                       !2x2 UNITARY
                          TSQ=DONE+(C2T*(RHOSQ-DONE)+DTWO*S2T*RHO)      &
     &                        /(RHOSQ+DONE)
                        else                                !non-unitary
                          tsq=done+(dtwo*s2t*rho-c2t)
                        endif
!
                        TSQ=TSQ+TSQ        !  T^R=1+EXP(2I*TAU)(T^RHO-1)
!
                      ELSE                                 !OFF DIAGONAL
!
                        IF(BRMX)THEN                    !USUAL REACTANCE
                          T1=TPI*PSHFTX(M,L0)
                          T2=TPI*PSHFTX(M,L00)
                          DET=COS(T1)*COS(T2)-RHOSQ*SIN(T1)*SIN(T2)
                          RMX=RHO/DET
                        ENDIF
!
                        TSQ=4*RHOSQ        !   |T^R(V,V')|=|T^RHO(V,V')|
!
                        if(bunit)TSQ=TSQ/(DONE+RHOSQ)**2 !APPROX UNITRTY
!
                        IF(J1.EQ.J1P)TSQ=TSQ+TSQ   !FOR ELASTIC LI.NE.LF
!
                      ENDIF
!
                      IF(BPRNT3)THEN
                        IF(BRMX)THEN
                          WRITE(MW6,10030)NCHL,NCHH,JL,JH,RMX,M0,       &
     &                                    'R-MATRIX  '
                        ELSE
                          WRITE(MW6,10030)NCHL,NCHH,JL,JH,RHO,M0,       &
     &                                    'RHO-MATRIX'
                        ENDIF
                      ENDIF
!
                      OMPW=wait*TSQ*NWT/DTWO
!
                      if(bht)ompw=ompw/2       !for BHT(1970) comparison
!
! LOOK AT TOP-UP ISSUES, IF L LARGE ENOUGH TO WARRANT IT (OFF IF BTHRSH)
!
                      IF(LNEW.GE.LRGLMN)THEN
!                                                     !NON-DIPOLE TOP-UP
                        IF(OMGINF(NOMT).gt.DZERO.and.litlam.gt.0)THEN
!
                          IF(LNEW.EQ.LRGLAM)THEN           !APPLY TOP-UP
                            EJ=DYY0(M0)
                            EI=EJ+DE
!
                            ompw0=ompw
                            ompw=ompw/wait
                            IF(BPRNT3)OMPW=-OMPW             !FLAG PRINT
!
                            CALL TOP2(LITLAM,LRGLAM,EI,EJ,OMPW)
!
                            ompw=ompw+ompw0*(wait-done)/wait     !adjust
!
                          ELSEIF(LNEW.GT.LRGLAM)THEN
                            OMPW=DZERO
                          ENDIF
!                                                  !DIPOLE:LITLAM=LRGLAM
                        ELSEIF(bdip)THEN                  !POSS ZERO-OUT
!                                                        !INC. IN TOP-UP
                          IF(MAX(LI,LF)/2.GT.LRGLAM)OMPW=DZERO
!
                        ENDIF
!
                      ENDIF
!
! ARCHIVE PARTIAL/TOTAL COLLISION STRENGTHS
!
                      IF(BTHRSH)THEN
                        M00=LUP/2+1-LVMIN
                        IF(M00.LT.1.OR.M00.GT.MOGGY)GO TO 176
                      ELSE                   !CASE NOT XCLUDED BY ALGXLS
                        M00=M0
                      ENDIF
!
                      OMP(M0)=OMPW
!                                                    !UPDATE TOTAL OMEGA
                      OMEGA(M00,NOMT)=OMEGA(M00,NOMT)+REAL(OMPW,RP)
!
  174               ENDDO                        !END LOOP OVER ENERGIES
!                                                         !PARTIAL OMEGA
                    IF(BPRNT2.AND..NOT.bunit2)WRITE(MW6,10020)NCHL,NCHH,&
     &                 JL,JH,(OMP(M0),M0=1,MENG0)
!
  176             ENDDO                       !END LOOP OVER FINAL TERMS
!
  178           ENDDO                       !END LOOP OVER INITIAL TERMS
!
                if(btimet)then
                  call nrb_time(timef)
                  timeint=timeint+timef-timei
                  timei=timef
                endif
!
!-----------------------------------------------------------------------
!
                NCHIP=NCHIP+MCP
              ENDDO                               !END LOOP OVER FINAL L
!
              NCHI=NCHI+MC
            ENDDO                               !END LOOP OVER INITIAL L
!
  180       NCHIP0=NCHIP0+((L2P-L1P)/4+1)*MCP
                                             !=NCHIP
            if(nchip0.ne.nchip)stop 'nchip0.ne.nchip'
!            write(mw0,*)nchip0,nchip
          ENDDO                              !END LOOP OVER FINAL GROUPS
!
          NCHI0=NCHI0+((L2-L1)/4+1)*MC     !=NCHI
          if(nchi0.ne.nchi)stop 'nchi0.ne.nchi'
!            write(mw0,*)nchi0,nchi
        ENDDO                              !END LOOP OVER INITIAL GROUPS
!
        if(bntest)then
          if(nch.ne.nchp)stop 'channel index error'
          do i=1,nch
            if(ntest(i,i).ne.1)then
              write(mw0,*)'checksum wrong for nch,nch ',i,' :',         &
     &                    ntest(i,i)
            endif
            do j=i+1,nch
              if(ntest(i,j)+ntest(j,i).ne.1)then
                write(mw0,*)'checksum wrong for nch,nchp',i,j,' :',     &
     &                      ntest(i,j),ntest(j,i)
              endif
            enddo
          enddo
        endif
!
! now determine t-matrix from full rho-matrix for approximation-ii:
!
        if(bunit2)then
!
          do m0=1,meng0
            m=iyy0(m0)
!
            if(m0.gt.0)then                                      !LAPACK
             call pqlap(nchlt,rhom(1,m0),wrkp,wrkq,work,nf)      !LAPACK
            else                                                 !LAPACK
            call pq(nchlt,rhom(1,m0),wrkp,wrkq,work,nf)
            endif                                                !LAPACK
!
            if(nf.le.0)go to 400
!
            do nch=1,nchlt
!
              j=iwrkn(nch)
              if(j.le.0)go to 190
              l0=iwrkl(nch)
!
              do nchp=nch,nchlt
!
                jp=iwrkn(nchp)
                if(jp.le.0)go to 185
!
                n=irow(nch,nchp,izero,nchlt)
                tp=-2*wrkp(n)                 !real T^rho
                tq=-2*wrkq(n)                 !imag T^rho
!
! get T^K from T^rho
!
                if(nch.eq.nchp)then
                  t=tpi*pshftx(m,l0)
                  if(bprnt2)then
                    write(mw6,10030)nch,nchp,j,jp,pshftx(m,l0),m0,      &
     &                              'phase shift'
                  endif
                  c2t=cos(t)
                  s2t=sin(t)
                  tp1=tp-done
!                  tr=done+c2t*tp1-tq*s2t
!                  ti=s2t*tp1+c2t*tq
!                  tsq=tr*tr+ti*ti
                  tsq=done+(2*c2t+tp1)*tp1-(2*s2t-tq)*tq
                else
                  tsq=tp*tp+tq*tq
                  if(j.eq.jp)tsq=tsq+tsq
                endif
!
                ompw=wait*tsq*nwt/dtwo
!
                if(bht)ompw=ompw/2      !for bht(1970) comparison
!
                if(j.le.jp)then
                  jl=j
                  jh=jp
                  nchl=nch
                  nchh=nchp
                else
                  jl=jp
                  jh=j
                  nchl=nchp
                  nchh=nch
                endif
!
                nomt=irow(jl,jh,ione1,nspece)
! some top-up
                if(lnew.ge.lrglmn)then             !look at top-up
!
                  if(omginf(nomt).gt.dzero)then        !non-dipole
!
                    if(lnew.eq.lrglam)then           !apply top-up
                      de=dspece(jh)-dspece(jl)
                      ej=dyy0(m0)
                      ei=ej+de
!
                      ompw0=ompw
                      ompw=ompw/wait
                      if(bprnt3)ompw=-ompw             !flag print
!
                      call top2(itwo,lrglam,ei,ej,ompw)
!
                      ompw=ompw+ompw0*(wait-done)/wait     !adjust
!
                    elseif(lnew.gt.lrglam)then
                      ompw=dzero
                    endif
!
                  elseif(omginf(nomt).lt.dzero)then        !dipole
                    if(lnew.gt.lrglam)ompw=dzero
                  endif
!
                endif
!
                omp(m0)=ompw
                omega(m0,nomt)=omega(m0,nomt)+real(ompw,rp)
                if(bprnt2)write(mw6,10020)nchl,nchh,jl,jh,tp,tq,omp(m0)
!
  185         enddo
!
  190       enddo
            if(bprnt2)write(mw6,*)':'
!
          enddo
!
          if(btimet)then
            call nrb_time(timef)
            timeunit=timeunit+timef-timei
          endif
!
          deallocate(rhom,wrkp,wrkq,iwrkn,iwrkl,work,stat=ierr)
!
          if(ierr.ne.0)then
            write(mw0,*)'dwxls: de-allocation fails for rhom,wrk'
            nf=0
            go to 800
          endif
!
        endif
!
!-----------------------------------------------------------------------
!
        if(btimet)then
          write(iw,*)'  set-up time=',nint(timeset),'sec'
          write(iw,*)'   mixi  time=',nint(timemixi),'sec'
          write(iw,*)'   mixf  time=',nint(timemixf),'sec'
          write(iw,*)'   mixir time=',nint(timemixir),'sec'
          write(iw,*)'   mixfr time=',nint(timemixfr),'sec'
          timemix=timemixi+timemixf+timemixir+timemixfr
          write(iw,*)'  mixing time=',nint(timemix),'sec'
          write(iw,*)'  interp time=',nint(timeint),'sec'
          if(bunit2)write(iw,*)' unitary time=',nint(timeunit),'sec'
        endif
!
        if(btimex)then
          call nrb_time(timef)
          times=timef-times
!
!par          if(iam.ge.0)then                                      !par
!par            write(mw6,*)'Ending proc',iam                       !par&
!par     &               ,'dwxls symmetry',ix,':',' nchan='         !par&
!par     &               ,nchs,'(',nch,')'                          !par&
!par     &               ,'  time=',nint(times),'sec'               !par
!par            call flush(iwp)                                     !par
!par          else                                                  !par
          write(iw,*)'Ending dwxls symmetry ',ix,':',' nchan=',nchs,'(',&
     &               nch,')','  time=',nint(times),'sec'
!par          endif                                                 !par
        endif
!
!-----------------------------------------------------------------------
!
        KUTOOX=KOLDOO
        BKUTOO=KUTOOX.NE.0
!                                             --------------------------
      ENDDO                                   !END LOOP OVER TOTAL SYMMS
!                                             --------------------------
!
      IF(IADD.NE.NCOR)THEN
        WRITE(MW6,*)'SR.DWXLS: GLOBAL INDEX ERROR:',IADD,NCOR      !test
        GO TO 800
      ENDIF
!
!par!                                                               !par
!par      if(iam.ne.0)then                                          !par
!par        if(btimex)then                                          !par
!par          btimep=.false.                                        !par
!par          call nrb_time(timef)                                  !par
!par          times=timef-time0                                     !par
!par!                                                               !par
!par          write(iw,*)'Ending proc',iam,' for dwxls:'            !par&
!par     &             ,' time=',nint(times),'sec'                  !par
!par        endif                                                   !par
!par      endif                                                     !par
!par!                                                               !par
!par      ns=0                                                      !par
!par      nr=0                                                      !par
!par      itmp4=int(nomwrt,sp_mpi)                                  !par
!par!                                                               !par
!par      do m0=1,moggy                                             !par
!par!                                                               !par
!par        call pomsend(ns,omega(1,1),nomwrt,omsend)               !par
!par!                                                               !par
!par        call comm_barrier()                                     !par
!par!                                                               !par
!par        call mpi_reduce(omsend,omrecv,itmp4,my_mpi_real,        !par&
!par     &                  mpi_sum,izero_mpi,mpi_comm_world,ier4)  !par
!par!                                                               !par
!par        if(ier4.ne.0)write(mw0,*)'mpi_reduce: iam,ier=',iam,ier4!par
!par!                                                               !par
!par        call comm_barrier()                                     !par
!par!                                                               !par
!par        if(iam.eq.0)call pomrecv(nomwrt,omrecv,nr,omega(1,1))   !par
!par!                                                               !par
!par      enddo                                                     !par
!par!                                                               !par
!par      if(iam.ne.0)go to 5000                                    !par
!par!                                                               !par
!
! APPLY (DIPOLE) TOP-UP (OFF IF BTHRSH)
!
      IF(LRGLAM.GT.0)THEN
!
        WRITE(MW6,10200)LRGLAM
        if(btimex)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Proc',iam,                                !par&
!par     &       'Top-up has been applied: lrglam=',lrglam          !par
!par        else                                                    !par
          write(iw,*)'Top-up has been applied: lrglam=',lrglam
!par        endif                                                   !par
        endif
        IF(BPRNT2)WRITE(MW6,10050)
!
        LITLAM=LRGLAM                             !USE GLOBAL VALUE LA=0
        CO2S=D3QRT/LOG(EINF*DZ2)
!
        NOMT=0
        DO I=1,NMETA                                        !,NSPECL
!          IF(INDEX(I).GT.0)THEN                               !NON-CORR
!
          DO J=I+ione1,NSPECE                                !,NSPECL
!            IF(INDEX(J).GT.0)THEN                             !NON-CORR
!
            NOMT=NOMT+1
            SS=OMGINF(NOMT)
!
            IF(SS.LT.DZERO)THEN                                  !DIPOLE
              SS=SS*CO2S                       !CONVERT TO LINE STRENGTH
              DE=DSPECE(J)-DSPECE(I)
              DE=DE/DZ2
              DO M0=1,MENG0
                EJ=DYY0(M0)/DZ2
                EI=EJ+DE
!
                CALL TOP1(NZA,LITLAM,EI,EJ,SS,OMT)
!
                if(bht)omt=omt/2               !for BHT(1970) comparison
!
                OM=REAL(OMEGA(M0,NOMT),WP)
                OMEGA(M0,NOMT)=OMEGA(M0,NOMT)+REAL(OMT,RP)
!
                IF(BPRNT2)WRITE(MW6,10060)I,J,SS,EI,EJ,DE,OM,OMT,OM+OMT
              ENDDO
            ENDIF
!
!              IF(NOMT.EQ.NOMWRT)GO TO 113                  !WE ARE DONE
!            ENDIF
          ENDDO
!
!          ENDIF
        ENDDO
!
      ELSE
!
        WRITE(MW6,10210)
        if(btimex)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Proc',iam,'Top-up has *NOT* been applied!'!par
!par        else                                                    !par
          write(iw,*)'Top-up has *NOT* been applied!'
!par        endif                                                   !par
        endif
!
      ENDIF
!
! 113  CONTINUE
!
! fix top-up failure on high-e near-degenerate Born allowed transitions
!
      if(btop)then
        NOMT=0
        DO I=1,NMETA
          DO J=I+ione1,NSPECE
            NOMT=NOMT+1
            OMB=OMGINF(NOMT)
            IF(OMB.GT.DZERO)THEN                                   !born
              DE=DSPECE(J)-DSPECE(I)
              DE=MAX(DE,D1M30)
              OM=REAL(OMEGA(2,NOMT),WP)
              DO M0=3,MENG0                        !skip threshold point
                RAT=DYY0(M0)/DE
                OM1=OM
                OM=REAL(OMEGA(M0,NOMT),WP)
                IF(RAT.GT.XBTEST.AND.OM.LT.D0PT8*OM1.AND.OM1.LT.OMB)THEN
                  MM=M0-1              !max(2,m0-1) if no threshold skip
                  GO TO 195
                ENDIF
              ENDDO
              M0=MENG0
              MM=M0+1
              IF(OM1.GE.OMB)THEN
                IF(OM.LT.OMB)MM=MENG0
              ELSE
                IF(OM.LT.OM1)MM=MENG0
              ENDIF
  195         IF(BPRNT2.AND.MM.LE.MENG0)THEN
                WRITE(MW6,10100)I,J,DYY0(M0),DE,RAT,                    &
     &                          (OMEGA(M,NOMT),M=1,MENG0),OMB
              ENDIF
              DO M0=MM,MENG0
                OMEGA(M0,NOMT)=REAL(OMB,RP)
              ENDDO
            ENDIF
          ENDDO
        ENDDO
      endif
!
! test convert to cross section
!
      if(bcrossx)then
        nomt=0
        do i=1,nmeta
          j=index(i)
          jj=nfq(j)
          wi=(qsi(jj)+1)*(qli(jj)+1)
          do j=i+ione1,nspece
            nomt=nomt+1
            de=dspece(j)-dspece(i)
            do m0=1,moggy
              ej=dyy0(m0)
              ei=ej+de
              if(brel)ei=ei+dalf4*ei*ei          !wavenumber
              om=real(omega(m0,nomt),wp)
              om=xconv*om/(ei*wi)
              omega(m0,nomt)=real(om,rp)
            enddo
          enddo
        enddo
      endif
!
!-----------------------------------------------------------------------
!
! WRITE TOTALS
!
      IF(BTHRSH)THEN
        WRITE(MW6,10190)
        IF(BPRNT0)THEN
          WRITE(MW6,10300)((I,J,J=I+ione1,NSPECE),I=1,NMETA)    !ROWWISE
          DO M0=1,MOGGY
            WRITE(MW6,10010)REAL(M0-1+LVMIN),(OMEGA(M0,N),N=1,NOMWRT)
          ENDDO
        ENDIF
      ELSE
        WRITE(MW6,10180)
        IF(BPRNT0)THEN
          WRITE(MW6,10290)((I,J,J=I+ione1,NSPECE),I=1,NMETA)    !ROWWISE
          DO M0=1,MENG0                                         !=MOGGY
            WRITE(MW6,10010)DYY0(M0),(OMEGA(M0,N),N=1,NOMWRT)
          ENDDO
        ENDIF
      ENDIF
!
      IF(IUNIT(MRW23).GT.0)THEN
        CLOSE(MRW23,STATUS='DELETE')
        IF(BTHRSH.or..not.bomega)THEN
          IUNIT(MRW23)=-1
        ELSE
          OPEN(MRW23,FILE='OMEGALS',STATUS='REPLACE')      !USE NEW NAME
!TBD     OPEN(MRW23,FILE='OMEGAULS',STATUS='REPLACE',FORM='UNFORMATTED')
          WRITE(MRW23,*)NZION,MION
          WRITE(MRW23,*)NSPECE,-(MENG0+1),NOMWRT      !FLAG NO E'S .LT.0
          WRITE(MRW23,*)(IWRK3(I),IWRK4(I),I=1,NSPECE)
          WRITE(MRW23,10040)(DWRK(I),I=1,NSPECE)
          DO M0=1,MENG0                                          !=MOGGY
            WRITE(MRW23,F713)DYY0(M0)/DZ2,(OMEGA(M0,N),N=1,NOMWRT)
          ENDDO
          WRITE(MRW23,F713)EINF,(OMGINF(N),N=1,NOMWRT)
          IUNIT(MRW23)=-1
          CLOSE(MRW23)
        ENDIF
      ENDIF
!
! OVERWRITE PWB ADF04 WITH DW, TAKING ACCOUNT OF THE FACT THAT THE PWB
! DOES NOT CONTAIN (SPIN) FORBIDDEN TRANSITIONS
!
      IF(IUNIT(MRW25).GE.0)THEN         !NO ADF04, LIKELY SINCE RAD='NO'
        WRITE(MW6,*)'NO ADF04 FILE="adf04ls"...'
        WRITE(MW0,*)'NO ADF04 FILE ON UNIT=MRW25'
!        NF=-1
        GO TO 400
      ELSEIF(IUNIT(MRW25).LT.0)THEN
        IUNIT(MRW25)=1
        OPEN(MRW25,FILE='adf04ls',STATUS='OLD',ERR=400)
      ENDIF
!
      BEXP=.FALSE.                              !*MUST* SYNC WITH DIAGON
      IF(NSPECE.LT.1000)THEN
        i1=0
        IF(MOGGY.LE.20)THEN
          IF(BEXP)THEN
            F761='(F5.2, I5, 8X,20(1PE10.2))'
            F762='(2I4,22(1PE10.2))'
            F767='(18X,21(F10.5))'
          ELSE
            F761='(A5,A3,I2, 6X, 20(A5, A3))'
            F762='(2I4, 22(A5, A3))'
            F767='(16X,21(F8.5))'
          ENDIF
        ELSE
          IF(BEXP)THEN
            F761='(F5.2, I5, 8X,20(1PE10.2)/(18X,20(1PE10.2)))'
            F762='(2I4,21(1PE10.2)/(18X,20(1PE10.2)))'
          ELSE
            F761='(A5,A3,I2, 6X, 20(A5, A3)/(16X, 20(A5, A3)))'
            F762='(2I4, 21(A5, A3)/(16X, 20(A5, A3)))'  !WRAP LAST POINT
          ENDIF
        ENDIF
      ELSE
        i1=1
        IF(MOGGY.LE.20)THEN
          IF(BEXP)THEN
            F761='(F5.2, I5,10X,20(1PE10.2))'
            F762='(2I5,22(1PE10.2))'
            F767='(20X,21(F10.5))'
          ELSE
            F761='(A5,A3,I2, 8X, 20(A5, A3))'
            F762='(2I5, 22(A5, A3))'
            F767='(18X,21(F8.5))'
          ENDIF
        ELSE
          IF(BEXP)THEN
            F761='(F5.2, I5,10X,20(1PE10.2)/(20X,20(1PE10.2)))'
            F762='(2I5,21(1PE10.2)/(20X,20(1PE10.2)))'
          ELSE
            F761='(A5,A3,I2, 8X, 20(A5, A3)/(18X, 20(A5, A3)))'
            F762='(2I5, 21(A5, A3)/(18X, 20(A5, A3)))'  !WRAP LAST POINT
          ENDIF
        ENDIF
      ENDIF
!
      MSC0=80
      OPEN(MSC0,STATUS='SCRATCH',FORM='FORMATTED')
      IF(.NOT.BEXP)THEN
        MSCP=81
        OPEN(MSCP,STATUS='SCRATCH',FORM='FORMATTED')
      ENDIF
!
      DO N=1,NSPECE+2
        READ(MRW25,10090)CARD
        WRITE(MSC0,10090)CARD
      ENDDO
!
      NNN=max(NOMWRT,nomwr0)
!
      DO N=1,NNN+2
        READ(MRW25,10090,END=200)CARD
        WRITE(MSC0,10090)CARD
      ENDDO
!
  200 REWIND(MRW25)
      REWIND(MSC0)
!
      DO N=1,NSPECE+2
        READ(MSC0,10090)CARD
        WRITE(MRW25,10090)CARD
      ENDDO
!
      IF(BTHRSH)THEN
        ITYPE=6
        WRITE(MRW25,F767)(PSHFT0(M-1+LVMIN),M=1,MOGGY)
        IF(BEXP)THEN
          WRITE(MRW25,F761)REAL(NZA+1),ITYPE,(REAL(M-1+LVMIN),M=1,MOGGY)
        ELSE
          WRITE(MSCP,10120)(REAL(M-1+LVMIN),M=1,MOGGY)
        ENDIF
      ELSE
        ITYPE=5
        IF(BEXP)THEN
          WRITE(MRW25,F761)REAL(NZA+1),ITYPE,(DYY0(M),M=1,MENG0) !=MOGGY
        ELSE
          WRITE(MSCP,10120)(DYY0(M),M=1,MENG0)                   !=MOGGY
        ENDIF
      ENDIF
!
      IF(BEXP)THEN
        READ(MSC0,F761)
      ELSE
        BACKSPACE(MSCP)
        READ(MSCP,10130)(XMANT(M),IEXP(M),M=1,MOGGY)
        iexp(0)='   '
        READ(MSC0,F761)XMANT(0)                                !,IEXP(0)
        WRITE(MRW25,F761)XMANT(0),IEXP(0),ITYPE,                        &
     &                   (XMANT(M),IEXP(M),M=1,MOGGY)
      ENDIF
!
      MENG1=MOGGY+1
      IB0=1
      JB0=IB0+IONE1
!
      nt=0
!
      DO N=1,NNN+1
!
        IF(BEXP)THEN
          READ(MSC0,F762)JB,IB,XB0,(DUM,I=1,MXNXB),XB1
        ELSE
          READ(MSC0,F762)JB,IB,XMANT0,IEXP0,(XMANT(I),IEXP(I),I=1,MXNXB)&
     &                   ,XMANT1,IEXP1
        ENDIF
!
        JB1=JB
        IF(JB.LT.0)THEN
          JB1=NSPECE
          IB=MIN(JB1-IONE1,NMETA)
          IF(BEXP)THEN
            XB0=D1M30
            XB1=DZERO
          ELSE
            XMANT0=' 1.00'
            IEXP0='-30'
            XMANT1=' 0.00'
            IEXP1='+00'
          ENDIF
        ENDIF
!
        IF(BEXP)THEN
          X0=D1M30
          X1=DZERO
        ELSE
          XMANT(0)=' 1.00'
          IEXP(0)='-30'
          XMANT(MENG1)=' 0.00'
          IEXP(MENG1)='+00'
        ENDIF
!
        DO JT=JB0,JB1
          IF(JT.EQ.JB1)THEN
            IB1=IB
          ELSE
            IB1=MIN(JT-IONE1,NMETA)
          ENDIF
          DO IT=IB0,IB1
!
!test        if(ione1.eq.0.or.it.ne.jt)then   !catch ione1=0 diagon only
            nt=nt+1
!
            NOMT=IROW(IT,JT,IONE1,NSPECE)
!                                            !TEST MENG0 STILL IF BTHRSH
            IF(OMEGA(MENG0,NOMT).GT.E1M30)THEN         !SKIP SA-SAP.GT.1
!
!              if(omginf(nomt).lt.dzero)then  !test write reduced dipole
!                do m=1,moggy
!                  de=log(dyy0(m)+2.7183)
!                  omega(m,nomt)=omega(m,nomt)/de
!                enddo
!              endif
!
              IF(BEXP)THEN
                IF(JT.EQ.JB1.AND.IT.EQ.IB1)THEN             !NOW ALLOWED
                  X0=XB0
                  X1=XB1
                ENDIF
                WRITE(MRW25,F762)JT,IT,X0,(OMEGA(M,NOMT),M=1,MOGGY),X1
              ELSE
                BACKSPACE(MSCP)
                WRITE(MSCP,10120)(OMEGA(M,NOMT),M=1,MOGGY)
                BACKSPACE(MSCP)
                READ(MSCP,10130)(XMANT(M),IEXP(M),M=1,MOGGY)
                IF(JT.EQ.JB1.AND.IT.EQ.IB1)THEN             !NOW ALLOWED
                  XMANT(0)=XMANT0
                  IEXP(0)=IEXP0
                  XMANT(MENG1)=XMANT1
                  IEXP(MENG1)=IEXP1
                ENDIF
                WRITE(MRW25,F762)JT,IT,(XMANT(M),IEXP(M),M=0,MENG1)
              ENDIF
!
            ENDIF
!test        endif
          ENDDO
          IB0=1
        ENDDO
!
        IF(JB.LT.0)then
          if(nt.ne.nomwrt)then                                 !checksum
            write(mw6,*)'adf04 no. of transitions mis-match: nt,nomwrt='&
     &                  ,nt,nomwrt
            write(mw0,*)'adf04 no. of transitions mis-match'
            nf=-1
            go to 400
          endif
          GO TO 300
        endif
!
        JB0=JB
        IB0=IB+1
!
      ENDDO
!
      WRITE(MW0,*)'SR.DWXLS: HAVE NOT REACHED END OF adf04ls...'
      WRITE(MW6,*)'SR.DWXLS: HAVE NOT REACHED END OF adf04ls...'
      NF=-1
      GO TO 400
!
  300 WRITE(MRW25,F762)-1
      WRITE(MRW25,F762)-1,-1
!
      if(.not.badas)then                             !adas skip comments
        WRITE(MRW25,10070)
!
        NREC=1
  350   NREC=NREC+1
        BACKSPACE(MR5)
        BACKSPACE(MR5)
        READ(MR5,10140)CARD4
        IF(CARD4.NE.'A.S.'.AND.CARD4.NE.'S.S.')GO TO 350
        REWIND(MR5)
!
        DO N=1,NREC
          READ(MR5,10090)CARD
          WRITE(MRW25,10080)CARD
        ENDDO
        DATE='        '
        CALL DATE_AND_TIME(DATE)
        WRITE(MRW25,10110)DATE(7:7),DATE(8:8),DATE(5:5),DATE(6:6),      &
     &                    DATE(3:3),DATE(4:4)
      endif
!
      IUNIT(MRW25)=-1
      CLOSE(MRW25)
!
      CLOSE(MSC0)
      IF(.NOT.BEXP)CLOSE(MSCP)
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par 5000 continue                                                  !par
!
  400 CONTINUE
!
      DEALLOCATE(KACT,KTMP,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXLS: DE-ALLOCATION FAILS FOR KACT,KTMP'
        NF=0
        GO TO 800
      ENDIF
!
      DEALLOCATE(PSHFT0)                                          !SMALL
!
  500 CONTINUE
!
      DEALLOCATE(RHO1,RHO2,TEMP,OMGINF,OMEGA,STAT=IERR)
!par!                                                               !par
!par      deallocate(omsend,omrecv,stat=ierr)                       !par
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXLS: DE-ALLOCATION FAILS FOR RHO,OMEGA,TEMP'
        NF=0
        GO TO 800
      ENDIF
!
  600 DEALLOCATE(TFU,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXLS: DE-ALLOCATION FAILS FOR TFU'
        NF=0
        GO TO 800
      ENDIF
!
  700 CONTINUE
!
      DEALLOCATE(NADRUG)
      DEALLOCATE(TMP,OMP)
      DEALLOCATE(IEXP,XMANT)
      IF(ALLOCATED(DWRK))DEALLOCATE(DWRK,IWRK3,IWRK4)
!
      deallocate(bswap)
!par!                                                               !par
!par 5500 continue                                                  !par
!
  800 CONTINUE
!
!-----------------------------------------------------------------------
!
      if(btimep)then
        call nrb_time(timef)
        times=timef-time0
!
!        if(abs(modd).le.1)then
!
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Ending proc',iam,' for dwxls:'            !par&
!par     &               ,' time=',nint(times),'sec,     '          !par&
!par     &               ,nint(times/60),'min'                      !par
!par          call flush(iw)                                        !par
!par        else                                                    !par
        write(iw,*)'Ending dwxls: time=',nint(times),'sec,     ',       &
     &             nint(times/60),'min'
!par        endif                                                   !par
!        endif
      endif
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(F21.3,2X,1P,10(E11.3)/(23X,10(E11.3)))
10020 FORMAT(2I5,3X,2I4,2X,1P,10(E11.3)/(23X,10(E11.3)))
10030 FORMAT(2I5,3X,2I4,2X,1PE11.3,10X,'E(',I2,')   ',A11)
10040 FORMAT(1P,5E16.6)
!10050 FORMAT(1PE14.8,6E11.3/(14X,6E11.3))
10050 FORMAT(3X,'CH',2X,'CHP',9X,'S',14X,'EI',10X,'EJ',10X,'DE',9X,     &
     &       'OMEGA(PAR)',2X,'OMEGA(TOP)',4X,'OMEGA(TOT)')
10060 FORMAT(2I5,3X,1PE11.3,2X,0P,3F12.4,5X,2F12.4,2X,F12.4)
10070 FORMAT('C',79('-')/'C'/'C')
10080 FORMAT('C ',A200)
10090 FORMAT(A200)
10100 FORMAT(2I5,22(1PE10.2))
10110 FORMAT('C'/'C'/'C',79('-')/'C'/'C',1X,                            &
     &       'AUTOSTRUCTURE DISTORTED-WAVE'/'C'/'C NAME:'/'C DATE: ',   &
     &       2(A1),'/',2(A1),'/',2(A1)/'C'/'C',79('-'))
10120 FORMAT(22(1PE9.2))
10130 FORMAT(22(A5,1X,A3))
10140 FORMAT(A4)
10150 FORMAT(2I10,13X,I5,I2,I5,12X,F18.6)
10160 FORMAT(9X,'I',8X,' T',14X,'2S+1 L   CF',20X,'(EI-E1)/RY',15X,     &
     &       'NMETA=',I5)
10170 FORMAT(//' *** FULLY UNITARIZED K- TO T-MATRIX CONVERSION ***'//)
10180 FORMAT(///1X,136('-')//51X,                                       &
     &       '*** TOTAL COLLISION STRENGTHS (LS) ***'//1X,136('-')//)
10190 FORMAT(///1X,136('-')//45X,                                       &
     &       '*** THRESHOLD PARTIAL COLLISION STRENGTHS (LS) ***'//1X,  &
     &       136('-')//)
10200 FORMAT(//' *** TOP-UP HAS BEEN APPLIED: LRGLAM=',I5//)
10210 FORMAT(//' *** TOP-UP HAS *NOT* BEEN APPLIED ***'//)
10220 FORMAT(//1X,136('-')///49X,'*** TARGET ENERGIES (LS) ***'/)
10230 FORMAT(//1X,136('-')/)
10240 FORMAT(13X,'CH',8X,'T',3X,'SMALL L')
10250 FORMAT(7X,I8,I9,I10)
10260 FORMAT(' SY=',I3,5X,'(2S+1) L P =',I3,I4,I3,5X,'NCHT=',I6,2X,'(', &
     &       I6,')')
10270 FORMAT(//' SY=',I3,5X,'(2S+1) L P =',I3,I4,I3/1X,33('-'))
10280 FORMAT(/3X,'CH',2X,'CHP',6X,'I',2X,'IP',4X,'OMEGA(IE=1,MENG):')
10290 FORMAT(74X,'OMEGA(I-IP)'/74X,11('-')/2X,'*FINAL* ENERGY(RYD)',2X, &
     &       10(2X,I4,'-',I4)/(23X,10(2X,I4,'-',I4)))
10300 FORMAT(74X,'OMEGA(I-IP)'/74X,11('-')/1X,'*FINAL* RYDBERG A.M.',2X,&
     &       10(2X,I4,'-',I4)/(23X,10(2X,I4,'-',I4)))
10310 FORMAT(//' SY=',I3,5X,'(2S+1) L P =',I3,I4,I3,5X,'NCHT=',I6,2X,   &
     &       '(',I6,')'/1X,33('-'))
10320 FORMAT(//' *** UPDATING SLATER INTEGRALS FOR LTOT=',I3/1X,42('-') &
     &       /)
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION IROW(ILI,ILF,IONE1,NENG)
!
      INTEGER(SP) ILI,ILF,IONE1,NENG,IROW
!
      IROW=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE1))/2
!
      END FUNCTION IROW
!-----------------------------------------------------------------------
!
      END SUBROUTINE DWXLS_DAXPY
!
!                             *******************
!
      SUBROUTINE DWXLS_DDOT                                             &
     &                (FRX,PSHFTX,DRLX,MDIM0,MDIM1,MDIM2,MDIM3,MDIM4    &
     &                ,MDIM5,DZLX,DXTWOX,DETAX,MDIM6,MDIM7,MDIM8)
!
!-----------------------------------------------------------------------
!
!  SR.DWXLS_DDOT
!    CALCULATES EIE 2-BODY NFS COLLISION STRENGTHS IN LS-COUPLING
!
!  IT IS CALLED BY:
!    SR.DWXLS
!
!  IT CALLS:
!    SR.DATE_AND_TIME (SYSTEM)
!    SR.NRB_TIME
!    SR.PQ
!    SR.PQLAP
!    FN.QPTLS
!    SR.RADCNX
!    SR.SLATRX
!    SR.TOP1
!    SR.TOP2
!    FN.XINT
!
!  IT CONTAINS:
!    FN.IROW
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam,comm_barrier               !par&
!par     &                          ,sp_mpi,izero_mpi               !par
!par      use mpi, only : mpi_real4,mpi_real8,mpi_integer           !par&
!par     &               ,mpi_sum,mpi_comm_world                    !par
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL,NAD
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_MINIM,  ONLY: BECOR
      USE COMMON_MINIM,  ONLY: XMIX
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_QTG,    ONLY: NFI,NFK,NFQ
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      use common_misc,   only: ione1,ione0
      use common_misc,   only: iw,iwp,btime,btimex
      use common_misc,   only: badas
!
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,INAST0=>NASTB                            &
     &                        ,INASTJ0=>NASTJB,LFACT,JFACT              &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDW1, ONLY: MXORB,ma0,mb0
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
      USE COMMON_NRBDW4, ONLY: DSPECE,INDEX,JNDEX,NSPECE,NENERG
      USE COMMON_NRBDW5, ONLY: DYY,MENG,NLAG
      USE COMMON_NRBDW6, ONLY: QPOS,QPOS0
      USE COMMON_NRBDW7, ONLY: MNDEX,MRNDX,MTRAN,mlim
      USE COMMON_NRBDW8, ONLY: DYY0,IYY0,MENG0
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBDWX, ONLY: LLCH,ITARG,NCHG
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBIAD, ONLY: IADD
      USE COMMON_NRBKUT, ONLY: KCUTX,LSKUT,NASTK
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
      USE COMMON_NRBREL, ONLY: BREL
      USE COMMON_NRBRN3, ONLY: MXNXB,MXNXB1
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (MXLEN=200)                                 !CARD LENGTH
!
      PARAMETER (MXD13=500)
!
      INTEGER(SP) QPTLS                        !DO NOT USE SHORT INTEGER
!
      INTEGER(SP) SA,SAP
!par!                                                               !par
!par      integer(sp_mpi) itmp4,ier4,my_mpi_real                    !par
!par!                                                               !par
!par      real(rp) omsend,omrecv                                    !par
!
      REAL(RP) OMEGA,E1M30
!
      PARAMETER (E1M30=1.E-30_RP)
      PARAMETER (XBTEST=DFIVE)          !APPLY btop ONLY FOR X.GT.XBTEST
!
      CHARACTER(LEN=3) IEXP,IEXP0,IEXP1
      CHARACTER(LEN=4) CARD4
      CHARACTER(LEN=5) XMANT,XMANT0,XMANT1
      CHARACTER(LEN=8) DATE
      CHARACTER(LEN=15) F767
      CHARACTER(LEN=29) F713
      CHARACTER(LEN=35) F762
      CHARACTER(LEN=44) F761
      CHARACTER(LEN=MXLEN) CARD
!
      ALLOCATABLE :: RHO1(:,:),RHO2(:,:),OMEGA(:,:),TFU(:)              &
     &              ,TEMP(:,:),OMGINF(:),KACT(:,:),KTMP(:)
!par      allocatable :: omsend(:),omrecv(:)                        !par
!
      allocatable :: rhom(:,:),wrkp(:),wrkq(:),iwrkn(:),iwrkl(:)        &
     &              ,work(:)
!
      allocatable :: bswap(:)
!
      ALLOCATABLE :: IEXP(:),XMANT(:)
      ALLOCATABLE :: NADRUG(:),TMP(:,:),OMP(:)                          &
     &              ,DWRK(:),IWRK3(:),IWRK4(:)
!
      ALLOCATABLE :: PSHFT0(:)
!
      DIMENSION FRX(MDIM1,MDIM2,MDIM3),PSHFTX(MDIM2,MDIM3)              &
     &         ,DRLX(MDIM4,MDIM0,0:MDIM5)                               &
     &         ,DZLX(MDIM7,MDIM6,0:MDIM8)                               &
     &         ,DXTWOX(MDIM7,MDIM6,0:MDIM8)                             &
     &         ,DETAX(MDIM7,MDIM6,0:MDIM8)
!
      dimension ntest(1,1)                     !check channel set-up
!
!-----------------------------------------------------------------------
!
!      IROW(ILI,ILF,IONE1,NENG)=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE1))/2
!
!-----------------------------------------------------------------------
!
! flag write of cross sections to adf04ls instead of collision strengths
! - this is for test purposes only.
!
      bcrossx=.false.                !.true.
!
      if(bcrossx)then
!
        write(mw0,*)' *** Attention, adf04ls contains cross sections!'
        write(mw6,*)' *** Attention, adf04ls contains cross sections!'
!
        xconv=done                   !pi*a_0^2
        xconv=xconv*acos(-done)      !a_0^2
        xconv=xconv*28.003D0         !Mbarns
        xconv=xconv*1.D6             !barns
!
      endif
!
! flag write of "OMEGA" file - this is by final scattered energy and so
! *not* directly usable by R-matrix utility codes such as xtrct/adasexj.
! this is somewhat historic as adasexj *does* read/process dw adf04 file
!
      bomega=.false.
!
! elastic switch (normally ione1=1, no elastic. ione1=0 inc elastic)
! now set by user in algeb, and passed thru /nrbdwm/ as needed.
!
!old  ione1=1
!
! test: DO NOT CHANGE!
!old  ione0=0                   !algxls ione1, elastic needed for mixing
!
! some test set-up switches that user joe should not need to touch.
!
      bht=.false.                  !.true. for bht(1970) test comparison
!
! set (approx) unitarity switch
!
      bunit=.true.
      if(bht)bunit=.false.
!
! set approximation-ii unitarization switch - needs the full rho-matrix
! (.and.. not.bthrsh, i.e. lvmax.lt.0) only coded for F95.
! currently, in principle, only for use at medium to high energies
! since it still works with the final scattered energy, but seems to
! work well down to low-e as well - strongest coupling with nearby
! states, i.e. ones calculated at the same/similar relative energy.
!
      bunit2=nmeta.ge.nspece.and.ione1.eq.0.and.lvmax.lt.0
!
! set print of approx r(tau=0)-matrix as opposed to rho(tau)-matrix
! *MUST* use full T=-2iR/(1-iR) if converting via R-matrix.   (not done)
! can only use weak coupling T=-2i*rho for rho-matrix -see bunit2 above.
!
      brmx=.false.
      if(jprint.eq.4)brmx=.true.
!
! set mixing switch, can test interpolation followed by mixing (false).
!
      bmix=xmix.ge.dzero                !default xmix->.true.
      xmix=abs(xmix)
!
! checks channel set-up (needs ntest dimensioned)
!
      bntest=.false.                    !ione1.eq.0.and.jprint.ge.2
!
      bntest=bntest.and.nmeta.ge.nspece
!
! if bcor then we have algebraic correlation, and we know how ordered
!
      bcor=kmax*kcut.ne.kcut*kcut
!
! if becor then we have correlation by energy, and we know not where, so
!
      beqgrpl0=.not.becor                       !false for full li=lf mx
!
! if only algebraic then can reduce memory requirement  NAD(NCOR)
!
      bcorr=bcor.and..not.becor.and.kcutx.ge.0
!par!                                                               !par
!par      if(rp.eq.4)then                                           !par
!par        my_mpi_real=mpi_real4                                   !par
!par      elseif(rp.eq.8)then                                       !par
!par        my_mpi_real=mpi_real8                                   !par
!par      else                                                      !par
!par        if(iam.eq.0)write(iw,*)'error rp precsion =',rp         !par
!par        go to 5500                                              !par
!par      endif                                                     !par
!
!-----------------------------------------------------------------------
!
      btimep=btimex                                        !for iam.ne.0
      if(btimex)then
!        if(abs(modd).le.1)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Starting proc',iam,' for dwxls'           !par
!par        else                                                    !par
        write(iw,*)'Starting dwxls'
!par        endif                                                   !par
!        endif
        call nrb_time(timei)
        time0=timei
      endif
      btimet=btimex  !.false.                             !debug timings
!
! INITIALIZATIONS
!
      PI=ACOS(-DONE)
      TPI=DTWO*PI
!
      BPRNT1=JPRINT.GE.1                       !PRINT CHANNEL INFO AGAIN
      BPRNT2=JPRINT.GE.2                    !FOR DETAILED OMEGA PRINTOUT
      BPRNT3=JPRINT.GE.3                      !FOR DETAILED RHO PRINTOUT
      BPRNT0=JPRINT.NE.-3
!
      KOLDOO=KUTOOX
      BKUTOO=KUTOOX.NE.0
!
      LAPAK=1                                                    !LAPACK
!
      IF(NZION.EQ.MION)THEN
        NZA=0
        DZ2=DONE
      ELSE
        NZA=NZION-MION
        DZ2=NZA*NZA
      ENDIF
!
      LOLD=-1                                          !INITIAL FOR QPOS
      LSTORE=0                                 !TRIVIAL INTEGRAL STORAGE
!
      IF(MAXLT.GE.0)THEN
        IF(LRGLAM.GT.MAXLT)THEN
          WRITE(MW0,*)'*** SR.DWXLS: LRGLAM.GT.MAXLT, SO NO TOP-UP'
          LRGLAM=-1
        ELSE
          IF(LRGLAM.EQ.-999)LRGLAM=MAXLT
        ENDIF
        IF(LRGLAM.EQ.0)LRGLAM=-1
      ENDIF
!
      IF(LRGLAM.GE.0)THEN        !SET L WHERE DIPOLE TOP-UP NEEDS CHECKS
        LRGLMN=LRGLAM-QCL0
      ELSE
        LRGLMN=1000
      ENDIF
!
      btop=btop.and.lrglam.ge.0
!
! SMALL LOCAL MEMORY
!
      MXD4=MAX(MENG,10_SP)+3
      ALLOCATE(IEXP(0:MXD4),XMANT(0:MXD4))
      ALLOCATE(TMP(MENG,MENG),OMP(MENG))
      ALLOCATE(NADRUG(NSL0))
!
      ixd13=mxd13
      allocate(bswap(ixd13))                                      !small
!
! SET POINTER TO START OF GROUP IN MIXING COEFFICIENT ARRAY TFU
!
      MC=0
      NCMX=0
      DO N0=1,NSL0
        NADRUG(N0)=MC
        NC=NSL(N0)
        NCMX=MAX(NCMX,NC)                        !MAX NO TERMS IN GROUP
        MC=MC+NC*NC
      ENDDO
!
! RECOVER TARGET MIXING COEFFICIENTS
!
      READ(MRW10)NCTOT
!
      if(nctot.ne.mc)stop 'dwxls:nctot index error'    !shouldn't happen
!
      ALLOCATE(TFU(NCTOT),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXLS: ALLOCATION FAILS FOR TFU'
        NF=0
        GO TO 700
      ENDIF
!
      READ(MRW10)(TFU(I),I=1,NCTOT)
!
! LOOK FOR LAST SPECTROSCOPIC ENERGY
!
!      NSPECL=0
!      DO N=1,NENERG
!        NSPECL=MAX(NSPECL,JNDEX(N))
!      ENDDO
!
! USE ROWWISE TO SIMPLY REDUCE NDIM2 IF NMETA.LT.NSPECE
!
      NOMTG=NCMX*NCMX                               !NEED ALL FOR MIXING
      nmin=min(NMETA,NSPECE)
      NOMWRT=IROW(nmin,NSPECE,ione1,NSPECE)                     !ROWWISE
      NOMWR0=NOMWRT
!test    if(ione1.eq.1)nomwr0=nomwr0+nmin      !incase ione1=0 in diagon
!
!
      BTHRSH=LVMAX.GE.0
      IF(BTHRSH)THEN
        MOGGY=LVMAX+1-LVMIN
        ALLOCATE(PSHFT0(LVMIN:LVMAX))                             !SMALL
      ELSE
        MOGGY=MENG0
        ALLOCATE(PSHFT0(LVMIN:LVMIN))                             !SMALL
      ENDIF
!
      MX=MTRAN
      if(.not.bmix)mx=meng0
!
      ALLOCATE(RHO1(NOMTG,MX),RHO2(MTRAN,NOMTG),TEMP(NCMX,MX),          &
     &         OMGINF(NOMWR0),OMEGA(MOGGY,NOMWRT),STAT=IERR)
!par!                                                               !par
!par      allocate(omsend(nomwrt),omrecv(nomwrt),stat=ierr)         !par
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXLS: ALLOCATION FAILS FOR RHO,OMEGA,TEMP'
        NF=0
        GO TO 600
      ENDIF
!
      DO N=1,NOMWRT
        OMGINF(N)=DZERO
        DO M=1,MOGGY
          OMEGA(M,N)=0
        ENDDO
      ENDDO
!
! RECOVER INFINITE ENERGY INFO (ROWWISE)
!
      IF(IUNIT(MRW23).EQ.0)THEN                !ADF04 WILL BE INCOMPLETE
        WRITE(MW6,*)'NO INFINITE ENERGY FILE="OMGINFLS"...'
        WRITE(MW0,*)'NO INFINITE ENERGY FILE ON UNIT=',MRW23
        IF(LRGLAM.GE.0)THEN
          WRITE(MW6,*)'NO INFINITE ENERGY FILE INFO, CANNOT TOP-UP'
          WRITE(MW0,*)'NO INFINITE ENERGY FILE INFO, CANNOT TOP-UP'
          NF=-1
          GO TO 500
        ELSE
          GO TO 100
        ENDIF
      ELSEIF(IUNIT(MRW23).LT.0)THEN
        OPEN(MRW23,FILE='OMGINFLS',STATUS='OLD',ERR=100)
        IUNIT(MRW23)=1
      ELSE                               !SERIAL SHOULD NOT BE HERE
        REWIND(MRW23)                       !BUT PAR ALREADY OPEN
!par        if(iam.eq.0)then                                        !par
        stop 'dwxls: omginfls confusion'
!par        endif                                                   !par
      ENDIF
!
      READ(MRW23,*)NZDUM,MDUM
      READ(MRW23,*)NSPEC0,MENGB,NOMWR0
!
      IF(NSPEC0.NE.NSPECE)THEN                   !SHOULD NOT HAPPEN, NOW
        WRITE(MW6,*)'DWXLS: INFINITE ENERGY TARGET MISMATCH',NSPEC0,    &
     &              NSPECE
        WRITE(MW0,*)'DWXLS: INFINITE ENERGY TARGET MISMATCH'
        NF=-1
        GO TO 500
      ENDIF
!
      ALLOCATE(DWRK(NSPEC0),IWRK3(NSPEC0),IWRK4(NSPEC0))
!
      READ(MRW23,*)(IWRK3(I),IWRK4(I),I=1,NSPEC0)
      READ(MRW23,10040)(DWRK(I),I=1,NSPEC0)
!
! optionally recover spec energy subset from omginf,
! and retain full-set in denerg back in algx.
!
!      do i=1,nspec0
!        dwrk(i)=dwrk(i)*dz2
!      enddo
!
      iflag=0
      if(nomwrt.ne.nomwr0)then       !should not happen in non-test mode
        if(ione1.eq.0)then                             !elastic in dwxls
          if(nomwrt-nmin.ne.nomwr0)then
            write(mw6,*)'dwxls: infinite energy omega mismatch',nomwrt, &
     &                  nomwr0
            write(mw0,*)'dwxls: infinite energy omega mismatch'
            nf=-1
            go to 500
          else                                   !case ione1=1 in diagon
            iflag=1
          endif
        else                                         !inelastic in dwxls
          if(nomwrt+nmin.ne.nomwr0)then
            write(mw6,*)'dwxls: infinite energy omega mismatch',nomwrt, &
     &                  nomwr0
            write(mw0,*)'dwxls: infinite energy omega mismatch'
            nf=-1
            go to 500
          else                                   !case ione1=0 in diagon
            iflag=2
          endif
        endif
      endif
!
      F713='(1PE14.8,6E11.3/(14X,6E11.3))'        !SUPPRESS IFORT REMARK
!
      READ(MRW23,F713)EINF,(OMGINF(I),I=1,NOMWR0)
!par!                                                               !par
!par      if(iam.ne.0)then                                          !par
!par        IUNIT(MRW23)=-1                                         !par
!par        CLOSE(MRW23)                                            !par
!par      endif                                                     !par
!
      if(iflag.eq.1)then                          !make room for elastic
        n=nomwrt+1
        nshft=nmin
        do i=nmin,1,-1
          do j=nspec0,i+1,-1
            n=n-1
            omginf(n)=omginf(n-nshft)
          enddo
          n=n-1
          omginf(n)=done                             !flag poss. allowed
          nshft=nshft-1
        enddo
        if(n.ne.1)stop 'iflag=1 nshft error'
      elseif(iflag.eq.2)then                               !drop elastic
        n=0
        nshft=1
        do i=1,nmin
          do j=i+1,nspec0
            n=n+1
            omginf(n)=omginf(n+nshft)
          enddo
          nshft=nshft+1
        enddo
        if(n.ne.nomwrt)stop 'iflag=2 nshft error'
      endif
!
  100 CONTINUE
!
! WRITE-OUT SPEC. TARGET ENERGIES
!
      WRITE(MW6,10220)
      WRITE(MW6,10160)NMETA
!
      DO J=1,NSPECE
        I=INDEX(J)
        JJ=NFQ(I)
        II=(1-QPI(JJ))*(QSI(JJ)+1)
        WRITE(MW6,10150)J,I,II,QLI(JJ)/2,NFK(I),DSPECE(J)
      ENDDO
!
      WRITE(MW6,10230)
!
! FLAG ACTIVE ORBITAL PAIR IN INTERACTING CONFIGS C.F. SR.ALGX BXIST0
!
      ALLOCATE(KACT(KMAX,KMAX),KTMP(NF),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXLS: ALLOCATION FAILS FOR KACT,KTMP'
        NF=0
        GO TO 500
      ENDIF
!
      DO KF=1,KMAX
        DO KG=1,KF
          KACT(KF,KG)=0
          KACT(KG,KF)=0
          DO I=1,NF
            KTMP(I)=QCG(I,KG)
          ENDDO
          K=0
          DO I=1,NF
            L0=0
            DO L=1,NF
              IF(IEQ(KTMP(L)).EQ.IEQ(QCG(I,KF)))THEN
                KTMP(L)=0
                GO TO 120
              ELSE
                IF(KTMP(L).NE.0.AND.L0.EQ.0)L0=L
              ENDIF
            ENDDO
            K=K+1
            IF(K.GT.1)GO TO 150
            KACT(KF,KG)=QCG(I,KF)
            KACT(KG,KF)=KTMP(L0)
  120     ENDDO
  150   ENDDO
      ENDDO
!
!-----------------------------------------------------------------------
!
! BEGIN LOOP OVER SCATTERING SYMMETRIES
!
!-----------------------------------------------------------------------
!
      NCOR=0
!
      if(bunit2)write(mw6,10170)
      iwait=0
      wait=done
!
      DO IX=1,INAST
!
        IS=LSPI(IX)/10000
        IP=LSPI(IX)-IS*10000
        IL=IP/10
        IP=IP-IL*10
!
        LNEW=IL
!
        IF(BKUTOO.AND.LNEW.GT.MAXLOO)THEN
          KUTOOX=0
          BKUTOO=.FALSE.
        ENDIF
!
! SEE IF WE NEED TO UPDATE INTEGRALS & CONTINUUM BASIS
!
        IF(LNEW.NE.LOLD)THEN
!
!-----------------------------------------------------------------------
!
          if(btimex)then
!!        if(abs(modd).gt.1)then   ADD IC FLAG
!par            if(iam.ge.0)then                                    !par
!par              write(iwp,*)'Starting proc',iam                   !par&
!par     &                  ,'updating continuum for l=',il         !par
!par              call flush(iwp)                                   !par
!par            else                                                !par
            write(iw,*)                                                 &
     &              'Begin update of continuum basis & integrals for L='&
     &              ,lnew
!par            endif                                               !par
!!        endif
!
            call nrb_time(timei)
            times=timei
          endif
!
!-----------------------------------------------------------------------
!
          lstep=lnew-lold
          if(lstep.gt.1.and.lfact.gt.100.and.lold.gt.0)then
            if(iwait.eq.4)then
              iwait=2
            else
              iwait=4
            endif
            wait=iwait*lstep
            wait=wait/dthree
          endif
!
! UPDATE CONTINUUM BASIS
!
          IF(BTHRSH)LCONDW=-LCONDW                            !FLAG
!
          CALL RADCNX(FRX,PSHFTX,PSHFT0,MDIM1,MDIM2,MDIM3,LNEW,LOLD,    &
     &                LCONDW,MXORB)
!
          IF(NF.LE.0)GO TO 400
!
! UPDATE EXCHANGE MULTIPOLE
!
          LDIFF=LNEW
          IF(LOLD.GE.0)LDIFF=LDIFF-LOLD
          LDIFF=LDIFF+LDIFF
!
          DO I=1,IRL
            IF(QRL(2,I).GT.MXORB)QRL(5,I)=QRL(5,I)+INT(LDIFF,QP) !EXCHNG
          ENDDO
!
! UPDATE SLATER INTEGRALS (INC. 2NFS IF BKUTOO=.TRUE.)
!
          IF(BPRNT0)WRITE(MW6,10320)LNEW
!
          DO M=1,MTRAN
            M1=MNDEX(M,1)
            M2=MNDEX(M,2)
            IF(BKUTOO)THEN
              CALL SLATRX(FRX,PSHFTX,MDIM1,MDIM2,MDIM3,DRLX(1,M,LSTORE),&
     &                    DZLX(1,M,LSTORE),DXTWOX(1,M,LSTORE),          &
     &                    DETAX(1,M,LSTORE),M1,M2,LNEW,MXORB)
            ELSE
              CALL SLATRX(FRX,PSHFTX,MDIM1,MDIM2,MDIM3,DRLX(1,M,LSTORE),&
     &                    DZLX(1,1,0),DXTWOX(1,1,0),DETAX(1,1,0),M1,M2, &
     &                    LNEW,MXORB)
            ENDIF
          ENDDO
!
          LOLD=LNEW
!
!-----------------------------------------------------------------------
!
          if(btimex)then
            call nrb_time(timef)
            times=timef-times
!
!!        if(abs(modd).gt.1)then
!par            if(iam.ge.0)then                                    !par
!par              write(iwp,*)'Ending proc',iam                     !par&
!par     &                  ,'updating continuum'                   !par&
!par     &                 ,' time=',nint(times),'sec'              !par
!par              call flush(iwp)                                   !par
!par            else                                                !par
            write(iw,*)'End update of continuum basis & integrals',     &
     &                 ', time=',nint(times),'sec'
!par            endif                                               !par
!!        endif
          endif
!
!-----------------------------------------------------------------------
!
        ENDIF
!
!
! INITIALIZE FOR LS-LOOP
!
        nwt=is
        if(il.gt.maxlx)nwt=-2*is+2
!
        IF(BPRNT1)WRITE(MW6,10270)IX,nwt,IL,IP
!
! count channels
!
        if(bprnt1)write(mw6,10240)
!
        nchlt=0
        nchs=0
!
        do n=1,nchg(ix)
          nc=itarg(n,ix)
          mc=nsl(nc)
          mci=ngrpi(nc)
          l1=llch(1,n,ix)
          l2=llch(2,n,ix)
          do l=l1,l2,4
            do m=1,mc
              j1=m+mci
              nchlt=nchlt+1
              if(jndex(j1).gt.0)then
                if(bprnt1)write(mw6,10250)nchlt,j1,l/2
                nchs=nchs+1
              endif
            enddo
          enddo
        enddo
!
        if(bntest)then
          do i=1,nchlt
            do j=1,nchlt
              ntest(j,i)=0
            enddo
          enddo
        endif
!
! initialize for approximation-ii (memory hog)
!
        if(bunit2)then
!
          nx=(nchlt*(nchlt+1))/2
!
          ALLOCATE(rhom(nx,meng0),wrkp(nx),wrkq(nx),iwrkn(nchlt),       &
     &             iwrkl(nchlt),work(nchlt),stat=ierr)
!
          if(ierr.ne.0)then
            write(mw0,*)'dwxls: allocation fails for rhom,wrk'
            nf=0
            go to 400
          endif
!
          do i=1,nchlt
            iwrkn(i)=-1
            iwrkl(i)=-1
          enddo
!
          do m=1,meng0
            n=0
            do i=1,nchlt
              n=n+1
              rhom(n,m)=done
              do j=i+1,nchlt
                n=n+1
                rhom(n,m)=dzero
              enddo
            enddo
          enddo
!
        endif
!
        IF(.NOT.BPRNT0)then
          WRITE(MW6,10260)IX,nwt,IL,IP,nchs,nchlt
        ELSEIF(.not.BPRNT1)then
          WRITE(MW6,10310)IX,nwt,IL,IP,nchs,nchlt
        ENDIF
        IF(BPRNT2)WRITE(MW6,10280)
!
!-----------------------------------------------------------------------
!
        if(btimex)then
!!        if(abs(modd).gt.1)then
!par          if(iam.ge.0)then                                      !par
!par            write(iwp,*)'Starting proc',iam                     !par&
!par     &                ,'dwxls symmetry',ix,':',nwt,il,ip        !par
!par            call flush(iwp)                                     !par
!par          else                                                  !par
          write(iw,*)'Starting dwxls symmetry',ix,':',nwt,il,ip
!par          endif                                                 !par
!!        endif
!
          call nrb_time(timei)
          times=timei
        endif
!
        if(btimet)then
          timeset=dzero
          timemix=dzero
          timemixi=dzero
          timemixf=dzero
          timemixir=dzero
          timemixfr=dzero
          timeunit=dzero
          timeint=dzero
        endif
!
!-----------------------------------------------------------------------
!
        nwt=abs(nwt)*(2*il+1)
!
        NCN=NCHG(IX)
!
        NCHI=0
        NCHI0=0
!
        DO NC0=1,NCN                     !BEGIN LOOP OVER INITIAL GROUPS
          L1=LLCH(1,NC0,IX)
          L2=LLCH(2,NC0,IX)
          NC=ITARG(NC0,IX)
          MC=NSL(NC)
          SA=QSI(NC)
          LA=QLI(NC)
          MCI=NGRPI(NC)
!
          NCHIP=0
          NCHIP0=0
!
          DO ND0=1,NC0                     !BEGIN LOOP OVER FINAL GROUPS
            L1P=LLCH(1,ND0,IX)
            L2P=LLCH(2,ND0,IX)
            ND=ITARG(ND0,IX)
            MCP=NSL(ND)
            SAP=QSI(ND)
!            IF(ABS(SA-SAP).GT.2)GO TO 68   !unnecessary...
            IF(NMETAG(NC)+NMETAG(ND).EQ.2)THEN
              NCHI=NCHI0+((L2-L1)/4+1)*MC
              NCHIP=NCHIP0+((L2P-L1P)/4+1)*MCP
              GO TO 180
            ENDIF
            LAP=QLI(ND)
            MCIP=NGRPI(ND)
!
            beqgrp=nc.eq.nd          !flag equal groups for filling rho1
!
! get lambda for non-dipole infnite energy top-up
!
            if(lnew.ge.lrglam)then
              if(sa.eq.sap)then
                litlam=0
                if(qpi(nc).ne.qpi(nd))then
                  litlam=3                         !for case of octupole
                else
                  if(la.eq.lap)then
                    if(la+lap.ge.4)litlam=2
                  else
                    litlam=abs(la-lap)/2
                  endif
                endif
              else
                litlam=-1
              endif
            else
              litlam=0
            endif
!
            NCHI=NCHI0
            DO LI=L1,L2,4                   !LOOP OVER INITIAL CHANNEL L
!
! set position of phase shift for this li
! only required by  elastic case for diagonal rho
! or if printing usual reactance matrix
!
              if(ione1.eq.0.or.brmx)then
                L=LCONDW/2+1-LNEW+LI/2
                L0=ABS(QPOS(L))
              endif
!
              lf2=l2p
              if(beqgrp)lf2=li
!
              NCHIP=NCHIP0
              DO LF=L1P,lf2,4                 !LOOP OVER FINAL CHANNEL L
!
                beqgrpl=beqgrpl0.and.beqgrp.and.li.eq.lf
!
                ncort=qptls(ix,nc0,nd0,li,lf)
!
                if(ncort.ne.ncor)then
                  write(mw0,*)ix,nc0,nd0,li,lf,ncor,ncort
                  stop 'ncor mis-match'
                endif
!
! set position of phase shift for this lf
! only need if printing usual reactance matrix, not needed by rho matrix
!
                if(brmx)then
                  L=LCONDW/2+1-LNEW+LF/2
                  L00=ABS(QPOS(L))
                endif
!
!-----------------------------------------------------------------------
!
! NOW FORM LS INTERACTION (BY TARGET SYMMETRY GROUP)
!*************************
!
! THIS IS IN THE RHO-I REPRESENTATION, WHERE
! |T^R(V,V')|=|T^RHO(V,V')| FOR CHANNELS V.NE.V'.
! WE USE T^RHO(V,V')=-2I*RHO(V,V'), WITH A 2X2 UNITARITY CONDITION.
! FOR V.EQ.V' T^R(V,V)~-2*TAN(TAU(V)), FOR RHO(V,V) SMALL.
! (IN GENERAL, WE ARE NOT INTERESTED IN ELASTIC TRANSITIONS.)
!
!
                if(btimet)call nrb_time(timei)
!
                NOMTG=MC*MCP
                DO N=1,NOMTG
                  DO M=1,MTRAN
                    RHO2(M,N)=DZERO
                  ENDDO
                ENDDO
!
                DO MD1=1,MC               !BEGIN LOOP OVER INITIAL TERMS
                  J1=MD1+MCI
                  j=jndex(j1)
                  if(kcutx.lt.0)j=abs(j)                !keep corr-corr
                  KF=NFK(J1)
!
                  DO MDP1=1,MCP             !BEGIN LOOP OVER FINAL TERMS
                    J1P=MDP1+MCIP
                    IF(beqgrpl.and.J1P.GT.J1-ione0)GO TO 154 !syncalgxls
!
                    jp=jndex(j1p)
                    if(j.lt.0.and.jp.lt.0)then  !omit cor-cor, as algxls
                      if(becor)then
                        ncor=ncor+1
                        go to 152
                      endif
                      go to 154
                    endif
!
                    N1=NAD(NCOR)+1
                    NCOR=NCOR+1
                    N2=NAD(NCOR)
!                                    write(73,*)ix,md1,mdp1,j,jp,ncor,n2
                    IF(N1.GT.N2)GO TO 152
                    KG=NFK(J1P)
!
! need to find if Slater integral initial and final states are swapped
! because of falling order. (algebraic are not swapped in LS.)
!
                    ixxx=n2-n1+1
                    if(ixxx.gt.ixd13)then
                      deallocate(bswap)
                      ixd13=ixxx
                      allocate(bswap(ixd13))
                    endif
!
                    ks=0
                    do n=n1,n2
                      ks=ks+1
                      bswap(ks)=.false.
                      n0=int(nrk(n),sp)
                      m0=qrl(1,n0)
                      if(li.eq.ql(m0))then
                        if(li.eq.lf.and.kf.ne.kg)then
                          m0=qrl(3,n0)
                          if(qn(m0).gt.0)then                  !exchange
                            if(m0.ne.kact(kg,kf))then              !swap
                              bswap(ks)=.true.
                            endif
!                         else             !direct and it doesn't matter
                          endif
!                       else           !distinct or kf=kg, so they can't
                        endif
                      else                         !trivially, they were
                        bswap(ks)=.true.
                      endif
                    enddo
!
                    NOMTG=(MDP1-1)*MC+MD1                   !rho2 (orig)
                    if(beqgrpl)nmteq=(md1-1)*mcp+mdp1
!
                    DO M=1,MTRAN
!
                      DD=DZERO
                      ks=0
                      DO N=N1,N2
                        ks=ks+1
!
                        if(bswap(ks))then !swap because of falling order
                          mm=mrndx(m)
                        else
                          mm=m
                        endif
!
                        N0=INT(NRK(N),SP)
!
                        DD=DD+DRLX(N0,mm,LSTORE)*DRK(N)
                        IF(BKUTOO)THEN
                          DS=DZLX(N0,mm,LSTORE)
                          IF(BFALL(N))DS=-DS
                          DS=DS+DXTWOX(N0,mm,LSTORE)*DRK(N)             &
     &                       +DETAX(N0,mm,LSTORE)*DEK(N)
                          DD=DD+DS
                        ENDIF
                      ENDDO
!
                      RHO2(M,NOMTG)=RHO2(M,NOMTG)+DD            !UNMIXED
!
                      if(beqgrpl.and.nomtg.ne.nmteq)then  !pop lower tri
                        mm=mrndx(m)                        !need reverse
                        rho2(mm,nmteq)=rho2(mm,nmteq)+dd
                      endif
!
                    ENDDO
!
!                    write(mw6,777)j1,j1p,(rho2(m,nomtg),m=1,mtran)
!  777               format(2i5,1p,10d12.3/(10x,10d12.3))
!
  152             ENDDO                       !END LOOP OVER FINAL TERMS
!
  154           ENDDO                       !END LOOP OVER INITIAL TERMS
!
                if(btimet)then
                  call nrb_time(timef)
                  timeset=timeset+timef-timei
                  timei=timef
                endif
!
!-----------------------------------------------------------------------
!
                MX=MTRAN
!
! INTERP THEN MIX (APPROX)
!
                if(.not.bmix)then
!
                  DO MDP1=1,MCP             !BEGIN LOOP OVER FINAL TERMS
!
                    J1P=MDP1+MCIP
                    JP=JNDEX(J1P)
!
                    NOMTG0=(MDP1-1)*MC
!
                    DO MD1=1,MC           !BEGIN LOOP OVER INITIAL TERMS
!
                      J1=MD1+MCI
                      J=JNDEX(J1)
!
                      NOMTG=NOMTG0+MD1                !rho2 nomtg (orig)
!
                      IF(J.LE.JP)THEN !INITIAL ALGEBRAIC IS LOWER ENERGY
!
                        JL=J
                        JH=JP
!
                        DO M=1,MX
                          M1=MNDEX(M,1)
                          M2=MNDEX(M,2)
                          TMP(M1,M2)=RHO2(M,NOMTG)
                        ENDDO
!
                      ELSE              !FINAL ALGEBRAIC IS LOWER ENERGY
!
                        JL=JP
                        JH=J
!
                        DO M=1,MX
                          M1=MNDEX(M,1)
                          M2=MNDEX(M,2)
                          TMP(M2,M1)=RHO2(M,NOMTG)
                        ENDDO
!
                      ENDIF
!
                      DE=DSPECE(JH)-DSPECE(JL)
!
                      NOMT=IROW(JL,JH,ione1,NSPECE)             !ROWWISE
!
                      bdip=.false.
                      if(jl.le.nmeta.and.jl.lt.jh)then      !need exists
                        bdip=omginf(nomt).lt.dzero          !flag dipole
                      endif
!
! LOOP-OVER MENG0 UPPER STATE SCATTERING ENERGIES
!
                      DO M0=1,MENG0
!
                        M=IYY0(M0)
!
                        ml=mlim(m,1)
                        mu=mlim(m,2)
!
                        if(bdip)mu=-mu                      !flag dipole
!
                        RHO=-2*XINT(DE,DYY,NLAG,TMP(1,M),M,ml,mu)
                                                                !AS A.U.
!
                        RHO2(M0,NOMTG)=RHO
!
                      ENDDO
!
                    ENDDO                   !END LOOP OVER INITIAL TERMS
!
                  ENDDO                       !END LOOP OVER FINAL TERMS
!
                  if(btimet)then
                    call nrb_time(timef)
                    timeint=timeint+timef-timei
                    timei=timef
                  endif
!
                  mx=meng0                                       !re-set
!
                endif
!
                NOMTG=MC*MCP
                DO M=1,MX
                  DO N=1,NOMTG
                    RHO1(N,M)=RHO2(M,N)
                  ENDDO
                ENDDO
!
                if(btimet)then
                  call nrb_time(timef)
                  timeset=timeset+timef-timei
                  timei=timef
                endif
!
!-----------------------------------------------------------------------
!
! NOW MIX (INITIAL)
!
                N0=NADRUG(NC)
                N0P=NADRUG(ND)
!                MCI=NGRPI(NC)
!                MCIP=NGRPI(ND)
!                MC=NSL(NC)
!                MCP=NSL(ND)
!
                DO MD1=1,MC               !BEGIN LOOP OVER INITIAL TERMS
!
                  J1=MD1+MCI
                  j=jndex(j1)
                  if(j.lt.0)go to 160                         !omit corr
                  if(j.gt.nmeta)go to 160           !omit non-metastable
!
                  if(bcorr.or.li.eq.lf)then
                    DO MDP1=1,MCP           !SEE IF WE HAVE A FINAL TERM
                      J1P=MDP1+MCIP
                      IF(J1P.GT.J1.and.li.eq.lf)GO TO 160
                      jp=jndex(j1p)
                      if(jp.gt.0)go to 156                        !we do
                    ENDDO
                    GO TO 160                                  !WE DON'T
                  endif
!
  156             N1=N0+(MD1-1)*MC                          !tfu pointer
!
                  DO M=1,MX
!
                    DO MDP1=1,MCP                   !FOR EACH FINAL TERM
!
                      NG0=(MDP1-1)*MC                    !for rho1 nomtg
!
                      IF(LAPAK.GT.0)THEN                         !LAPACK
                  DD=DDOT(MC,RHO1(NG0+1,M),IONE,TFU(N1+1),IONE)  !LAPACK
                      ELSE                                       !LAPACK
                      DD=DZERO
                      DO LD1=1,MC                  !BEGIN INITIAL MIXING
!x                          IF(ABS(TFU(N1+LD1).GT.XMIX)THEN
                        DD=DD+RHO1(NG0+LD1,M)*TFU(N1+LD1)    !ng=ng0+ld1
!x                          ENDIF
                      ENDDO                          !END INITIAL MIXING
                      ENDIF                                      !LAPACK
!
                      TEMP(MDP1,M)=DD
!
!                      j1p=mdp1+mcip
!                      write(mw6,777)j1,j1p,(temp(mdp1,m),m=1,mx)
                    ENDDO                           !FOR EACH FINAL TERM
!
                  ENDDO
!
                  if(btimet)then
                    call nrb_time(timef)
                    timemixi=timemixi+timef-timei
                    timei=timef
                  endif
!
! NOW MIX (FINAL)
!
                  NOMTG0=(MD1-1)*MCP                     !for rho1 (new)
!
                  DO MDP1=1,MCP             !BEGIN LOOP OVER FINAL TERMS
!
                    J1P=MDP1+MCIP
                    IF(J1P.GT.J1.and.li.eq.lf)GO TO 160
                    if(j1.eq.j1p.and.ione1.ne.0)go to 158
!
                    jp=jndex(j1p)
                    if(jp.lt.0)go to 158                      !omit corr
!                    if(min(j,jp).gt.nmeta)go to 10      !non-metastable
!
                    N1P=N0P+(MDP1-1)*MCP                    !tfu pointer
!
                    NOMTG=NOMTG0+MDP1                        !rho1 (new)
!
                    DO M=1,MX
!
                      IF(LAPAK.GT.0)THEN                         !LAPACK
                    DD=DDOT(MCP,TEMP(1,M),IONE,TFU(N1P+1),IONE)  !LAPACK
                      ELSE                                       !LAPACK
                      DD=DZERO
                      DO LDP1=1,MCP                  !BEGIN FINAL MIXING
!x                          IF(ABS(TFU(N1P+LDP1)).GT.XMIX)THEN
                        DD=DD+TEMP(LDP1,M)*TFU(N1P+LDP1)
!x                          ENDIF
                      ENDDO                            !END FINAL MIXING
                      ENDIF                                      !LAPACK
!
                      RHO2(M,NOMTG)=DD
!
                    ENDDO
!
!                    write(mw6,777)j1,j1p,(rho2(m,nomtg),m=1,mx)
  158             ENDDO                       !END LOOP OVER FINAL TERMS
!
                  if(btimet)then
                    call nrb_time(timef)
                    timemixf=timemixf+timef-timei
                    timei=timef
                  endif
!
  160           ENDDO                       !END LOOP OVER INITIAL TERMS
!
! FIRST SEE IF WE NEED REVERSE CASE:
!----------------------------------
!
!  INITIAL & FINAL ARE ALGEBRAIC AND SO NMETA CAN BE IN EITHER/BOTH/NONE
!  BUT WE WANT THE FIRST MIXING MATRIX MULT TO BE FOR NMETA SO WE DON'T
!  NEED TO MULTIPLY BY THE ZERO BLOCK. THUS, WE MAKE A DOUBLE PASS. OF
!  COURSE, IF NMETA=NSPECE THEN THE SECOND PASS IS "SKIPPED".
!
                DO MDP1=1,NSL(NC)                   !CHECK INITIAL TERMS
                  J1P=MDP1+NGRPI(NC)
                  jp=jndex(j1p)
                  if(jp.gt.nmeta)go to 162                       !needed
                ENDDO
                GO TO 172                                      !ALL DONE
!
! NOW MIX (FINAL) - REVERSE CASE
!
  162           N0=NADRUG(ND)
                N0P=NADRUG(NC)
                MCI=NGRPI(ND)
                MCIP=NGRPI(NC)
                MC=NSL(ND)
                MCP=NSL(NC)
!
                DO MD1=1,MC                 !BEGIN LOOP OVER FINAL TERMS
!
                  J1=MD1+MCI
                  j=jndex(j1)
                  if(j.lt.0)go to 170                         !omit corr
                  if(j.gt.nmeta)go to 170           !omit non-metastable
!
                  DO MDP1=1,MCP             !SEE IF WE HAVE INITIAL TERM
                    J1P=MDP1+MCIP
                    IF(J1P.LT.J1.and.li.eq.lf)GO TO 164
                    jp=jndex(j1p)
                    if(jp.gt.nmeta)go to 166                      !we do
  164             ENDDO
                  GO TO 170                                    !WE DON'T
!
  166             N1=N0+(MD1-1)*MC                          !tfu pointer
!
                  DO M=1,MX
!
                    DO MDP1=1,MCP                 !FOR EACH INITIAL TERM
!
                      IF(LAPAK.GT.0)THEN                         !LAPACK
                    DD=DDOT(MC,RHO1(MDP1,M),MCP,TFU(N1+1),IONE)  !LAPACK
                      ELSE                                       !LAPACK
                      NG0=MDP1-MCP                       !for rho1 nomtg
                      DD=DZERO
                      DO LD1=1,MC                    !BEGIN FINAL MIXING
!x                          IF(ABS(TFU(N1+LD1)).GT.XMIX)THEN
                        DD=DD+RHO1(NG0+LD1*MCP,M)*TFU(N1+LD1)
!x                          ENDIF
                      ENDDO                            !END FINAL MIXING
                      ENDIF                                      !LAPACK
!
                      TEMP(MDP1,M)=DD
!
!                    j1p=mdp1+mcip
!                    write(mw6,777)j1,j1p,(temp(mdp1,m),m=1,mx)
!
                    ENDDO                         !FOR EACH INITIAL TERM
!
                  ENDDO
!
                  if(btimet)then
                    call nrb_time(timef)
                    timemixfr=timemixfr+timef-timei
                    timei=timef
                  endif
!
! NOW MIX (INITIAL) - REVERSE CASE
!
                  DO MDP1=1,MCP           !BEGIN LOOP OVER INITIAL TERMS
!
                    J1P=MDP1+MCIP
                    IF(J1P.LT.J1.and.li.eq.lf)GO TO 168
                    if(j1.eq.j1p.and.ione1.ne.0)go to 168
!
                    jp=jndex(j1p)
!                    if(jp.lt.0)go to 12                      !omit corr
                    if(jp.le.nmeta)go to 168             !already gotten
!
                    N1P=N0P+(MDP1-1)*MCP                    !tfu pointer
!
                    NOMTG=MD1+(MDP1-1)*MC              !rho2 nomtg (new)
!
                    DO M=1,MX
!
                      IF(LAPAK.GT.0)THEN                         !LAPACK
                    DD=DDOT(MCP,TEMP(1,M),IONE,TFU(N1P+1),IONE)  !LAPACK
                      ELSE                                       !LAPACK
                      DD=DZERO
                      DO LDP1=1,MCP                !BEGIN INITIAL MIXING
!x                          IF(ABS(TFU(N1P+LDP1)).GT.XMIX)THEN
                        DD=DD+TEMP(LDP1,M)*TFU(N1P+LDP1)
!x                          ENDIF
                      ENDDO                          !END INITIAL MIXING
                      ENDIF                                      !LAPACK
!
                      RHO2(M,NOMTG)=DD
!
                    ENDDO
!
!                    write(mw6,777)j1,j1p,(rho2(m,nomtg),m=1,mx)
  168             ENDDO                     !END LOOP OVER INITIAL TERMS
!
                  if(btimet)then
                    call nrb_time(timef)
                    timemixir=timemixir+timef-timei
                    timei=timef
                  endif
!
  170           ENDDO                         !END LOOP OVER FINAL TERMS
!
! RE-SET
                MCI=NGRPI(NC)
                MCIP=NGRPI(ND)
                MC=NSL(NC)
                MCP=NSL(ND)
!
  172           CONTINUE
!
!-----------------------------------------------------------------------
!
! (IF bmix INTERPOLATE MIXED RHO2.) CONVERT TO TMX AND ADD TO OMEGA
! NOTE, RHO2 IS IN "A.U"
! ALLOW FOR ANY INITIAL ALGEBRAIC TERMS NOT BEING LOWEST IN ENERGY.
!
                if(.not.bmix)mx=-mx                  !skip interp set-up
!
                DO MD1=1,MC               !BEGIN LOOP OVER INITIAL TERMS
!
                  J1=MD1+MCI
                  J=JNDEX(J1)
                  if(j.lt.0)go to 178                         !omit corr
!
                  NCH=NCHI+MD1
! hold
                  if(bunit2)then
                    iwrkn(nch)=j
                    iwrkl(nch)=l0
                  endif
!
                  NOMTG0=(MD1-1)*MCP
!
                  DO MDP1=1,MCP             !BEGIN LOOP OVER FINAL TERMS
!
                    J1P=MDP1+MCIP
                    IF(J1P.GT.J1.and.li.eq.lf)GO TO 178
                    if(j1.eq.j1p.and.ione1.ne.0)go to 176
!
                    JP=JNDEX(J1P)
                    if(jp.lt.0)go to 176                      !omit corr
                    if(min(j,jp).gt.nmeta)go to 176      !non-metastable
!
                    NCHP=NCHIP+MDP1
!
!                    write(mw6,*)nch,nchp,j1,j1p,j,jp
!
                    if(bntest)ntest(nch,nchp)=ntest(nch,nchp)+1
!
! "undefined" should not be accessed by xint...
!                    do m2=1,meng
!                      do m1=1,meng
!                        tmp(m1,m2)=1.d70 !dzero      !test
!                      enddo
!                    enddo
!
                    NOMTG=NOMTG0+MDP1                  !rho2 nomtg (new)
!
                    IF(J.LE.JP)THEN   !INITIAL ALGEBRAIC IS LOWER ENERGY
!
                      JL=J
                      JH=JP
                      NCHL=NCH
                      NCHH=NCHP
                      LUP=LF
!
                      DO M=1,MX
                        M1=MNDEX(M,1)
                        M2=MNDEX(M,2)
                        TMP(M1,M2)=RHO2(M,NOMTG)
                      ENDDO
!
                    ELSE                !FINAL ALGEBRAIC IS LOWER ENERGY
!
                      JL=JP
                      JH=J
                      NCHL=NCHP
                      NCHH=NCH
                      LUP=LI
!
                      DO M=1,MX
                        M1=MNDEX(M,1)
                        M2=MNDEX(M,2)
                        TMP(M2,M1)=RHO2(M,NOMTG)
                      ENDDO
!
                    ENDIF
!
                    DE=DSPECE(JH)-DSPECE(JL)
!
                    NOMT=IROW(JL,JH,ione1,NSPECE)               !ROWWISE
!
                    if(nomt.gt.nomwrt)then        !shouldn't happen, now
                      write(mw0,*)jl,jh,nmeta,nspece,nomt,nomwrt
                      stop 'omega prob.'
                    endif
!
                    bdip=omginf(nomt).lt.dzero              !flag dipole
!
! LOOP-OVER MENG0 UPPER STATE SCATTERING ENERGIES
!
                    DO M0=1,MENG0
!
                      M=IYY0(M0)
!
                      if(bmix)then                               !interp
!
                        ml=mlim(m,1)
                        mu=mlim(m,2)
!
                        if(bdip)mu=-mu                      !flag dipole
!
                        RHO=-2*XINT(DE,DYY,NLAG,TMP(1,M),M,ml,mu)
                                                                !AS A.U.
!
                      else                                 !already have
!
                        RHO=RHO2(M0,NOMTG)
!
                      endif
!
                      RHOSQ=RHO*RHO
! store for ii
                      if(bunit2)then
                        if(nchp.gt.nch)stop 'dwxls: channel reversal'
                        nx=irow(nchp,nch,izero,nchlt)
                        rhom(nx,m0)=rho
                        go to 174
                      endif
!
                      IF(NCH.eq.NCHP)THEN                   !DIAGONAL MX
!                        if(j1.ne.j1p.or.li.ne.lf)stop 'not diag'
!
                        IF(BRMX)THEN                    !USUAL REACTANCE
                          T=PI*PSHFTX(M,L0)
                          CT=COS(T)
                          ST=SIN(T)
                          RMX=(ST+RHO*CT)/(CT+RHO*ST)
                        ENDIF
!
                        IF(BPRNT3)WRITE(MW6,10030)NCHL,NCHH,JL,JH,      &
     &                                  PSHFTX(M,L0),M0,'PHASE SHIFT'
                        T=TPI*PSHFTX(M,L0)
                        C2T=COS(T)
                        S2T=SIN(T)
!
                        if(bunit)then                       !2x2 UNITARY
                          TSQ=DONE+(C2T*(RHOSQ-DONE)+DTWO*S2T*RHO)      &
     &                        /(RHOSQ+DONE)
                        else                                !non-unitary
                          tsq=done+(dtwo*s2t*rho-c2t)
                        endif
!
                        TSQ=TSQ+TSQ        !  T^R=1+EXP(2I*TAU)(T^RHO-1)
!
                      ELSE                                 !OFF DIAGONAL
!
                        IF(BRMX)THEN                    !USUAL REACTANCE
                          T1=TPI*PSHFTX(M,L0)
                          T2=TPI*PSHFTX(M,L00)
                          DET=COS(T1)*COS(T2)-RHOSQ*SIN(T1)*SIN(T2)
                          RMX=RHO/DET
                        ENDIF
!
                        TSQ=4*RHOSQ        !   |T^R(V,V')|=|T^RHO(V,V')|
!
                        if(bunit)TSQ=TSQ/(DONE+RHOSQ)**2 !APPROX UNITRTY
!
                        IF(J1.EQ.J1P)TSQ=TSQ+TSQ   !FOR ELASTIC LI.NE.LF
!
                      ENDIF
!
                      IF(BPRNT3)THEN
                        IF(BRMX)THEN
                          WRITE(MW6,10030)NCHL,NCHH,JL,JH,RMX,M0,       &
     &                                    'R-MATRIX  '
                        ELSE
                          WRITE(MW6,10030)NCHL,NCHH,JL,JH,RHO,M0,       &
     &                                    'RHO-MATRIX'
                        ENDIF
                      ENDIF
!
                      OMPW=wait*TSQ*NWT/DTWO
!
                      if(bht)ompw=ompw/2       !for BHT(1970) comparison
!
! LOOK AT TOP-UP ISSUES, IF L LARGE ENOUGH TO WARRANT IT (OFF IF BTHRSH)
!
                      IF(LNEW.GE.LRGLMN)THEN
!                                                     !NON-DIPOLE TOP-UP
                        IF(OMGINF(NOMT).gt.DZERO.and.litlam.gt.0)THEN
!
                          IF(LNEW.EQ.LRGLAM)THEN           !APPLY TOP-UP
                            EJ=DYY0(M0)
                            EI=EJ+DE
!
                            ompw0=ompw
                            ompw=ompw/wait
                            IF(BPRNT3)OMPW=-OMPW             !FLAG PRINT
!
                            CALL TOP2(LITLAM,LRGLAM,EI,EJ,OMPW)
!
                            ompw=ompw+ompw0*(wait-done)/wait     !adjust
!
                          ELSEIF(LNEW.GT.LRGLAM)THEN
                            OMPW=DZERO
                          ENDIF
!                                                  !DIPOLE:LITLAM=LRGLAM
                        ELSEIF(bdip)THEN                  !POSS ZERO-OUT
!                                                        !INC. IN TOP-UP
                          IF(MAX(LI,LF)/2.GT.LRGLAM)OMPW=DZERO
!
                        ENDIF
!
                      ENDIF
!
! ARCHIVE PARTIAL/TOTAL COLLISION STRENGTHS
!
                      IF(BTHRSH)THEN
                        M00=LUP/2+1-LVMIN
                        IF(M00.LT.1.OR.M00.GT.MOGGY)GO TO 176
                      ELSE                   !CASE NOT XCLUDED BY ALGXLS
                        M00=M0
                      ENDIF
!
                      OMP(M0)=OMPW
!                                                    !UPDATE TOTAL OMEGA
                      OMEGA(M00,NOMT)=OMEGA(M00,NOMT)+REAL(OMPW,RP)
!
  174               ENDDO                        !END LOOP OVER ENERGIES
!                                                         !PARTIAL OMEGA
                    IF(BPRNT2.AND..NOT.bunit2)WRITE(MW6,10020)NCHL,NCHH,&
     &                 JL,JH,(OMP(M0),M0=1,MENG0)
!
  176             ENDDO                       !END LOOP OVER FINAL TERMS
!
  178           ENDDO                       !END LOOP OVER INITIAL TERMS
!
                if(btimet)then
                  call nrb_time(timef)
                  timeint=timeint+timef-timei
                  timei=timef
                endif
!
                NCHIP=NCHIP+MCP
              ENDDO                               !END LOOP OVER FINAL L
!
              NCHI=NCHI+MC
            ENDDO                               !END LOOP OVER INITIAL L
!
  180       NCHIP0=NCHIP0+((L2P-L1P)/4+1)*MCP
                                             !=NCHIP
            if(nchip0.ne.nchip)stop 'nchip0.ne.nchip'
!            write(mw0,*)nchip0,nchip
          ENDDO                              !END LOOP OVER FINAL GROUPS
!
          NCHI0=NCHI0+((L2-L1)/4+1)*MC     !=NCHI
          if(nchi0.ne.nchi)stop 'nchi0.ne.nchi'
!            write(mw0,*)nchi0,nchi
        ENDDO                              !END LOOP OVER INITIAL GROUPS
!
        if(bntest)then
          if(nch.ne.nchp)stop 'channel index error'
          do i=1,nch
            if(ntest(i,i).ne.1)then
              write(mw0,*)'checksum wrong for nch,nch ',i,' :',         &
     &                    ntest(i,i)
            endif
            do j=i+1,nch
              if(ntest(i,j)+ntest(j,i).ne.1)then
                write(mw0,*)'checksum wrong for nch,nchp',i,j,' :',     &
     &                      ntest(i,j),ntest(j,i)
              endif
            enddo
          enddo
        endif
!
! now determine t-matrix from full rho-matrix for approximation-ii:
!
        if(bunit2)then
!
          do m0=1,meng0
            m=iyy0(m0)
!
            if(m0.gt.0)then                                      !LAPACK
             call pqlap(nchlt,rhom(1,m0),wrkp,wrkq,work,nf)      !LAPACK
            else                                                 !LAPACK
            call pq(nchlt,rhom(1,m0),wrkp,wrkq,work,nf)
            endif                                                !LAPACK
!
            if(nf.le.0)go to 400
!
            do nch=1,nchlt
!
              j=iwrkn(nch)
              if(j.le.0)go to 190
              l0=iwrkl(nch)
!
              do nchp=nch,nchlt
!
                jp=iwrkn(nchp)
                if(jp.le.0)go to 185
!
                n=irow(nch,nchp,izero,nchlt)
                tp=-2*wrkp(n)                 !real T^rho
                tq=-2*wrkq(n)                 !imag T^rho
!
! get T^K from T^rho
!
                if(nch.eq.nchp)then
                  t=tpi*pshftx(m,l0)
                  if(bprnt2)then
                    write(mw6,10030)nch,nchp,j,jp,pshftx(m,l0),m0,      &
     &                              'phase shift'
                  endif
                  c2t=cos(t)
                  s2t=sin(t)
                  tp1=tp-done
!                  tr=done+c2t*tp1-tq*s2t
!                  ti=s2t*tp1+c2t*tq
!                  tsq=tr*tr+ti*ti
                  tsq=done+(2*c2t+tp1)*tp1-(2*s2t-tq)*tq
                else
                  tsq=tp*tp+tq*tq
                  if(j.eq.jp)tsq=tsq+tsq
                endif
!
                ompw=wait*tsq*nwt/dtwo
!
                if(bht)ompw=ompw/2      !for bht(1970) comparison
!
                if(j.le.jp)then
                  jl=j
                  jh=jp
                  nchl=nch
                  nchh=nchp
                else
                  jl=jp
                  jh=j
                  nchl=nchp
                  nchh=nch
                endif
!
                nomt=irow(jl,jh,ione1,nspece)
! some top-up
                if(lnew.ge.lrglmn)then             !look at top-up
!
                  if(omginf(nomt).gt.dzero)then        !non-dipole
!
                    if(lnew.eq.lrglam)then           !apply top-up
                      de=dspece(jh)-dspece(jl)
                      ej=dyy0(m0)
                      ei=ej+de
!
                      ompw0=ompw
                      ompw=ompw/wait
                      if(bprnt3)ompw=-ompw             !flag print
!
                      call top2(itwo,lrglam,ei,ej,ompw)
!
                      ompw=ompw+ompw0*(wait-done)/wait     !adjust
!
                    elseif(lnew.gt.lrglam)then
                      ompw=dzero
                    endif
!
                  elseif(omginf(nomt).lt.dzero)then        !dipole
                    if(lnew.gt.lrglam)ompw=dzero
                  endif
!
                endif
!
                omp(m0)=ompw
                omega(m0,nomt)=omega(m0,nomt)+real(ompw,rp)
                if(bprnt2)write(mw6,10020)nchl,nchh,jl,jh,tp,tq,omp(m0)
!
  185         enddo
!
  190       enddo
            if(bprnt2)write(mw6,*)':'
!
          enddo
!
          if(btimet)then
            call nrb_time(timef)
            timeunit=timeunit+timef-timei
          endif
!
          deallocate(rhom,wrkp,wrkq,iwrkn,iwrkl,work,stat=ierr)
!
          if(ierr.ne.0)then
            write(mw0,*)'dwxls: de-allocation fails for rhom,wrk'
            nf=0
            go to 800
          endif
!
        endif
!
!-----------------------------------------------------------------------
!
        if(btimet)then
          write(iw,*)'  set-up time=',nint(timeset),'sec'
          write(iw,*)'   mixi  time=',nint(timemixi),'sec'
          write(iw,*)'   mixf  time=',nint(timemixf),'sec'
          write(iw,*)'   mixir time=',nint(timemixir),'sec'
          write(iw,*)'   mixfr time=',nint(timemixfr),'sec'
          timemix=timemixi+timemixf+timemixir+timemixfr
          write(iw,*)'  mixing time=',nint(timemix),'sec'
          write(iw,*)'  interp time=',nint(timeint),'sec'
          if(bunit2)write(iw,*)' unitary time=',nint(timeunit),'sec'
        endif
!
        if(btimex)then
          call nrb_time(timef)
          times=timef-times
!
!par          if(iam.ge.0)then                                      !par
!par            write(mw6,*)'Ending proc',iam                       !par&
!par     &               ,'dwxls symmetry',ix,':',' nchan='         !par&
!par     &               ,nchs,'(',nch,')'                          !par&
!par     &               ,'  time=',nint(times),'sec'               !par
!par            call flush(iwp)                                     !par
!par          else                                                  !par
          write(iw,*)'Ending dwxls symmetry ',ix,':',' nchan=',nchs,'(',&
     &               nch,')','  time=',nint(times),'sec'
!par          endif                                                 !par
        endif
!
!-----------------------------------------------------------------------
!
        KUTOOX=KOLDOO
        BKUTOO=KUTOOX.NE.0
!                                             --------------------------
      ENDDO                                   !END LOOP OVER TOTAL SYMMS
!                                             --------------------------
!
      IF(IADD.NE.NCOR)THEN
        WRITE(MW6,*)'SR.DWXLS: GLOBAL INDEX ERROR:',IADD,NCOR      !test
        GO TO 800
      ENDIF
!
!par!                                                               !par
!par      if(iam.ne.0)then                                          !par
!par        if(btimex)then                                          !par
!par          btimep=.false.                                        !par
!par          call nrb_time(timef)                                  !par
!par          times=timef-time0                                     !par
!par!                                                               !par
!par          write(iw,*)'Ending proc',iam,' for dwxls:'            !par&
!par     &             ,' time=',nint(times),'sec'                  !par
!par        endif                                                   !par
!par      endif                                                     !par
!par!                                                               !par
!par      ns=0                                                      !par
!par      nr=0                                                      !par
!par      itmp4=int(nomwrt,sp_mpi)                                  !par
!par!                                                               !par
!par      do m0=1,moggy                                             !par
!par!                                                               !par
!par        call pomsend(ns,omega(1,1),nomwrt,omsend)               !par
!par!                                                               !par
!par        call comm_barrier()                                     !par
!par!                                                               !par
!par        call mpi_reduce(omsend,omrecv,itmp4,my_mpi_real,        !par&
!par     &                  mpi_sum,izero_mpi,mpi_comm_world,ier4)  !par
!par!                                                               !par
!par        if(ier4.ne.0)write(mw0,*)'mpi_reduce: iam,ier=',iam,ier4!par
!par!                                                               !par
!par        call comm_barrier()                                     !par
!par!                                                               !par
!par        if(iam.eq.0)call pomrecv(nomwrt,omrecv,nr,omega(1,1))   !par
!par!                                                               !par
!par      enddo                                                     !par
!par!                                                               !par
!par      if(iam.ne.0)go to 5000                                    !par
!par!                                                               !par
!
! APPLY (DIPOLE) TOP-UP (OFF IF BTHRSH)
!
      IF(LRGLAM.GT.0)THEN
!
        WRITE(MW6,10200)LRGLAM
        if(btimex)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Proc',iam,                                !par&
!par     &       'Top-up has been applied: lrglam=',lrglam          !par
!par        else                                                    !par
          write(iw,*)'Top-up has been applied: lrglam=',lrglam
!par        endif                                                   !par
        endif
        IF(BPRNT2)WRITE(MW6,10050)
!
        LITLAM=LRGLAM                             !USE GLOBAL VALUE LA=0
        CO2S=D3QRT/LOG(EINF*DZ2)
!
        NOMT=0
        DO I=1,NMETA                                        !,NSPECL
!          IF(INDEX(I).GT.0)THEN                               !NON-CORR
!
          DO J=I+ione1,NSPECE                                !,NSPECL
!            IF(INDEX(J).GT.0)THEN                             !NON-CORR
!
            NOMT=NOMT+1
            SS=OMGINF(NOMT)
!
            IF(SS.LT.DZERO)THEN                                  !DIPOLE
              SS=SS*CO2S                       !CONVERT TO LINE STRENGTH
              DE=DSPECE(J)-DSPECE(I)
              DE=DE/DZ2
              DO M0=1,MENG0
                EJ=DYY0(M0)/DZ2
                EI=EJ+DE
!
                CALL TOP1(NZA,LITLAM,EI,EJ,SS,OMT)
!
                if(bht)omt=omt/2               !for BHT(1970) comparison
!
                OM=REAL(OMEGA(M0,NOMT),WP)
                OMEGA(M0,NOMT)=OMEGA(M0,NOMT)+REAL(OMT,RP)
!
                IF(BPRNT2)WRITE(MW6,10060)I,J,SS,EI,EJ,DE,OM,OMT,OM+OMT
              ENDDO
            ENDIF
!
!              IF(NOMT.EQ.NOMWRT)GO TO 113                  !WE ARE DONE
!            ENDIF
          ENDDO
!
!          ENDIF
        ENDDO
!
      ELSE
!
        WRITE(MW6,10210)
        if(btimex)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Proc',iam,'Top-up has *NOT* been applied!'!par
!par        else                                                    !par
          write(iw,*)'Top-up has *NOT* been applied!'
!par        endif                                                   !par
        endif
!
      ENDIF
!
! 113  CONTINUE
!
! fix top-up failure on high-e near-degenerate Born allowed transitions
!
      if(btop)then
        NOMT=0
        DO I=1,NMETA
          DO J=I+ione1,NSPECE
            NOMT=NOMT+1
            OMB=OMGINF(NOMT)
            IF(OMB.GT.DZERO)THEN                                   !born
              DE=DSPECE(J)-DSPECE(I)
              DE=MAX(DE,D1M30)
              OM=REAL(OMEGA(2,NOMT),WP)
              DO M0=3,MENG0                        !skip threshold point
                RAT=DYY0(M0)/DE
                OM1=OM
                OM=REAL(OMEGA(M0,NOMT),WP)
                IF(RAT.GT.XBTEST.AND.OM.LT.D0PT8*OM1.AND.OM1.LT.OMB)THEN
                  MM=M0-1              !max(2,m0-1) if no threshold skip
                  GO TO 195
                ENDIF
              ENDDO
              M0=MENG0
              MM=M0+1
              IF(OM1.GE.OMB)THEN
                IF(OM.LT.OMB)MM=MENG0
              ELSE
                IF(OM.LT.OM1)MM=MENG0
              ENDIF
  195         IF(BPRNT2.AND.MM.LE.MENG0)THEN
                WRITE(MW6,10100)I,J,DYY0(M0),DE,RAT,                    &
     &                          (OMEGA(M,NOMT),M=1,MENG0),OMB
              ENDIF
              DO M0=MM,MENG0
                OMEGA(M0,NOMT)=REAL(OMB,RP)
              ENDDO
            ENDIF
          ENDDO
        ENDDO
      endif
!
! test convert to cross section
!
      if(bcrossx)then
        nomt=0
        do i=1,nmeta
          j=index(i)
          jj=nfq(j)
          wi=(qsi(jj)+1)*(qli(jj)+1)
          do j=i+ione1,nspece
            nomt=nomt+1
            de=dspece(j)-dspece(i)
            do m0=1,moggy
              ej=dyy0(m0)
              ei=ej+de
              if(brel)ei=ei+dalf4*ei*ei          !wavenumber
              om=real(omega(m0,nomt),wp)
              om=xconv*om/(ei*wi)
              omega(m0,nomt)=real(om,rp)
            enddo
          enddo
        enddo
      endif
!
!-----------------------------------------------------------------------
!
! WRITE TOTALS
!
      IF(BTHRSH)THEN
        WRITE(MW6,10190)
        IF(BPRNT0)THEN
          WRITE(MW6,10300)((I,J,J=I+ione1,NSPECE),I=1,NMETA)    !ROWWISE
          DO M0=1,MOGGY
            WRITE(MW6,10010)REAL(M0-1+LVMIN),(OMEGA(M0,N),N=1,NOMWRT)
          ENDDO
        ENDIF
      ELSE
        WRITE(MW6,10180)
        IF(BPRNT0)THEN
          WRITE(MW6,10290)((I,J,J=I+ione1,NSPECE),I=1,NMETA)    !ROWWISE
          DO M0=1,MENG0                                         !=MOGGY
            WRITE(MW6,10010)DYY0(M0),(OMEGA(M0,N),N=1,NOMWRT)
          ENDDO
        ENDIF
      ENDIF
!
      IF(IUNIT(MRW23).GT.0)THEN
        CLOSE(MRW23,STATUS='DELETE')
        IF(BTHRSH.or..not.bomega)THEN
          IUNIT(MRW23)=-1
        ELSE
          OPEN(MRW23,FILE='OMEGALS',STATUS='REPLACE')      !USE NEW NAME
!TBD     OPEN(MRW23,FILE='OMEGAULS',STATUS='REPLACE',FORM='UNFORMATTED')
          WRITE(MRW23,*)NZION,MION
          WRITE(MRW23,*)NSPECE,-(MENG0+1),NOMWRT      !FLAG NO E'S .LT.0
          WRITE(MRW23,*)(IWRK3(I),IWRK4(I),I=1,NSPECE)
          WRITE(MRW23,10040)(DWRK(I),I=1,NSPECE)
          DO M0=1,MENG0                                          !=MOGGY
            WRITE(MRW23,F713)DYY0(M0)/DZ2,(OMEGA(M0,N),N=1,NOMWRT)
          ENDDO
          WRITE(MRW23,F713)EINF,(OMGINF(N),N=1,NOMWRT)
          IUNIT(MRW23)=-1
          CLOSE(MRW23)
        ENDIF
      ENDIF
!
! OVERWRITE PWB ADF04 WITH DW, TAKING ACCOUNT OF THE FACT THAT THE PWB
! DOES NOT CONTAIN (SPIN) FORBIDDEN TRANSITIONS
!
      IF(IUNIT(MRW25).GE.0)THEN         !NO ADF04, LIKELY SINCE RAD='NO'
        WRITE(MW6,*)'NO ADF04 FILE="adf04ls"...'
        WRITE(MW0,*)'NO ADF04 FILE ON UNIT=MRW25'
!        NF=-1
        GO TO 400
      ELSEIF(IUNIT(MRW25).LT.0)THEN
        IUNIT(MRW25)=1
        OPEN(MRW25,FILE='adf04ls',STATUS='OLD',ERR=400)
      ENDIF
!
      BEXP=.FALSE.                              !*MUST* SYNC WITH DIAGON
      IF(NSPECE.LT.1000)THEN
        i1=0
        IF(MOGGY.LE.20)THEN
          IF(BEXP)THEN
            F761='(F5.2, I5, 8X,20(1PE10.2))'
            F762='(2I4,22(1PE10.2))'
            F767='(18X,21(F10.5))'
          ELSE
            F761='(A5,A3,I2, 6X, 20(A5, A3))'
            F762='(2I4, 22(A5, A3))'
            F767='(16X,21(F8.5))'
          ENDIF
        ELSE
          IF(BEXP)THEN
            F761='(F5.2, I5, 8X,20(1PE10.2)/(18X,20(1PE10.2)))'
            F762='(2I4,21(1PE10.2)/(18X,20(1PE10.2)))'
          ELSE
            F761='(A5,A3,I2, 6X, 20(A5, A3)/(16X, 20(A5, A3)))'
            F762='(2I4, 21(A5, A3)/(16X, 20(A5, A3)))'  !WRAP LAST POINT
          ENDIF
        ENDIF
      ELSE
        i1=1
        IF(MOGGY.LE.20)THEN
          IF(BEXP)THEN
            F761='(F5.2, I5,10X,20(1PE10.2))'
            F762='(2I5,22(1PE10.2))'
            F767='(20X,21(F10.5))'
          ELSE
            F761='(A5,A3,I2, 8X, 20(A5, A3))'
            F762='(2I5, 22(A5, A3))'
            F767='(18X,21(F8.5))'
          ENDIF
        ELSE
          IF(BEXP)THEN
            F761='(F5.2, I5,10X,20(1PE10.2)/(20X,20(1PE10.2)))'
            F762='(2I5,21(1PE10.2)/(20X,20(1PE10.2)))'
          ELSE
            F761='(A5,A3,I2, 8X, 20(A5, A3)/(18X, 20(A5, A3)))'
            F762='(2I5, 21(A5, A3)/(18X, 20(A5, A3)))'  !WRAP LAST POINT
          ENDIF
        ENDIF
      ENDIF
!
      MSC0=80
      OPEN(MSC0,STATUS='SCRATCH',FORM='FORMATTED')
      IF(.NOT.BEXP)THEN
        MSCP=81
        OPEN(MSCP,STATUS='SCRATCH',FORM='FORMATTED')
      ENDIF
!
      DO N=1,NSPECE+2
        READ(MRW25,10090)CARD
        WRITE(MSC0,10090)CARD
      ENDDO
!
      NNN=max(NOMWRT,nomwr0)
!
      DO N=1,NNN+2
        READ(MRW25,10090,END=200)CARD
        WRITE(MSC0,10090)CARD
      ENDDO
!
  200 REWIND(MRW25)
      REWIND(MSC0)
!
      DO N=1,NSPECE+2
        READ(MSC0,10090)CARD
        WRITE(MRW25,10090)CARD
      ENDDO
!
      IF(BTHRSH)THEN
        ITYPE=6
        WRITE(MRW25,F767)(PSHFT0(M-1+LVMIN),M=1,MOGGY)
        IF(BEXP)THEN
          WRITE(MRW25,F761)REAL(NZA+1),ITYPE,(REAL(M-1+LVMIN),M=1,MOGGY)
        ELSE
          WRITE(MSCP,10120)(REAL(M-1+LVMIN),M=1,MOGGY)
        ENDIF
      ELSE
        ITYPE=5
        IF(BEXP)THEN
          WRITE(MRW25,F761)REAL(NZA+1),ITYPE,(DYY0(M),M=1,MENG0) !=MOGGY
        ELSE
          WRITE(MSCP,10120)(DYY0(M),M=1,MENG0)                   !=MOGGY
        ENDIF
      ENDIF
!
      IF(BEXP)THEN
        READ(MSC0,F761)
      ELSE
        BACKSPACE(MSCP)
        READ(MSCP,10130)(XMANT(M),IEXP(M),M=1,MOGGY)
        iexp(0)='   '
        READ(MSC0,F761)XMANT(0)                                !,IEXP(0)
        WRITE(MRW25,F761)XMANT(0),IEXP(0),ITYPE,                        &
     &                   (XMANT(M),IEXP(M),M=1,MOGGY)
      ENDIF
!
      MENG1=MOGGY+1
      IB0=1
      JB0=IB0+IONE1
!
      nt=0
!
      DO N=1,NNN+1
!
        IF(BEXP)THEN
          READ(MSC0,F762)JB,IB,XB0,(DUM,I=1,MXNXB),XB1
        ELSE
          READ(MSC0,F762)JB,IB,XMANT0,IEXP0,(XMANT(I),IEXP(I),I=1,MXNXB)&
     &                   ,XMANT1,IEXP1
        ENDIF
!
        JB1=JB
        IF(JB.LT.0)THEN
          JB1=NSPECE
          IB=MIN(JB1-IONE1,NMETA)
          IF(BEXP)THEN
            XB0=D1M30
            XB1=DZERO
          ELSE
            XMANT0=' 1.00'
            IEXP0='-30'
            XMANT1=' 0.00'
            IEXP1='+00'
          ENDIF
        ENDIF
!
        IF(BEXP)THEN
          X0=D1M30
          X1=DZERO
        ELSE
          XMANT(0)=' 1.00'
          IEXP(0)='-30'
          XMANT(MENG1)=' 0.00'
          IEXP(MENG1)='+00'
        ENDIF
!
        DO JT=JB0,JB1
          IF(JT.EQ.JB1)THEN
            IB1=IB
          ELSE
            IB1=MIN(JT-IONE1,NMETA)
          ENDIF
          DO IT=IB0,IB1
!
!test        if(ione1.eq.0.or.it.ne.jt)then   !catch ione1=0 diagon only
            nt=nt+1
!
            NOMT=IROW(IT,JT,IONE1,NSPECE)
!                                            !TEST MENG0 STILL IF BTHRSH
            IF(OMEGA(MENG0,NOMT).GT.E1M30)THEN         !SKIP SA-SAP.GT.1
!
!              if(omginf(nomt).lt.dzero)then  !test write reduced dipole
!                do m=1,moggy
!                  de=log(dyy0(m)+2.7183)
!                  omega(m,nomt)=omega(m,nomt)/de
!                enddo
!              endif
!
              IF(BEXP)THEN
                IF(JT.EQ.JB1.AND.IT.EQ.IB1)THEN             !NOW ALLOWED
                  X0=XB0
                  X1=XB1
                ENDIF
                WRITE(MRW25,F762)JT,IT,X0,(OMEGA(M,NOMT),M=1,MOGGY),X1
              ELSE
                BACKSPACE(MSCP)
                WRITE(MSCP,10120)(OMEGA(M,NOMT),M=1,MOGGY)
                BACKSPACE(MSCP)
                READ(MSCP,10130)(XMANT(M),IEXP(M),M=1,MOGGY)
                IF(JT.EQ.JB1.AND.IT.EQ.IB1)THEN             !NOW ALLOWED
                  XMANT(0)=XMANT0
                  IEXP(0)=IEXP0
                  XMANT(MENG1)=XMANT1
                  IEXP(MENG1)=IEXP1
                ENDIF
                WRITE(MRW25,F762)JT,IT,(XMANT(M),IEXP(M),M=0,MENG1)
              ENDIF
!
            ENDIF
!test        endif
          ENDDO
          IB0=1
        ENDDO
!
        IF(JB.LT.0)then
          if(nt.ne.nomwrt)then                                 !checksum
            write(mw6,*)'adf04 no. of transitions mis-match: nt,nomwrt='&
     &                  ,nt,nomwrt
            write(mw0,*)'adf04 no. of transitions mis-match'
            nf=-1
            go to 400
          endif
          GO TO 300
        endif
!
        JB0=JB
        IB0=IB+1
!
      ENDDO
!
      WRITE(MW0,*)'SR.DWXLS: HAVE NOT REACHED END OF adf04ls...'
      WRITE(MW6,*)'SR.DWXLS: HAVE NOT REACHED END OF adf04ls...'
      NF=-1
      GO TO 400
!
  300 WRITE(MRW25,F762)-1
      WRITE(MRW25,F762)-1,-1
!
      if(.not.badas)then                             !adas skip comments
        WRITE(MRW25,10070)
!
        NREC=1
  350   NREC=NREC+1
        BACKSPACE(MR5)
        BACKSPACE(MR5)
        READ(MR5,10140)CARD4
        IF(CARD4.NE.'A.S.'.AND.CARD4.NE.'S.S.')GO TO 350
        REWIND(MR5)
!
        DO N=1,NREC
          READ(MR5,10090)CARD
          WRITE(MRW25,10080)CARD
        ENDDO
        DATE='        '
        CALL DATE_AND_TIME(DATE)
        WRITE(MRW25,10110)DATE(7:7),DATE(8:8),DATE(5:5),DATE(6:6),      &
     &                    DATE(3:3),DATE(4:4)
      endif
!
      IUNIT(MRW25)=-1
      CLOSE(MRW25)
!
      CLOSE(MSC0)
      IF(.NOT.BEXP)CLOSE(MSCP)
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par 5000 continue                                                  !par
!
  400 CONTINUE
!
      DEALLOCATE(KACT,KTMP,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXLS: DE-ALLOCATION FAILS FOR KACT,KTMP'
        NF=0
        GO TO 800
      ENDIF
!
  500 CONTINUE
!
      DEALLOCATE(PSHFT0)                                          !SMALL
!
      DEALLOCATE(RHO1,RHO2,TEMP,OMGINF,OMEGA,STAT=IERR)
!par!                                                               !par
!par      deallocate(omsend,omrecv,stat=ierr)                       !par
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXLS: DE-ALLOCATION FAILS FOR RHO,OMEGA,TEMP'
        NF=0
        GO TO 800
      ENDIF
!
  600 DEALLOCATE(TFU,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'DWXLS: DE-ALLOCATION FAILS FOR TFU'
        NF=0
        GO TO 800
      ENDIF
!par!                                                               !par
!par 5500 continue                                                  !par
!
  700 CONTINUE
!
      DEALLOCATE(NADRUG)
      DEALLOCATE(TMP,OMP)
      DEALLOCATE(IEXP,XMANT)
      IF(ALLOCATED(DWRK))DEALLOCATE(DWRK,IWRK3,IWRK4)
!
      deallocate(bswap)
!
  800 CONTINUE
!
!-----------------------------------------------------------------------
!
      if(btimep)then
        call nrb_time(timef)
        times=timef-time0
!
!        if(abs(modd).le.1)then
!
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Ending proc',iam,' for dwxls:'            !par&
!par     &               ,' time=',nint(times),'sec,     '          !par&
!par     &               ,nint(times/60),'min'                      !par
!par          call flush(iw)                                        !par
!par        else                                                    !par
        write(iw,*)'Ending dwxls: time=',nint(times),'sec,     ',       &
     &             nint(times/60),'min'
!par        endif                                                   !par
!        endif
      endif
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(F21.3,2X,1P,10(E11.3)/(23X,10(E11.3)))
10020 FORMAT(2I5,3X,2I4,2X,1P,10(E11.3)/(23X,10(E11.3)))
10030 FORMAT(2I5,3X,2I4,2X,1PE11.3,10X,'E(',I2,')   ',A11)
10040 FORMAT(1P,5E16.6)
!10050 FORMAT(1PE14.8,6E11.3/(14X,6E11.3))
10050 FORMAT(3X,'CH',2X,'CHP',9X,'S',14X,'EI',10X,'EJ',10X,'DE',9X,     &
     &       'OMEGA(PAR)',2X,'OMEGA(TOP)',4X,'OMEGA(TOT)')
10060 FORMAT(2I5,3X,1PE11.3,2X,0P,3F12.4,5X,2F12.4,2X,F12.4)
10070 FORMAT('C',79('-')/'C'/'C')
10080 FORMAT('C ',A200)
10090 FORMAT(A200)
10100 FORMAT(2I5,22(1PE10.2))
10110 FORMAT('C'/'C'/'C',79('-')/'C'/'C',1X,                            &
     &       'AUTOSTRUCTURE DISTORTED-WAVE'/'C'/'C NAME:'/'C DATE: ',   &
     &       2(A1),'/',2(A1),'/',2(A1)/'C'/'C',79('-'))
10120 FORMAT(22(1PE9.2))
10130 FORMAT(22(A5,1X,A3))
10140 FORMAT(A4)
10150 FORMAT(2I10,13X,I5,I2,I5,12X,F18.6)
10160 FORMAT(9X,'I',8X,' T',14X,'2S+1 L   CF',20X,'(EI-E1)/RY',15X,     &
     &       'NMETA=',I5)
10170 FORMAT(//' *** FULLY UNITARIZED K- TO T-MATRIX CONVERSION ***'//)
10180 FORMAT(///1X,136('-')//51X,                                       &
     &       '*** TOTAL COLLISION STRENGTHS (LS) ***'//1X,136('-')//)
10190 FORMAT(///1X,136('-')//45X,                                       &
     &       '*** THRESHOLD PARTIAL COLLISION STRENGTHS (LS) ***'//1X,  &
     &       136('-')//)
10200 FORMAT(//' *** TOP-UP HAS BEEN APPLIED: LRGLAM=',I5//)
10210 FORMAT(//' *** TOP-UP HAS *NOT* BEEN APPLIED ***'//)
10220 FORMAT(//1X,136('-')///49X,'*** TARGET ENERGIES (LS) ***'/)
10230 FORMAT(//1X,136('-')/)
10240 FORMAT(13X,'CH',8X,'T',3X,'SMALL L')
10250 FORMAT(7X,I8,I9,I10)
10260 FORMAT(' SY=',I3,5X,'(2S+1) L P =',I3,I4,I3,5X,'NCHT=',I6,2X,'(', &
     &       I6,')')
10270 FORMAT(//' SY=',I3,5X,'(2S+1) L P =',I3,I4,I3/1X,33('-'))
10280 FORMAT(/3X,'CH',2X,'CHP',6X,'I',2X,'IP',4X,'OMEGA(IE=1,MENG):')
10290 FORMAT(74X,'OMEGA(I-IP)'/74X,11('-')/2X,'*FINAL* ENERGY(RYD)',2X, &
     &       10(2X,I4,'-',I4)/(23X,10(2X,I4,'-',I4)))
10300 FORMAT(74X,'OMEGA(I-IP)'/74X,11('-')/1X,'*FINAL* RYDBERG A.M.',2X,&
     &       10(2X,I4,'-',I4)/(23X,10(2X,I4,'-',I4)))
10310 FORMAT(//' SY=',I3,5X,'(2S+1) L P =',I3,I4,I3,5X,'NCHT=',I6,2X,   &
     &       '(',I6,')'/1X,33('-'))
10320 FORMAT(//' *** UPDATING SLATER INTEGRALS FOR LTOT=',I3/1X,42('-') &
     &       /)
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION IROW(ILI,ILF,IONE1,NENG)
!
      INTEGER(SP) ILI,ILF,IONE1,NENG,IROW
!
      IROW=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE1))/2
!
      END FUNCTION IROW
!-----------------------------------------------------------------------
!
      END SUBROUTINE DWXLS_DDOT
!
!                             *******************
!
      SUBROUTINE EKALG1(KMAX,NF,MMIN,MMAX,DVC,BAM,BBM,QLML,JYI,JYF      &
     &                 ,MAXEL)
!
!-----------------------------------------------------------------------
!
!  SR.EKALG1 DEALS WITH THE PROBLEMS DESCRIBED IN SECTION 3.2 OF E&N:
!  IT CALCULATES THE PURELY ALGEBRAIC COEFFICIENTS FOR EACH REDUCED
!  ELECTRIC MULTIPOLE MATRIX ELEMENT, IN TERMS OF SLATER STATES. NRB
!
!  IT IS CALLED BY:
!    SR.ALGEB2
!
!  IT CALLS:
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!    FN.VCC
!
!  IT CONTAINS:
!    FN.MVC
!
!-----------------------------------------------------------------------
!
      USE COMMON_ALGEB,  ONLY: BFANO
      USE COMMON_CFCT,   ONLY: VCA,VCB,MXLL,MAXLL0,MAXLL1,BVC,BDLBD
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DXRLS,  ONLY: DRKS,DEKS,QRLS,NRKS,BFALLS
      USE COMMON_DXRLS,  ONLY: IRKS,IRKS0,IRLS,IRLS0
      USE COMMON_NSTS,   ONLY: NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT
!
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL2, ONLY: MDEL,MXORBR,MPOL00,MPOL0,MPOLE,MPOLX,CODE
      USE COMMON_NRBAL2, ONLY: MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M8)
!
      DIMENSION DVC(0:*),BAM(*),BBM(*),QLML(MAXEL,*),JYI(*),JYF(*)
!
!
!      MVC(M1,M2)=((M1+2)*M1/2+M2)/2+1
!
!-----------------------------------------------------------------------
!
! INITIALIZATIONS
!
      BSKP=MXLL.EQ.-1
      BKUTOO=KUTOO.NE.0
!
      NMULT=NMULTE-1                              !LIMIT NO OF MULIPOLES
!
      MXORB2=MXORBR*MXORBR                                        !FLAGX
!
      i1=mb+1                                                     !FLAGX
      i2=i1
!
      IOSS=0
      LOSS=0
      NCF=0
      NADS(0)=0
      KGG=KMAX
      DD=DONE
!
! LOOP OVER ALL CONFIG PAIRS
!
      DO KF=1,KMAX
!
        JA=JYI(KF)
        JB=JYF(KF)
!
        IF(BBM(1))KGG=KF                 !WITHIN A GROUP
!
        DO KG=1,KGG
!
          NCF=NCF+1
          BSKPCF=NADS(NCF).LT.0     !KF AND/OR KG NOT CONTRIB
          NADS(NCF)=NADS(NCF-1)
          IF(BSKPCF)GO TO 100
!
! MMIN IS SYNC'ED TO GROUP PARITY
!      IF(MOD(QCP(KF)+QCP(KG)+MMIN,4).NE.0)GO TO 90 !WRONG PARITY
!
          IOSS00=IOSS+1
          LOSS00=LOSS
          LOSS1=LOSS00+1
          JAP=JYI(KG)
          JBP=JYF(KG)
          BAM(1)=KF.EQ.KG
!
! LOOP OVER SLATER STATES OF ALL CONFIG PAIRS
!
          DO J=JA,JB
            IF(BAM(J))GO TO 40
!
            IF(BAM(1))JBP=J              !KF=KG
!
            DO JD=JAP,JBP
              IF(BBM(JD))GO TO 30
!
!THIS NEXT STATEMENT RESOLVES INTERACTIONS BY SLATER STATE, NOT TERM
!OLD      IOSS0=IOSS+1
!
              DO I=LOSS1,LOSS
                IORIG(I)=0
              ENDDO
!
              MK=MMIN
              QCL=0
!
              IF(JD.NE.J)THEN
                QCS=0
                DO I=1,NF
                  QCS=QCS+INT(I,QP)
                  DO K=1,NF
                    IF(IEQ(QCG(K,KG)).NE.IEQ(QCG(I,KF)))GO TO 2
                    IF(QLML(I,J).NE.QLML(K,JD))GO TO 2
                    QCS=QCS-INT(K,QP)
                    GO TO 4
    2             ENDDO
                  IF(QCL.NE.0)GO TO 30
                  QCL=INT(I,QP)
    4           ENDDO
                QCS0=QCS
                QCL0=QCL
                GO TO 10
              ENDIF
!
    5         QCL=QCL+QONE
              QCS=QCL
!
   10         NG=QCG(QCL,KF)
              NT=QCG(QCS,KG)
!
!     M1=QN(NG)
!     M2=QN(NT)
!     IF(ABS(M1-M2).LT.MDEL)GO TO 28
!
              M1=QL(NG)
              M2=QL(NT)
              IF(M1+M2.LT.MK)GO TO 20      !MK TOO LARGE A MULTIPOLE
              IF(ABS(M1-M2).GT.MK)GO TO 20 !MK TOO SMALL A MULTIPOLE
              IF(MK.GT.ABS(M1-M2)+4*NMULT)GO TO 20
                                           !MK GIVES TOO MANY MULTIPOLES
!
              IF(.NOT.BSKP)THEN
                ML1=((QLML(QCL,J)+100)/2)*2-100
                ML2=((QLML(QCS,JD)+100)/2)*2-100
                ML2=-ML2
                IF(BVC.OR.(M1.LE.MXLL.AND.M2.LE.MXLL))THEN
                  I=MVC(M1,ML1)
                  K=MVC(M2,ML2)
                  MM=MK/4+1
                  DD=VCA(I,K,MM)
                ELSE
                  MLK=ML1+ML2
                  DD=VCC(M1,M2,MK,IZERO,IZERO,IZERO)                    &
     &               *VCC(M1,M2,MK,ML1,ML2,MLK)/(MK+1)
                ENDIF
!
                MMM=(MK-ML2)/2
                ISGN=1-2*mod(abs(MMM+QCL+QCS),ITWO)
                                                   !(-1)**(MMM+QCL+QCS)
                DD=ISGN*SQRT(REAL((M1+1)*(M2+1),WP))*DD
!
                IF(ABS(DD/DVC(MK/4)).LT.TYNY)GO TO 20
!
                IF(BFANO)THEN
                  IFANO=MK+M2-M1
                  IFANO=IFANO/4
                  IFANO=1-2*mod(abs(IFANO),ITWO)      !(-1)**IFANO
                  DD=DD*IFANO
                ENDIF
              ENDIF
!
! STORE COEFFICIENT
!
              MX=MK
              MX=MX-MPOL0                                         !FLAGX
              if(irlx.lt.0)then
                i1=icfgp(kf)*mb+1
                i2=icfgp(kg)*mb+1
              endif
              IPLANT=(MX/2)*MXORB2+(NG-I1)*MXORBR+NT-I2
!
              DO L=LOSS1,LOSS
                IF(IPLANT.EQ.JORIG(L))THEN
                  IF(J.EQ.JD)THEN
                    I=IORIG(L)
                    IF(I.GT.0)THEN
                      DRKS(I)=DRKS(I)+DD
                      GO TO 20
                    ENDIF
                  ENDIF
                  LP=L
                  GO TO 15
                ENDIF
              ENDDO
!
! CANNOT FIND OLD ARGUMENT
!
              LP=LOSS+1
              IF(LP.GT.IXRLS)THEN                             !GO TO 999
!
                IXXX=7*(IXRLS/5+1)
!
                WRITE(MW6,*)'*** EKALG1: increasing MXRLS from ',IXRLS, &
     &                      ' to: ',IXXX
                WRITE(MW0,*)'*** EKALG1: increasing MXRLS from ',IXRLS, &
     &                      ' to: ',IXXX
!
                CALL RE_ALLOC2(QRLS,IONE,IFIVE,IONE,IXRLS,IFIVE,IXXX,   &
     &                         IERR)
!
                IF(IERR.NE.0)THEN
                  WRITE(MW0,*)'EKALG1: RE-ALLOCATION FAILS FOR QRLS'
                  NF=0
                  GO TO 200
                ENDIF
!
                IXXX0=MAX(IXRLS,IAXRL)
                IXXX2=MAX(IXXX,IAXRL)
                IF(IXXX2.GT.IXXX0)CALL RE_ALLOC(IORIG,IONE,IXXX0,IXXX2, &
     &             IERR)
                CALL RE_ALLOC(JORIG,IONE,IXRLS,IXXX,IERR)
                CALL RE_ALLOC(JPLANT,IONE,IXRLS,IXXX,IERR) !KEEP IN SYNC
!
                IF(IERR.NE.0)THEN
                  WRITE(MW0,*)                                          &
     &              'EKALG1: RE-ALLOCATION FAILS FOR IORIG,JORIG,JPLANT'
                  NF=0
                  GO TO 200
                ENDIF
!
                IXRLS=IXXX
!
              ENDIF
!
              LOSS=LP
              QRLS(1,LP)=INT(NT,QP)
              QRLS(2,LP)=INT(NG,QP)
              QRLS(3,LP)=INT(MK,QP)
              JORIG(LP)=IPLANT
!
   15         IOSS=IOSS+1
              IF(IOSS.GT.IXRKS)THEN                           !GO TO 999
!
                IXXX=7*(IXRKS/5+1)
!
                WRITE(MW6,*)'*** EKALG1: increasing MXRKS from ',IXRKS, &
     &                      ' to: ',IXXX
                WRITE(MW0,*)'*** EKALG1: increasing MXRKS from ',IXRKS, &
     &                      ' to: ',IXXX
!
                CALL RE_ALLOC(DRKS,IONE,IXRKS,IXXX,IERR)
                IF(BKUTOO)THEN
                  CALL RE_ALLOC(DEKS,IONE,IXRKS,IXXX,IERR) !KEEP IN SYNC
                  CALL RE_ALLOC(BFALLS,IONE,IXRKS,IXXX,IERR)
                                                           !KEEP IN SYNC
                ENDIF
!
                IF(IERR.NE.0)THEN
                  WRITE(MW0,*)                                          &
     &                       'EKALG1: RE-ALLOCATION FAILS FOR DRKS,DEKS'
                  NF=0
                  GO TO 200
                ENDIF
!
                CALL RE_ALLOC(NRKS,IONE,IXRKS,IXXX,IERR)
                CALL RE_ALLOC(NSTJ,IONE,IXRKS,IXXX,IERR)
                CALL RE_ALLOC(NSTJD,IONE,IXRKS,IXXX,IERR)
!
                IF(IERR.NE.0)THEN
                  WRITE(MW0,*)                                          &
     &                       'EKALG1: RE-ALLOCATION FAILS FOR NRKS,NSTJ'
                  NF=0
                  GO TO 200
                ENDIF
!
                IXRKS=IXXX
!
              ENDIF
!
              IORIG(LP)=IOSS
              NRKS(IOSS)=LP
              DRKS(IOSS)=DD
              NSTJ(IOSS)=J
              NSTJD(IOSS)=JD
!
   20         IF(JD.EQ.J.AND.QCS.LT.NF)GO TO 5
!
              MK=MK+4
              IF(MK.LE.MMAX)THEN
                            !MULTIPOLE LOOP...
                IF(J.EQ.JD)THEN
                  QCL=0
                  GO TO 5
                ELSE
                  QCL=QCL0
                  QCS=QCS0
                  GO TO 10
                ENDIF
              ENDIF
!
!
   30       ENDDO                  !END SLATER STATE LOOP
!
   40     ENDDO                  !END SLATER STATE LOOP
!
!
! ELIMINATE ZEROES
!
          IF(IOSS.LT.IOSS00)GO TO 100
!
          K=IOSS00-1
          KP=0
          DO I=LOSS1,LOSS
            IORIG(I)=0
          ENDDO
!
          DO I=IOSS00,IOSS
            JD0=NRKS(I)
            JD=ABS(JD0)
            MK=QRLS(3,JD)
            IF(ABS(DRKS(I)/DVC(MK/4)).LT.TYNY)THEN
              IF(IORIG(JD).GT.0)GO TO 80
              JD0=0           !RE-INDEX QRLS AS MAY OCCUR LATER
              GO TO 50
            ENDIF
!
            K=K+1
            DRKS(K)=DRKS(I)
            NSTJ(K)=NSTJ(I)
            NSTJD(K)=NSTJD(I)
!
   50       IF(JD.LE.LOSS00)THEN
              IF(LOSS.LE.IXRLS)THEN
                                  !SHOULD NOT GET HERE
                WRITE(MW6,*)'EKALG1: INFORM NRB OF STOP HERE'
                WRITE(MW0,*)'EKALG1: INFORM NRB OF STOP HERE'
                NF=-1
                GO TO 200
              ELSE      !GRACEFUL EXIT TO DIMENSION STOP
                LP=JD
                GO TO 60
              ENDIF
            ENDIF
!
            IF(IORIG(JD).EQ.0)THEN
              LP=JD-KP
              DO L=1,LOSS00
                DO J=1,3
                  IF(QRLS(J,JD).NE.QRLS(J,L))GO TO 55
                ENDDO
                KP=KP+1
                IORIG(JD)=L
                LP=L
                GO TO 60
   55         ENDDO
            ELSE
              LP=IORIG(JD)
              GO TO 60
            ENDIF
!
            IORIG(JD)=LP
            DO J=1,3
              QRLS(J,LP)=QRLS(J,JD)
            ENDDO
!
   60       IF(JD0.NE.0)THEN
              NRKS(K)=LP
!          IF(JD0.LT.0)NRKS(K)=-NRKS(K)
            ENDIF
   80     ENDDO
!
          LOSS=LOSS-KP
          IOSS=K
          NADS(NCF)=IOSS
!
!
  100   ENDDO              !END LOOP OVER CFS
!
      ENDDO              !END LOOP OVER CFS
!
!
  200 IRLS=LOSS
      IRKS=IOSS
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION MVC(M1,M2)
!
      INTEGER(SP) M1,M2,MVC
!
      MVC=((M1+2)*M1/2+M2)/2+1
!
      END FUNCTION MVC
!-----------------------------------------------------------------------
!
      END SUBROUTINE EKALG1
!
!                             *******************
!
      SUBROUTINE EKALG2(mam,nam,KK,DVC,JOS,IXY)
!
!-----------------------------------------------------------------------
!
!  SR.EKALG2 DEALS WITH THE PROBLEMS DESCRIBED IN SECTION 3.2 OF E&N:
!  IT CALCULATES THE PURELY ALGEBRAIC COEFFICIENTS FOR EACH REDUCED
!  ELECTRIC MULTIPOLE MATRIX ELEMENT, IN TERMS OF LEVELS. NRB
!
!  IT IS CALLED BY:
!    SR.ALGEB2
!
!  IT CALLS:
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_ALGEB,  ONLY: MPRINT
!!      COMMON /BASIC/NF,KF,KG,JGAP(2),MB1,MB2,ND1,NDP1,ND2,NDP2,NGAP
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,IBSK4=>IBSK4,IBSK5=>IBSK5      &
     &              ,MB1=>IBSK6,MB2=>IBSK7,ND1=>IBSK8,NDP1=>IBSK9       &
     &              ,ND2=>IBSK10,NDP2=>IBSK11,IBSK12=>IBSK12
      USE COMMON_DC,     ONLY: BFAST,DC
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL,N8
      USE COMMON_DXRL,   ONLY: IRK,IRK0,IOS,IOS0
      USE COMMON_DXRLS,  ONLY: DRKS,DEKS,QRLS,NRKS,BFALLS
      USE COMMON_DXRLS,  ONLY: IRKS,IRKS0,IRLS,IRLS0
      USE COMMON_NSTS,   ONLY: NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT
!
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL2, ONLY: MDEL,MXORBR,MPOL00,MPOL0,MPOLE,MPOLX,CODE
      USE COMMON_NRBRN2, ONLY: BINDB,MENGB
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M5)
      PARAMETER (TTYNY=TYNY/D1P3)
!
      DIMENSION mam(*),nam(*),DVC(0:*)
!
!-----------------------------------------------------------------------
!
!      ICOL(ILI,ILF,IONE1)=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
!-----------------------------------------------------------------------
!
      BKUTOO=KUTOO.NE.0
!
      if(mpolx.ne.mpole)stop 'mpolx.ne.mpole!'
!
      MX=MPOLX
      MX=MX-MPOL0                                                 !FLAGX
      MXPOL=MAX(IONE,MX/2+1)
      MXORB2=MXORBR*MXORBR                                        !FLAGX
      if(irlx.lt.0)then
        i1=icfgp(kf)*mb+1
        i2=icfgp(kg)*mb+1
      else
        i1=mb+1                                                   !FLAGX
        i2=i1
      endif
!
!B      BBORN=MENGB.GE.0            !BORN CODING USED MORE GENERALLY NOW
!
      IOS0=IOS+1
      LOS=IRL
!
      DO J=1,IRLS
        JORIG(J)=0
      ENDDO
!
      BEQCFS=KG.EQ.KF
!
!     LOOP OVER SLATER STATES
!
      K0=NADS(KK-1)+1
!
      m0=0
      t0=dzero
      DO KS=K0,NADS(KK)
!
        J=NSTJ(KS)
        JD=NSTJD(KS)
!
        IF(BFAST)THEN
          DD=DC(J+ND2)*DC(JD+NDP2)*DRKS(KS)
          IF(BEQCFS.AND.J.NE.JD)DD=DD+DC(J+NDP2)*DC(JD+ND2)*DRKS(KS)
        ELSE
          m=mam(j)
          md=nam(jd)
          if(m.gt.0.and.md.gt.0)then             !m*md can over flow I*4
            if(m.ne.m0)then
              t0=dc(m)
              m0=m
            endif
            DD=t0*DC(md)*DRKS(KS)
          else
            dd=dzero
          endif
          IF(BEQCFS.AND.J.NE.JD)then
            md=mam(jd)
            m=nam(j)
            if(m.gt.0.and.md.gt.0)then           !m*md can over flow I*4
              DD=DD+DC(md)*DC(m)*DRKS(KS)
            endif
          endif
        ENDIF
!
        N=NRKS(KS)
        MM=QRLS(3,N)/2
        IF(ABS(DD/DVC(MM/2)).LE.TTYNY)GO TO 100
!
        L=JORIG(N)
        IF(L.GT.0)THEN
          I=IORIG(L)
          DRK(I)=DRK(I)+DD
        ELSE                                   !CANNOT FIND OLD ARGUMENT
          LOS=LOS+1
          IF(LOS.GT.IAXRL)THEN                                 !GO TO 93
!
            IXXX=7*(IAXRL/5+1)
!
            WRITE(MW6,*)'*** EKALG2: increasing MAXRL from ',IAXRL,     &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** EKALG2: increasing MAXRL from ',IAXRL,     &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC2(QRL,IONE,IFIVE,IONE,IAXRL,IFIVE,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'EKALG2: RE-ALLOCATION FAILS FOR QRL'
              NF=0
              GO TO 300
            ENDIF
!
            IXXX0=MAX(IAXRL,IXRLS)
            IXXX2=MAX(IAXRL,IXXX)
            IF(IXXX2.GT.IXXX0)CALL RE_ALLOC(IORIG,IONE,IXXX0,IXXX2,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'EKALG2: RE-ALLOCATION FAILS FOR IORIG'
              NF=0
              GO TO 300
            ENDIF
!
            IAXRL=IXXX
!
          ENDIF
!
          IOS=IOS+1
          IF(IOS.GT.IAXRK)THEN                                 !GO TO 92
!
            IXXX=7*(IAXRK/5+1)
!
            WRITE(MW6,*)'*** EKALG2: increasing MAXRK from ',IAXRK,     &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** EKALG2: increasing MAXRK from ',IAXRK,     &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC(DRK,IONE,IAXRK,IXXX,IERR)
            IF(BKUTOO)THEN
              CALL RE_ALLOC(DEK,IONE,IAXRK,IXXX,IERR)      !KEEP IN SYNC
              CALL RE_ALLOC(BFALL,IONE,IAXRK,IXXX,IERR)    !KEEP IN SYNC
            ENDIF
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'EKALG2: RE-ALLOCATION FAILS FOR DRK,DEK'
              NF=0
              GO TO 200
            ENDIF
!
            CALL RE_ALLOC(NRK,IONE,IAXRK,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'EKALG2: RE-ALLOCATION FAILS FOR NRK'
              NF=0
              GO TO 200
            ENDIF
!
            IAXRK=IXXX
!
          ENDIF
!
          DRK(IOS)=DD
          NRK(IOS)=LOS
          IORIG(LOS)=IOS
          JORIG(N)=LOS
          DO I=1,3
            QRL(I,LOS)=QRLS(I,N)
          ENDDO
!
        ENDIF
!
  100 ENDDO
!
! CLEAR ARRAY OF ZEROES
!
      IXY=0
      K=IOS0-1
!
      DO I=IOS0,IOS
!
        DD=DRK(I)
        LL=INT(NRK(I),SP)
        MM=QRL(3,LL)/2
        IF(ABS(DD/DVC(MM/2)).GT.TYNY)THEN
          K=K+1
          NT=QRL(1,LL)
          NG=QRL(2,LL)
!B          IF(BBORN)THEN
          MN=MIN(NT,NG)
          MX=MAX(NT,NG)
          IN=ICOL(MN,MX,IZERO)
          BINDB(IN,MM/2)=.TRUE.
          IF(BREL)BINDB(IN,MM/2+1)=.TRUE.
!B         ENDIF
          N8=MXORB2*MXPOL
          MX=MM-MPOL0/2
          IPLANT=MX*MXORB2+(NG-I1)*MXORBR+NT-I2
          NRK(K)=N8*(NDP1-1)+IPLANT
!          write(mw6,*)n8,ndp1,mxorb2,mx,mxorbr,ng,i1,nt,i2
          DD0=SQRT(REAL(2*MM+1,WP))
          DRK(K)=DD0*DD/DVC(MM/2)
!
          IF(MPRINT.GT.0)THEN
            IF(MM.LT.10)THEN
              WRITE(MW6,10010)JOS,ND1,NDP1,NG,NT,K,DRK(K),DD,DVC(MM/2), &
     &                        MB1,MB2,MM
            ELSE
              WRITE(MW6,10020)JOS,ND1,NDP1,NG,NT,K,DRK(K),DD,DVC(MM/2), &
     &                        MB1,MB2,MM
            ENDIF
          ENDIF
        ENDIF
!
      ENDDO
!
      IOS=K
      IF(IOS.GE.IOS0)JOS=JOS+1
!
!-----------------------------------------------------------------------
!
      RETURN
!
  200 IXY=1
      RETURN
!
  300 IXY=-1
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(I5,2X,2(I5,I4),I7,F13.5,2F19.5,6X,2I4,5X,'E',I1)
10020 FORMAT(I5,2X,2(I5,I4),I7,F13.5,2F19.5,6X,2I4,5X,'E',I2)
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!-----------------------------------------------------------------------
!
      END SUBROUTINE EKALG2
!
!                             *******************
!
      SUBROUTINE ELAM(LAM,K1,K2,K3,K4,TELAM)
!
!-----------------------------------------------------------------------
!
!  SR.ELAM EVALUATES THE ETA-LAMDA INTEGRALS OF ORBIT-ORBIT INTERACTION.
!
!  IT IS CALLED BY:
!    SR.SLATR
!    SR.SLATRI
!    SR.SLATRX
!
!  IT CALLS:
!    SR.VLAM
!
!-----------------------------------------------------------------------
!
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
!      IF(LAM.EQ.0)THEN               !test
!        TELAM=DZERO
!        RETURN
!      ENDIF
!
      L1=QL(K1)/2
      L2=QL(K2)/2
      L3=QL(K3)/2
      L4=QL(K4)/2
      LP1=LAM+1
      LP2=LAM+2
      LT=(L1+L3+LP2)*(L3-L1+LP1)*(L1-L3+LP1)*(L1+L3-LAM)*(L2+L4+LP2)    &
     &   *(L4-L2+LP1)*(L2-L4+LP1)*(L2+L4-LAM)
!
      if(lt.le.0)then                  !not needed for this L (IDW.ne.0)
        telam=dzero                    !1.d99 !test
        return
      endif
!
      T=SQRT(REAL(LT,WP))
      TP=LP1*LP2*(2*LP1-1)*(LP1+LP2)
! JONES  TP=LP1*LP2
!
      CALL VLAM(LAM,K1,K2,K3,K4,V)
!
      V=T*V/TP
!
      TELAM=-V                                                 !V->-V
!
!     WRITE(MW6,100) K1, K2, K3, K4, 2*LAM, ELAM
!100  FORMAT(8X,2(I5,I4),I6,F14.7,' =ELAM')
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE ELAM
!
!                             *******************
!
      FUNCTION F21(A,Y,C,D,EPS,IFAIL)
!
!-----------------------------------------------------------------------
!
! FN.F21 DETERMINES THE 2_F_1 HYPERGEOMETRIC FUNCTION FROM SERIES
!
!  IT IS CALLED BY:
!    SR.FDIP0
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
      IPRINT=IFAIL
      IFAIL=0
      T=(A*Y*D)/C
      DD=DONE/(DONE-D)
      SUM=DONE+T
      TN1=DZERO
!
      I=1
  100 AI=I
      T=T*(A+AI)*(Y+AI)*D/((C+AI)*(DONE+AI))
      TN2=T*DD
      F21=SUM+TN2
      SUM=SUM+T
!
      AT=ABS(T+TN2-TN1)
      AS=ABS(F21)*EPS
!
      IF(AS.GE.AT)RETURN
!
      TN1=TN2
      I=I+1
      IF(I.LT.301)GO TO 100
!
      IF(IPRINT.GT.0)WRITE(MW6,10010)
      IFAIL=3
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(' FAILED TO CONVERGE IN F21')
!
!-----------------------------------------------------------------------
!
      END FUNCTION F21
!
!                             *******************
!
      SUBROUTINE FACHXS(Z,NE,IHX,HX0,HX1,AHX)
!
!-----------------------------------------------------------------------
!
! SR.FACHXS EVALUATES THE FAC COEFFICIENT TO THE HARTREE-SLATER LOCAL
! EXCHANGE POTENTIAL, AS DISCUSSED IN COWAN'S BOOK CH.7-11.
! IT IS A TRANSLATION FROM C-TO-FORTRAN OF THE FAC SUBROUTINE GetHXS,
! THIS ACCOUNTS FOR THE MESSY ARRAY MAPPING.
!
! INPUT:
!
! Z IS THE NUCLEAR CHARGE.
! NE IS THE NUMBER OF ELECTRONS.
! IHX IS AN OPTIONAL FAC INPUT, WHOSE DEFAULT VALUE IS -1.
!      IT SPECIFIES THE COMBINATION OF THE TWO TABLES TO USE.
!      ONLY THE ABS(IHX) IS USED BY THIS SUBROUTINE.
!      THE DEFAULT USES THE SECOND TABLE, WHOSE VALUES ARE THE LARGER.
! HX0, HX1 ARE OPTIONAL VALUES TO BE USED INSTEAD OF THE INTERNAL ONES.
!      THEIR FAC DEFAULT VALUES ARE -1, -1.
!      IF HX0>0 THEN AHX=HX0+HX1*Z*Z.
!
! OUTPUT:
!
! AHX IS THE SAID COEFFICIENT, IN A.U.
!
! NOTE: FAC THEN MULTIPLIES AHX BY HXS OUTSIDE OF GetHXS.
!       THE DEFAULT VALUE OF HXS IS 1.
!
! FOR ANY FAC RUN, THE VALUES USED FOR
! IHX, HX0, HX1 & AHX, HXS
! CAN BE FOUND IN THE FAC GetPOTENTIAL FILE.
!
!  IT IS CALLED BY:
!    SR.MINIM0
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: SP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A-H,O-Z)
      IMPLICIT INTEGER(SP) (I-N)
!
      REAL(WP) IHX,NE                                !N.B. NOT INTEGERS!
!
      PARAMETER (NHXN=30)
!
! UNUSED HERE
!      PARAMETER (NXS=15)
!      PARAMETER (NXS2=2*NXS+1)
!
      DIMENSION AHX0(0:1,0:NHXN),AHX1(0:1,0:NHXN)
!
! UNUSED HERE
!      DIMENSION AHXN(0:NHXN)
!
!      DATA (AHXN(J),J=0,NHXN-1)
!     &                      /2,  3,  4,  5,  6,  7,  8,  9, 10,
!     &                      11, 12, 13, 14, 15, 16, 17, 18,
!     &                      19, 20, 21, 22, 23, 24, 25, 26, 27,
!     &                      28, 29, 30, 31/
!
      DATA (AHX0(0,J),J=0,NHXN-1)                                       &
     &/0.49464443,  0.4944842 ,  0.47671812,  0.47368338,  0.46881982,  &
     & 0.4650677 ,  0.46239243,  0.45992017,  0.4581007 ,  0.45699729,  &
     & 0.45327464,  0.45147903,  0.45018784,  0.44901484,  0.44783271,  &
     & 0.44677685,  0.44601044,  0.44668505,  0.44690311,  0.44747163,  &
     & 0.44809634,  0.44896082,  0.45032069,  0.4514605 ,  0.45283192,  &
     & 0.45420841,  0.45580976,  0.45472978,  0.45249835,  0.45/
      DATA (AHX0(1,J),J=0,NHXN-1)                                       &
     &/0.60392457,  0.5963838 ,  0.54396742,  0.53136923,  0.53471311,  &
     & 0.53206107,  0.52694942,  0.52089717,  0.51642186,  0.53134076,  &
     & 0.48894837,  0.47899983,  0.47580524,  0.47583937,  0.4763066 ,  &
     & 0.47516619,  0.47327929,  0.47544085,  0.47804916,  0.48123176,  &
     & 0.4848968 ,  0.4886115 ,  0.49402954,  0.49848388,  0.50336365,  &
     & 0.50842387,  0.51389326,  0.53564154,  0.55618328,  0.55/
!
      DATA (AHX1(0,J),J=0,NHXN-1)                                       &
     &/-2.24999797e-05,  -2.09402638e-05,  -1.97068001e-05,             &
     & -1.86529759e-05,  -1.73178539e-05,  -1.95629593e-05,             &
     & -2.21086675e-05,  -2.11895870e-05,  -2.01426809e-05,             &
     & -1.98210143e-05,  -1.92998222e-05,  -1.86920564e-05,             &
     & -1.82455335e-05,  -1.84696909e-05,  -1.87351162e-05,             &
     & -1.80283589e-05,  -1.73407781e-05,  -1.69192139e-05,             &
     & -1.63363906e-05,  -1.58294488e-05,  -1.53107601e-05,             &
     & -1.53014957e-05,  -1.54457903e-05,  -1.50586829e-05,             &
     & -1.47144622e-05,  -1.43879181e-05,  -1.40649716e-05,             &
     & -1.40581261e-05,  -1.38378555e-05,   -1.4e-5/
      DATA (AHX1(1,J),J=0,NHXN-1)                                       &
     &/-4.83974367e-05,  -2.69133100e-05,  -2.41090948e-05,             &
     & -2.21989673e-05,  -1.94076264e-05,  -1.97061814e-05,             &
     & -2.07157339e-05,  -1.88678066e-05,  -1.77080751e-05,             &
     & -2.23815832e-05,  -1.76272492e-05,  -1.70901358e-05,             &
     & -1.70196986e-05,  -1.72463938e-05,  -1.72980241e-05,             &
     & -1.61671348e-05,  -1.50179117e-05,  -1.48463176e-05,             &
     & -1.47797417e-05,  -1.47793769e-05,  -1.48393532e-05,             &
     & -1.53064076e-05,  -1.62570909e-05,  -1.63962294e-05,             &
     & -1.65777367e-05,  -1.67306107e-05,  -1.69330862e-05,             &
     & -1.95968009e-05,  -2.12996663e-05,  -2.0e-5/
!
!-----------------------------------------------------------------------
!
      if(hx0.GT.DZERO)THEN
        r0=hx0+hx1*z*z
        r0=Max(r0,D1M1)
        r0=Min(r0,D0PT9)
        AHX=R0
        return
      ENDIF
!
      if(hx0.LE.-DFIVE)THEN
        r0=0.42356543_WP                           ! (3/(4*pi^2))**(1/3)
        AHX=R0
        return
      ENDIF
!
      n=INT(DHALF+NE)
      if(n.LT.ITWO)THEN
        AHX=DHALF
        return
      ENDIF
!
      hs=abs(ihx)
      if(hs.LE.D1M3)hs=DZERO
      if(hs.GE.D0PT999)hs=DONE
      r0=DHALF
      r1=DHALF
!
      if(hs.LT.D0PT999)THEN
        if(n.LE.NHXN)THEN
          r0=Ahx0(0,n-2)+Ahx1(0,n-2)*z*z
        else
          r0=Ahx0(0,NHXN-1)+Ahx1(0,NHXN-1)*z*z
        ENDIF
        r0=Max(r0,D1M1)
        r0=Min(r0,D0PT9)
        if(hs.LT.D1M3)THEN
          AHX=R0
          return
        ENDIF
      ENDIF
!
      if(hs.GT.D1M3)THEN
        if(n.LE.NHXN)THEN
          r1=Ahx0(1,n-2)+Ahx1(1,n-2)*z*z
        else
          r1=Ahx0(1,NHXN-1)+Ahx1(1,NHXN-1)*z*z
        ENDIF
        r1=Max(r1,D1M1)
        r1=Min(r1,D0PT9)
        if(hs.GT.D0PT999)THEN
          AHX=R1                                            !IHX DEFAULT
          return
        ENDIF
      ENDIF
!
      AHX=r1*hs+r0*(DONE-hs)             !NOT USED BY DEFAULT ABS(IHX)=1
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE FACHXS
!
!                             *******************
!
      SUBROUTINE FCF4(F,C,E,Z,L,MJH0,MNH,DHNS,DX)
!
!-----------------------------------------------------------------------
!
!  BADNELL AND BURGESS, D.A.M.T.P., CAMBRIDGE.
!
!  SR.FCF4 DETERMINES A CONTINUUM COULOMB FUNCTION BY SERIES EXPANSION.
!
!  IT CONTAINS:
!    FN.WILF
!
!  INPUT. E,Z,L, PLUS GRID INFO FROM SR.RADIAL MJH0,MNH,DHNS,DX.
!
!  OUTPUT. F,C.
!
!  FREE REGULAR COULOMB REAL-FUNCTION IN F(J), AT X=DX(J).
!  F SATISFIES ((D/DX)(D/DX)-L(L+1)/X**2-2Z/X+E)F=0
!  F=C*X**(L+1.0)*(1.0+...) FOR SMALL X
!  F=K**(-0.5)*SIN(KX-0.5*EL*PI-(Z/K)LOG(2KX)+ARGGAMMA(EL+1+I*Z/K))
!  FOR LARGE X
!  WHERE K=SQRT(E)
!  N.B. Z IS POSITIVE FOR REPULSIVE FIELD
!  X0 IS (APPROX.) THE FIRST POINT OF INFLEXION IN F.
!
!  IT IS CALLED BY:
!    SR.RADCNX
!    SR.RADCON
!
!  IT CALLS:
!
!  IT CONTAINS:
!    FN.WILF
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION F(*),A(100)
      DIMENSION MNH(*),DHNS(*),DX(*)
!
!      WILF(X)=E+W1/X+W2/(X*X)
!
!-----------------------------------------------------------------------
!
      PI=ACOS(-DONE)
      EL=L
      W1=-(Z+Z)
      W2=-EL*(EL+DONE)
      W3=(EL+DONE)*(EL+DTWO)
      ZZ=Z*Z
!
      IF(E.GT.D1M40)GO TO 500
      IF(ABS(Z).GT.D1M15)GO TO 200
!
      WRITE(MW6,10010)
!
  100 K=0
!
      DO M=1,MJH0
        I1=MNH(M)
        DO I=1,I1
          K=K+1
          F(K)=DZERO
        ENDDO
      ENDDO
!
      GO TO 1300                                                 !RETURN
!
  200 IF(Z.LT.DZERO)GO TO 400
  300 WRITE(MW6,10020)
      GO TO 100
!
  400 C=-Z*(PI+PI)
      GO TO 800
!
  500 EK=SQRT(E)
      T1=PI*Z/EK
      T2=ABS(T1)
      IF(T2.GT.D1M2)GO TO 600
!
      C=DTHREE*EK/(DTHREE+T1*(DTHREE+T1*(DTWO+T1)))
      GO TO 800
!
  600 IF(T2.LT.D80)GO TO 700
      IF(Z.LT.DZERO)GO TO 400
      GO TO 300
!
  700 C=DONE-EXP(T1+T1)
      C=-(PI+PI)*Z/C
  800 C2=DONE
!
      IF(L.GT.0)THEN
        DO J=1,L
          CJ=J
          CJ2=J+J
          C2=C2*CJ*(CJ2+DONE)
          C=C*(ZZ+E*CJ*CJ)
  820     IF(C+C2.GE.D1P70)THEN
            C2=D1M5*C2
            C=D1M10*C
            GO TO 820
          ENDIF
        ENDDO
      ENDIF
!
      C=SQRT(C)/C2
      X0=W3/(SQRT(ZZ+W3*E)-Z)
      I1=0
      I=0
!
      DO M=1,MJH0
        MJH=M
        K=MNH(M)
        I1=I1+K
        DO J=1,K
          I=I+1
          IF(X0.LT.DX(I))GO TO 900
        ENDDO
      ENDDO
      J=K
!
  900 IF(I.LT.2)I=2
      IF(J.EQ.K)I=I-1
      I0=I
      X0=DX(I)
      L1=L+1
      A(1)=DONE
      T1=L1
      A(2)=X0*Z/T1
      J=2
      Z2=Z+Z
!
 1000 J=J+1
      C2=J-1
      C3=J+L+L
      A(J)=X0*(Z2*A(J-1)-X0*E*A(J-2))/(C2*C3)
      IF(J.LE.6)GO TO 1000
      C2=ABS(A(J))+ABS(A(J-1))
      IF(C2.GT.D1M10)GO TO 1000
      J0=J
!
      DO I=1,I0
        X=DX(I)
        X=X/X0
        J=J0
        T1=A(J)
 1050   J=J-1
        T1=A(J)+X*T1
        IF(J.GT.1)GO TO 1050
        F(I)=C*T1*(X*X0)**L1
      ENDDO
!
      IM=1
      I=I0
      X=DX(I)
      H=DHNS(MJH)
!
 1100 H0=H*H
      H1=DTWELF*H0
      C0=F(I)*(DONE+(H1-H0)*WILF(X))-F(I-IM)*(DONE+H1*WILF(X-H))
      C1=F(I)*(DONE+H1*WILF(X))
!
 1200 I=I+1
      X=DX(I)
      C1=C1+C0
      C2=WILF(X)
      F(I)=C1/(DONE+H1*C2)
      C0=C0-H0*C2*F(I)
      IF(I.LT.I1)GO TO 1200
      MJH=MJH+1
!
      IF(MJH.GT.MJH0)GO TO 1300
!
      H=DHNS(MJH)
      IM=2
      I1=I1+MNH(MJH)
      GO TO 1100
!
!-----------------------------------------------------------------------
!
 1300 RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT('***FAILED IN FCF4 BECAUSE E AND Z ARE BOTH ZERO, OUTPUT', &
     &       ' SET TO ZERO')
10020 FORMAT('***FCF4 OUTPUT SET TO ZERO BECAUSE E IS LESS THAN 1.0D-40'&
     &       ,' AND Z EXCEEDS 1.0D-15')
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION WILF(X)
!
      REAL(WP) X,WILF
!
      WILF=E+W1/X+W2/(X*X)
!
      END FUNCTION WILF
!-----------------------------------------------------------------------
!
      END SUBROUTINE FCF4
!
!                             *******************
!
      SUBROUTINE FCF6(FR,C,DEL,L,EI,ZI0,ZIA,QI,U,Z3,ZS,JZNM,ZL,MEND     &
     &               ,MJH0,MNH,DHNS,DX,GR,MAXRS)
!
!-----------------------------------------------------------------------
!
!  N.R.BADNELL D.A.M.T.P. CAMBRIDGE
!
!  SR.FCF6 EVALUATES A DW CONTINUUM RADIAL FUNCTION ON THE INPUT GRID
!  BY SOLVING THE SCHRODINGER EQUATION WITH THE SUMMED COWELL-NUMEROV
!  METHOD, USES SMALLER STEPS IF NECESSARY I.E. IT IS NOT CONSTRAINED
!  BY THE USER INPUT GRID.
!
!  IT IS CALLED BY:
!    SR.RADCNX
!    SR.RADCON
!
!  IT CALLS:
!    FN.CNORM
!    SR.DIFF
!    FN.DNAMP
!    FN.PHASEX
!    FN.PMVDAR
!    FN.ZEFXL
!
!  IT CONTAINS:
!    FN.WILT
!
!  INPUT: L,E,Z0,ZA,Q,U,Z3,ZS,JZNM,ZL,MEND,MJH0,MNH,DHNS,DX
!         WHERE
!    F(I)"=L(L+1)/R**2-ZL(I)-E    AND FOR LARGE R
!    F"=2*ZA/R+L(L+1)/R**2+Q/R**3+U/R**4+Z3/R**5-E
!    N.B. Z0,ZA .LT. 0, E .GT. 0
!    ZS(I) I=1,JZNM IS POTENTIAL POWER SERIES EXPANSION ABOUT ORIGIN
!    MEND,MJH0,MNH,DHNS,DX INFORMATION ON GRID DEFINED IN SR.RADIAL
!
!  OUTPUT: FUNCTION FR, C AND NON-COULOMB PHASE SHIFT / PI=DEL
!          WHERE FOR SMALL R F=C*R**(L+1)
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: TINORB,RZERO,MXBOX
!
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,VSC,XC1,XC2,NPITER
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBREL, ONLY: RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0
      USE COMMON_NRBREL, ONLY: DNUK0,DNUK1,DNUK2,DNUK
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
      REAL(WP) QI,QQ
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (DEPS0=D1M10)
!
      DIMENSION FR(*),GR(*),MNH(*),DHNS(*),DX(*),ZL(*),ZS(0:*)
      DIMENSION A(100),AMP2(20),AMP3(20)
!
      ALLOCATABLE :: DA(:)
!
! Q,U,Z3=ZERO IN AUTOSTRUCTURE
! WILT(T,E,ZZ,CI)=E-(ZZ+(CI+(Q+(U+Z3*T)*T)*T)*T)*T
!
!      WILT(T,E,ZZ,CI)=E-(ZZ+CI*T)*T
!
!-----------------------------------------------------------------------
!
      BREL2=ABS(IREL).EQ.2
!
!-----------------------------------------------------------------------
!
! THE NAMES HERE ARE NOT NECESSARILY SIGNIFICANT THEY ARE COMMON LEGACY.
!
! LOCAL
      IF(BREL2)THEN
!
        ALLOCATE(DA(MAXRS),STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'FCF6: ALLOCATION FAILS FOR DA,'
          NF=0
          RETURN
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! HISTORICALLY, FCF6 EXPECTS THE USER TO SET THE ASYMPTOTIC CHARGE SEEN
! BY A CONTINUUM ELECTRON AND WHICH IS NORMALLY THE CHARGE OF THE ION.
! HOWEVER, SR.STOPOT ALLOWS THE USER TO SET "UNPHYSICAL" CHARGES AND SO,
! LIKE SR.RADWAV WE DETERMINE IT FROM THE POTENTIAL. THIS ASSUMES THAT
! THE POTENTIAL IS TABULATED OUT FAR ENOUGH TO REACH THE ASYMP CHARGE.
! THIS SHOULD NOT BE AN ISSUE NOWADAYS.
!
      ZA0=ZIA
      ZA=ZI0-ZL(MAXRS)*DX(MAXRS)/DTWO
      IF(ABS(ZA-ZA0).GT.D1M4)THEN
!        write(*,*)za0,za
        ZA0=ZA                                                 !REDEFINE
      ENDIF
!
! LOOK AT COULOMB NORMALIZATION TO SEE IF FUNCTION IS NUMERICALLY
! DETERMINABLE, BASICALLY A FUNCTION OF L/E. ZERO-OUT IF NOT,
! THIS SHOULD ONLY OCCUR IN EXTREME CASES. (FCF4 DOESN'T EVEN WARN.)
!
      EC=MAX(EI,D1M2)
      C=CNORM(EC,ZA0,L)
!      write(70,700)l,ei,c
!
      IF(C.LE.DZERO)THEN
!
        WRITE(MW6,10050)L,EI
!
        C=DZERO
        DO I=1,MAXRS
          FR(I)=DZERO
        ENDDO
!
        IF(BREL.AND.ABS(IREL).EQ.2)THEN
          DO I=1,MAXRS
            GR(I)=DZERO
          ENDDO
        ENDIF
!
        RETURN                                !<----------------- RETURN
!
      ENDIF
!
! INITIALIZE
!
      KAPPA=0         !PMVDAR IGNORES KAPPA AND USES ITS OWN, DEFAULT -1
!
!      if(l.gt.0)kappa=-l-1      !l or -l-1
!
      PI=ACOS(-DONE)
      PIH=PI/DTWO
!
      EL=L
      CI=EL*(EL+DONE)
!      ELLP=CI
      ZA=ZA0
      Z0=ZI0
      ZP=-ZI0
!      EE=EI
      E=EI
      CI0=CI
      CI1=CI
      Z0Q=ZI0
      qq=qi
!
! ADD-IN FINITE NUCLEUS (RECALL, POINT ALREADY SUBTRACTED FOR FCF6)
!
      DO I=1,INUK
        T=ZL(I)
        ZL(I)=DNUK(I)+t
        DNUK(I)=T
      ENDDO
!
      IF(BREL)THEN
        EQ=DQUART*DALF*EI*EI
        E=EI+EQ
        Z0=ZI0+DHALF*DALF*ZI0*EI
        CI0=CI-DALF*ZI0*ZI0
        IF(MDEN.LE.0.OR.NPITER.LT.0)THEN      !UNSCREENED MVD CORRECTION
          ZQ=DHALF*DALF*ZA0*EI
          Z0Q=ZI0+ZQ
          ZA=ZA0+ZQ
          CQ=-DALF*ZA0*ZA0
          CI1=CI+CQ
          if(kappa.ne.0)then
            qq=qi+2*(kappa+1)*za0*dquart*dalf/(done+dquart*dalf*ei)
          endif
        ENDIF
      ENDIF
!
      Z2=ZA+ZA
      ZA2=ZA*ZA
      Z1=ZI0+ZI0
      VS=ZS(1)
      ZS(1)=VS+EI                                       !TEMP HOLD E
      NNMAX=10
      JMAX=5
      TMAX=DONE/D64
!
! FIND MAX STEP LENGTH ALLOWABLE FOR ACCURATE EVALUATION OF PHASE
!
      W3=DQUART+CI1-D3QRT/Z0
      HMAX=ABS(E)
      IF(L.GT.0)HMAX=HMAX+ZA2/CI1
      IF(HMAX.LT.D1M10)HMAX=D1M10
      HMAX=SQRT(TMAX/HMAX)
!
! ESTIMATE INNER TURNING POINT
!
!      X0=-DONE/Z0
      X0=DX(2)
      W3=W3-CI1+CI0
      IF(L.GT.0)X0=W3/(SQRT(Z0*Z0+W3*E)-Z0)
!
      i10=0
      I=0
      DO M=1,MJH0
        JM=MNH(M)
        DO J=1,JM
          I=I+1
          IF(X0.LE.DX(I))THEN
            I0=I
            GO TO 100
          ENDIF
        ENDDO
      ENDDO
      I0=I
!
  100 CONTINUE
!
! EVALUATE POWER SERIES SOLUTION FOR FIRST TWO POINTS WITH FR .GT. DEPS.
! (NEGLECT ANY PLASMA SCREENING HERE.)
!
!old      A1=DONE
      A1=C
      A(1)=A1
!
      DEPS=DEPS0/SQRT(-Z0)
      DEPS=DEPS*A1/C
!
      IF(BREL)THEN
!        TL=L                                          !=L HERE
        IF(RNUK.LT.DZERO)THEN                !POINT
          J0=2
          TB=DONE+(EI+DFOUR/DALF)*DX(1)/ZP
          TB=DONE/TB
          TB=TB*TB
          T=L*(L+1)-DALF*ZP*ZP+D3QRT*TB
          TLAM=DQUART+T
          TLAM=SQRT(TLAM)-DHALF
          A(2)=(TLAM+DONE)*(TLAM+DTWO)-T
          A(2)=-A(1)*DTWO*ZP*(DONE+EI*DALF/DTWO)/A(2)
          A(3)=A(1)*TLAM/DTWO                     !FOR Q NORM - NOT USED
        ELSE                                 !FINITE
          J0=3
          A(2)=DZERO
          T=(L+2)*(L+3)-L*(L+1)
          TT=DONE+DQUART*DALF*ZS(1)
          TT=-ZS(3)*D3QRT*DALF/TT
          TT=TT-ZS(1)*(DONE+DQUART*DALF)
          A(3)=A(1)*TT/T
        ENDIF
      ELSE
        A(2)=-A(1)*ZS(0)/(EL+DONE)*2
        T=DZERO
        JM=JZNM+1
        jam=10                                         !jm !old
        ks=2
!        TL=EL                                         !=L HERE
        DO J=2,jam
          if(j.gt.jm)ks=j+1-jznm
          DO K=ks,J
            K2=K-1
            K1=J-K2
            T=T-A(K2)*ZS(K1)
          ENDDO
          T=T+Z1*A(J)
          TJ=J
          A(J+1)=T/((EL+EL+TJ+DONE)*TJ)
        ENDDO
        J0=jam+1
      ENDIF
!
      ZS(1)=VS                               !RE-INSTATE PURE POT
!      TLAM=TL                                         !=L HERE
!
      i10=i0
      I00=2
      m00=1
      i1=MNH(m00)
      i11=1
      i2=i0-2
!
!      write(mw0,*)'Hello World 1'
!
  200 DO I=i11,I00
!      write(mw0,*)'Hello World 2'
        FR(I)=DZERO
        DO J=1,J0
!          T=real(J,wp)
!          T=T+TL                                      !=J+L HERE
          FR(I)=FR(I)+A(J)*DX(I)**(J+L)
        ENDDO
      ENDDO
!
      IF(ABS(FR(I00)).LT.DEPS.AND.ABS(FR(I00-1)).LT.DEPS)THEN
        if(i00.lt.i2)then
          i11=i11+2
          i00=i00+2
          if(i00.ge.i1)then
            if(i00.eq.i1)i00=i00+1
            m00=m00+1
            if(m00.gt.MJH0)then        !zero across entire mesh
              if(i0.eq.i10)then        !not reached inner turning-point
                m00=m00-1
                i00=i1-1
                fr(i00)=deps
                go to 300
              else                     !maybe need to be renormalized
                write(mw6,10040)E,L,DX(I0)
                stop 'fcf6: starting f-values must be non-zero'
!                go to 999            !SUN f95 -O4 does not like this...
              endif
            endif
            i1=i1+MNH(m00)
          endif
          go to 200
        elseif(i0.eq.i10)then          !not reached inner turning-point
          i00=i0-1
          fr(i00)=deps
          go to 300
        else                           !beyond inner turning point
          WRITE(MW6,10040)E,L,DX(I0)
          STOP 'FCF6: STARTING F-VALUES MUST BE NON-ZERO'
!          GO TO 999                  !SUN f95 -O4 does not like this...
        endif
      ENDIF
!      write(mw0,*)i00,dx(i00),i0,dx(i0)
!
  300 IF(ABS(C-A1).GT.DEPS0)THEN         !SKIP IF A(1)=C (&A(2)=A(1)*...
!         write(mw0,*)c
        DO I=1,I00
          FR(I)=FR(I)*C
!           write(mw6,*)i,fr(i)
        ENDDO
      ENDIF
!
! SUMMED COWELL NUMEROV OVER INPUT GRID
!
      M=0                                           !NODES
!
      MJH=m00
      H=DHNS(MJH)
      IM=1
!
      I=I00
      X=DX(I)
      T=DONE/X
!
      V2=ZL(I)+DTWO*VSC(I)+WILT(T,EI,Z1,CI)
      IF(BREL)V2=V2+PMVDAR(I,X,EI,ZP,CI)
!
  400 TT=X-H
      T=DONE/TT
      II=I-IM
!
      V1=ZL(II)+DTWO*VSC(II)+WILT(T,EI,Z1,CI)
      IF(BREL)V1=V1+PMVDAR(II,TT,EI,ZP,CI)
!
      HH=H*H
      H1=HH/DTWELV
      C0=FR(I)*(DONE+(H1-HH)*V2)-FR(I-IM)*(DONE+H1*V1)
      C1=FR(I)*(DONE+H1*V2)
!
  500 I=I+1
      X=DX(I)
      C1=C1+C0
      T=DONE/X
!
      V2=ZL(I)+DTWO*VSC(I)+WILT(T,EI,Z1,CI)
      IF(BREL)V2=V2+PMVDAR(I,X,EI,ZP,CI)
!
      FR(I)=C1/(DONE+H1*V2)
      C0=C0-HH*V2*FR(I)
!
      IF(I.GT.I0.AND.FR(I-1)*FR(I).LT.DZERO)M=M+1                 !NODES
      IF(I.LT.I1)GO TO 500
!
! START NEW INTERVAL
!
      MJH=MJH+1
      H2=H
!
      IF(MJH.LE.MJH0)THEN
        H=DHNS(MJH)
        I1=MNH(MJH)+I1
        IM=2
!
        IF(H.LE.HMAX)GO TO 400       !CHECK IF STEP CAN BE INCREASED
!
        H0=DHNS(MJH-1)
        JH=2
        ITEST=MEND
!
  550   J=0
        IT=I
        IF(MJH.EQ.MJH0)IT=MIN(I,I1-2)
        IF(VSC(1).NE.DZERO)ITEST=I1            !FOR PLASMA/POLARIZTN POT
  600   J=J+1
!
        X=X+H0
        C1=C1+C0
        T=DONE/X
!
        IF(I.LE.ITEST)THEN
          ZT=Z1-X*ZEFXL(X,ZL,DX,IT,EI,ZP,CI)   !ZEFXL INCL. VSC & PMVDAR
          V2=WILT(T,EI,ZT,CI)
        ELSE                                   !IF NO PLASMA/POLARIZ POT
          V2=WILT(T,E,Z2,CI1)
          if(kappa.ne.0)then                   !brel
            v2=v2+pmvdar(-i,x,ei,-za0,ci)
          endif
        ENDIF
!
        F2=C1/(DONE+H1*V2)
        C0=C0-HH*V2*F2
        IF(J.LT.JH)GO TO 600
!
        I=I+1
        X=DX(I)
        FR(I)=F2
!
        IF(I.GT.I0.AND.FR(I)*FR(I-1).LT.DZERO)M=M+1               !NODES
        IF(I.LT.I1)GO TO 550
!
        MJH=MJH+1
        H2=H0
        IF(MJH.LE.MJH0)THEN
          I1=MNH(MJH)+I1
          JH=JH+JH
          GO TO 550
        ENDIF
!
      ENDIF
!
! END OF REQUESTED TABULATION
!
      F2=FR(I1)
      X1=X
      ZT=Z0Q-(ZL(I1)/DTWO+VSC(I1))*X1                         !ZA-VSC*X1
      Z2=ZT+ZT
!
! TEST IF SHORT RANGE POTENTIALS CAN BE NEGLECTED
!
      T=DONE/X1
      TH=V2-WILT(T,E,Z2,CI1)
      if(kappa.ne.0)th=th+qq*t**3
      V2=V2+D1M10
      IF(ABS(TH)*D1P4.GT.ABS(V2))THEN
        WRITE(MW6,10010)E,L,X1,ABS(TH/V2)
!        write(mw6,10010)e,l,th,v2
!        write(mw6,*)z2,ci1
      ENDIF
!
      CHI=DTHREE*CI1+D60
!      X2=CHI/(SQRT(ZA2+E*CHI)-ZA)
      X2=CHI/(SQRT(ZT*ZT+E*CHI)-ZT)
      XZ=(D1P4*ABS(Z3/V2))**DFIFTH
      X2=MAX(X2,XZ,RZERO)
!      x2=1.5*x2
!
! DETERMINE WHERE TO NORMALISE WHEN PLASMA SCREENING POTENTIAL PRESENT,
! ALWAYS GOES OUT TO AT LEAST TO DX(MTEST).
!
      IF(DENE*ABS(VSC(1)).LE.DZERO)GO TO 1200
!
      IF(MOD(MDEN,ITEN).GT.2)THEN
        MTEST=MEND
      ELSE
        MTEST=MAXRS
      ENDIF
!
!      if(l.eq.0)then
!        write(mw0,*)'Hello'
!      endif
!
      ITER=0
      DO I=1,I1
        IF(DX(I).GT.X2)GO TO 700
      ENDDO
      I=I1
!
  700 ZX=Z0Q-(ZL(I)/DTWO+VSC(I))*DX(I)                        !ZA-VSC*DX
      XT=CHI/(SQRT(ZX*ZX+E*CHI)-ZX)
!      write(mw6,*)e,l,iter+1,x2,xt,abs(x2-xt)/max(x2,xt),i,i1
      IF(ABS(X2-XT)/MAX(X2,XT).GT.D1M1)THEN
        ITER=ITER+1
        X2=XT
        IF(ITER.GT.10)GO TO 800
        DO I=1,I1
          IF(DX(I).GT.X2)GO TO 700
        ENDDO
!        write(mw6,*)x1
        I=I1
        GO TO 700
      ENDIF
!
  800 IF(X2.LT.XC1)THEN
!
        IF(DX(MTEST).LT.XC1)THEN
          IF(X1.LT.XC1)GO TO 1200
!
          IF(X2.GT.DX(MTEST))THEN
            DO I=1,I1
              IF(DX(I).GT.X2)GO TO 820
            ENDDO
            I=I1
          ELSE
            I=MTEST
          ENDIF
  820     ZT=Z0Q-(ZL(I)/DTWO+VSC(I))*DX(I)                    !ZA-VSC*DX
!
          GO TO 1000
        ELSE
          ZX=Z0Q-(ZL(MTEST)/DTWO+VSC(MTEST))*DX(MTEST)        !ZA-VSC*DX
          XT=CHI/(SQRT(ZX*ZX+E*CHI)-ZX)
          X2=DX(MTEST)
!
          IF(X2.LT.XT)THEN
            X2=XT
            IF(X2.GT.X1)GO TO 800
          ENDIF
!
          IF(X1.GT.XC2)GO TO 1300
!
          IF(ABS(X2-XC1).GT.ABS(XC2-X1))THEN
            XT=CHI/(SQRT(ZT*ZT+E*CHI)-ZT)                   !ZT IS AT X1
            IF(XT.LT.X1)GO TO 840
          ENDIF
!
          DO I=1,I1
            IF(DX(I).GT.X2)GO TO 860
          ENDDO
  840     I=I1
  860     ZT=Z0Q-(ZL(I)/DTWO+VSC(I))*DX(I)                    !ZA-VSC*DX
          TT=abs((za-zt)/dx(i)*ZT/DX(I))                      !vsc
          IF(TT.GT.D0PT05*(E+DONE))WRITE(MW6,10030)E,L,X2,tt
          IF(-TT.LT.D1M1*(E+DONE))GO TO 1000
          WRITE(MW6,10020)E,L
          WRITE(MW0,*)'FCF6: UNABLE TO DETERMINE AMP-PHASE'
          GO TO 1600
        ENDIF
!
      ELSE
!
        IF(X1.GT.XC2)then
          ZX=Z0Q-(ZL(I1)/DTWO+VSC(I1))*DX(I1)                 !ZA-VSC*DX
          X2=CHI/(SQRT(ZX*ZX+E*CHI)-ZX)
          GO TO 1200
        endif
        IF(X2.LT.X1)THEN
          DO I=1,I1
            IF(DX(I).GT.X2)GO TO 900
          ENDDO
        ENDIF
        I=I1
  900   ZX=Z0Q-(ZL(I)/DTWO+VSC(I))*DX(I)                      !ZA-VSC*DX
        X2=CHI/(SQRT(ZX*ZX+E*CHI)-ZX)
        XT=DX(MTEST)
        IF(XT.LT.X2)XT=X2
!
        IF(X1.LT.X2.OR.ABS(X1-XC2).LT.ABS(XT-XC1))THEN
! USE APPROX ZT (X=X1) IN C-N AND AMP-PHASE
          TT=abs((za-zt)/x1*ZT/X1)                            !vsc
          IF(TT.GT.D0PT05*(E+DONE))WRITE(MW6,10030)E,L,X1,tt
          IF(-TT.LT.D1M1*(E+DONE))GO TO 1200
          WRITE(MW6,10020)E,L
          WRITE(MW0,*)'FCF6: UNABLE TO DETERMINE AMP-PHASE'
          GO TO 1600
        ELSE
          DO I=1,I1
            IF(DX(I).GT.XT)GO TO 920
          ENDDO
          I=I1
!
! CHECK AMP-PHASE ACC
!
  920     ZT=Z0Q-(ZL(I)/DTWO+VSC(I))*DX(I)                    !ZA-VSC*DX
          TT=abs((za-zt)/dx(i)*ZT/DX(I))                      !vsc
          IF(TT.GT.D0PT05*(E+DONE))WRITE(MW6,10030)E,L,DX(I),tt
          IF(-TT.LT.D1M1*(E+DONE))GO TO 1000
          WRITE(MW6,10020)E,L
          WRITE(MW0,*)'FCF6: UNABLE TO DETERMINE AMP-PHASE'
          GO TO 1600
        ENDIF
!
      ENDIF
!
 1000 Z2=ZT+ZT
      X=DX(I)
      F2=FR(I)
!
! RE-INITIALISE FOR F3, ALTERNATIVELY COULD SEARCH FOR F3 LATER
!
      H2=DX(I)-DX(I-1)
      NH=1
 1100 IF(H2.GT.HMAX)THEN
        H2=DHALF*H2
        NH=NH+1
        GO TO 1100
      ENDIF
!
      IF(NH.GT.1)THEN
        TH=NH
        F1=-DHALF*(TH-DONE)*FR(I-2)+(TH+TH-DONE)*FR(I-1)                &
     &     +DHALF*(TH+TH-DONE)*(TH-DONE)*FR(I)
        F1=F1/(TH*TH)
      ELSE
        F1=FR(I-1)
      ENDIF
!
      HH=H2*H2
      H1=HH/DTWELV
      T=DONE/X
      V2=WILT(T,E,Z2,CI1)
      if(kappa.ne.0)v2=v2-qq*t**3
      TT=X-H2
      T=DONE/TT
      V1=WILT(T,E,Z2,CI1)
      if(kappa.ne.0)v1=v1-qq*t**3
      C0=F2*(DONE+(H1-HH)*V2)-F1*(DONE+H1*V1)
      C1=F2*(DONE+H1*V2)
      IP=I+1
      DO J=IP,I1
        IF(FR(J)*FR(J-1).LT.DZERO)M=M-1                           !NODES
      ENDDO
      GO TO 1300
! END PLASMA MOD
!
! CONTINUE INTEGRATION UNTIL CAN USE AMP PHASE
! (COULD INCREASE STEP NOW SINCE NOT RESTRICTED BY TABULATION GRID,
!  BUT STILL NEEDS TO BE FINE ENOUGH FOR NUMEROV.)
!
 1200 IF(X2.GT.X1)THEN
!
        T=HMAX/DHNS(MJH0)
        IH=-INT(T,SP)                                         !SUPPRESS
        IF(IH.GT.1.AND.IH.LE.MNH(MJH0))THEN
          IH=MIN(IH,4_SP)                                  !DON'T GO MAD
          H2=DX(I1)-DX(I1-IH)
          HH=H2*H2
          H1=HH/DTWELV
          T=DONE/DX(I1-IH)
          V1=WILT(T,E,Z2,CI1)
          if(kappa.ne.0)v1=v1-qq*t**3
          F1=FR(I1-IH)
          V2=V2-D1M10
          C0=F2*(DONE+(H1-HH)*V2)-F1*(DONE+H1*V1)
        ENDIF
!
 1250   F1=F2
        X=X+H2
        C1=C1+C0
        T=DONE/X
        C2=WILT(T,E,Z2,CI1)
        if(kappa.ne.0)c2=c2-qq*t**3
        F2=C1/(DONE+H1*C2)
        C0=C0-HH*C2*F2
        IF(F1*F2.LT.DZERO)M=M+1                                   !NODES
!        write(mw6,*)x,f2
        IF(X.LT.X2)GO TO 1250
!
      ELSE
!
        DO I=MEND,-I1,2                                        !SUPPRESS
          IF(X2.LT.DX(I))THEN
            IP=I+1
            DO J=IP,I1
              IF(FR(J)*FR(J-1).LT.DZERO)M=M-1                     !NODES
            ENDDO
            H2=DX(I)-DX(I-1)
            HH=H2*H2
            H1=HH/DTWELV
            T=DONE/DX(I-1)
            V1=WILT(T,E,Z2,CI1)
            F1=FR(I-1)
            T=DONE/DX(I)
            V2=WILT(T,E,Z2,CI1)
            if(kappa.ne.0)v2=v2-qq*t**3
            F2=FR(I)
            C0=F2*(DONE+(H1-HH)*V2)-F1*(DONE+H1*V1)
            C1=F2*(DONE+H1*V2)
            X=DX(I)
            GO TO 1300
          ENDIF
        ENDDO
!
      ENDIF
!
! EVALUATE ASYMPTOTIC AMP AND PHASE AT X2 AND X3=X2+0.5*WAVELENGTH
!
 1300 X2=X
!
      CALL DNAMP(A2,AMP2,E,CI1,Qq,U,ZT,X2,NNMAX,JMAX)
!
      LM=L
      IF(BREL)LM=-L-1
!
      PHI2=PHASEX(E,CI1,Qq,U,LM,ZT,X2)
!
      X23=PIH*A2*A2
      X3=X2+X23
!
 1400 X=X+H2
      C1=C1+C0
      T=DONE/X
      C2=WILT(T,E,Z2,CI1)
      if(kappa.ne.0)c2=c2-qq*t**3
      F3=C1/(DONE+H1*C2)
      C0=C0-HH*C2*F3
      IF(X.LT.X3)GO TO 1400
      X3=X
!
      CALL DNAMP(A3,AMP3,E,CI1,Qq,U,ZT,X3,NNMAX,JMAX)
!
      PHI3=PHASEX(E,CI1,Qq,U,LM,ZT,X3)
!
      F2=F2/A2
      F3=F3/A3
      S2=SIN(PHI2)
      S3=SIN(PHI3)
      C2=COS(PHI2)
      C3=COS(PHI3)
      S23=SIN(PHI3-PHI2)
      C23=COS(PHI3-PHI2)
      CT=SQRT(S23*S23/(F2*F2+F3*F3-DTWO*F2*F3*C23))
      T=CT/S23
      SD=(F2*S3-F3*S2)*T
      CD=(F3*C2-F2*C3)*T
!
! NON-COULOMB PHASE SHIFT
!
      DEL=ATAN2(SD,CD)
      T=(PHI2+DEL)/PI
      M1=INT(T,SP)
      EM1=M-M1
      DEL=EM1+DEL/PI
!      f2norm=sin(phi2+del*pi)*a2
!      f2=f2*a2*ct
!
! NORMALISE FR
!
      IF(FR(I0).LT.DZERO)CT=-CT
      C=C*CT
!
      IF(.NOT.BREL)THEN
!        TLAM=L
        DO I=1,I1
          FR(I)=CT*FR(I)
        ENDDO
!        write(mw0,*)l,c,fr(1)/dx(1)**(l+1)
      ELSE
!        TLAM=L
        T=DONE
        IF(RNUK.GT.DZERO)T=T+DQUART*DALF*(EI+ZS(1))
        T=DONE/SQRT(T)
        C=C*T
!
! THE FOLLOWING BOTH TRANSFORMS SOLUTION AND CORRECTS NORMALIZATION
!
! (RENORMALIZING FOR OMITTED SMALL CPT IS MINOR IMPROVEMENT AT BEST
!  AT MEDIUM Z, BUT VERY POOR AT HIGH Z.)
!
!        if(brel2)then
        TQ=DQUART
        DE=DONE
!          de=((done+dhalf*dalf*ei)/(done+dquart*dalf*ei))**.25
!        else                  !try and compensate for missing small cpt
!          tq=dquart           !formal renormalization
!          de=sqrt((done+dhalf*dalf*ei)/(done+dquart*dalf*ei))
!          tq=dhalf            !sampson e->e-v
!          de=done
!        endif
!
!        w=done                !standard Darwin
!        if(kappa.ne.0)w=-2.   !see also pmvdar
!
        DO I=1,I1
          T=DONE+TQ*DALF*(EI+ZL(I)+DTWO*VSC(I)-Z1/DX(I))  !INV TRANSFORM
          t=abs(t)
          GR(I)=T
          T=SQRT(T)
!          t=t**(w/dtwo)
          FR(I)=CT*DE*T*FR(I)
        ENDDO
!      call dnamp(a2,amp2,e,ci1,qq,u,zt,x1,nnmax,jmax)
!      phi2=phasex(e,ci1,qq,u,lm,zt,x1)
!      fnorm=sin(phi2+del*pi)*e**.25/ei**.5 !a2
!      write(mw6,*)l,ei,x1,x2,f2/f2norm,fr(i1)/fnorm
!
! SMALL COMPONENT
!
        IF(BREL2)THEN
          tkap=-1
          if(kappa.ne.0)tkap=kappa
!
          CALL DIFF(FR,DA,MNH,DHNS,MJH0)
!
          DO I=1,I1
!   gr(i)=done+dquart*dalf*(ei+zl(i)+dtwo*vsc(i)-z1/dx(i)) !tq.ne.dquart
            GR(I)=DHALF*DFSC*(DA(I)+tkap*FR(I)/DX(I))/GR(I)
!          if(e.gt.0.)write(mw6,*)i,t!fr(i)**2+gr(i)**2*4*e/(dalf*ei**2)
          ENDDO
!      gnorm=dhalf*dfsc*cos(phi2+del*pi)*ei**.5/e**.25 !a2*ei/e**.5
!      write(mw6,*)l,ei,x1,gr(i1)/gnorm
        ENDIF
      ENDIF
!
! REMOVE FINITE NUCLEUS
!
      DO I=1,INUK
        T=ZL(I)
        ZL(I)=DNUK(I)
        DNUK(I)=T-dnuk(i)
      ENDDO
!
!      write(70,700)l,e,c,a1,i0,dx(i0),fr(i0),i1,dx(i1),fr(i1)
! 700  format(i5,1p,3e15.8,i5,2e15.8,i5,2e15.8)
!      write(mw6,700)l,e,c,a1,i0,dx(i0),fr(i0),i1,dx(i1),fr(i1)
!      do i=1,i1
!        write(mw6,700)i,dx(i),fr(i)
!      enddo
!
!-----------------------------------------------------------------------
!
 1500 CONTINUE
!
! LOCAL
      IF(BREL2)THEN
!
        DEALLOCATE(DA,STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'FCF6: DE-ALLOCATION FAILS FOR DA,'
          NF=0
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN                                              !NORMAL RETURN
!
!-----------------------------------------------------------------------
!
 1600 L=-999                                              !FLAG ABORT
!
      GO TO 1500
!
!-----------------------------------------------------------------------
!
10010 FORMAT('E=',F10.4,' RYD',5X,'L=',I3,5X,'X1=',F10.6,5X,'RAT=',F8.5,&
     &       5X,                                                        &
     &    'X1 TOO SMALL, SHORT-RANGE POTENTIALS STILL TOO LARGE IN FCF6'&
     &    )
10020 FORMAT(//'*** SR.FCF6: E=',F10.4,' RYD',5X,'L=',I3,5X,            &
     &       ' UNABLE TO DETERMINE AMP-PHASE, INCREASE MAXB1 OR',       &
     &       ' INCREASE STEP-LENGTH')
10030 FORMAT(' WARNING, PLASMA SCREENING POTENTIAL MAY CAUSE INACCURACY'&
     &       ,' IN EVALUATION OF AMP-PHASE FOR E=',F10.4,' RYD',5X,'L=',&
     &       I3,5X,'X2=',2F10.6)
10040 FORMAT(//'SR.FCF6: BOTH STARTING VALUES OF F ARE ZERO, NUMERICAL '&
     &       ,'INTEGRATION JUST RETURNS A NULL FUNCTION FOR'/'E=',F10.4,&
     &       ' RYD',5X,'L=',I3,5X,'AT INNER TURNING POINT X0=',F10.4)
10050 FORMAT('*** SR.FCF6: CONTINUUM FUNCTION NOT DETERMINABLE FOR L,', &
     &       ' E :',I6,F10.4)
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION WILT(T,E,ZZ,CI)
!
      REAL(WP) T,E,ZZ,CI,WILT
!
      WILT=E-(ZZ+CI*T)*T
!
      END FUNCTION WILT
!-----------------------------------------------------------------------
!
      END SUBROUTINE FCF6
!
!                             *******************
!
      FUNCTION FDIP(EK1,L1,EK2,L2,IFAIL)
!
!-----------------------------------------------------------------------
!
! FN.FDIP:
!    CALCULATES THE FUNCTION I(KAPPA1,L1,KAPPA2,L2,1)
!    DEFINED IN PHIL. TRANS. ROY. SOC. A226, 255, (1970),
!    WHERE EK1=KAPPA1**2 AND EK2=KAPPA2**2.
!    IT IS SUITABLE FOR USE IN EQUATIONS (8),(9),(10) OR (11) OF
!    J. PHYS. B. 7, L364, (1974).
! ALAN BURGESS DEPT. OF APPLIED MATHS. AND THEORETICAL PHYSICS,CAMBRIDGE
!
! NRB: ADDED FDIPA ASYMPTOTIC OPTION FOR EXTREME CASES
!
!  IT IS CALLED BY:
!    SR.TOP1
!
!  IT CALLS:
!    FN.FDIP0
!    FN.FDIP1
!    FN.FDIP2
!    FN.FDIPA
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (D1O6=DSIXTH)
      PARAMETER (D1O34=DONE/(DTWO*D7TEEN))
      PARAMETER (EPS=D1M4)
!
!-----------------------------------------------------------------------
!
      IPRINT=IFAIL
!
      IF(EK1+EK2.LT.D1M40)THEN
        FDIP=DZERO
        IFAIL=1
        IF(IPRINT.EQ.-2)WRITE(MW6,10010)IFAIL
        RETURN
      ENDIF
!
      IF(EK1.LE.EK2)THEN
        EMIN=EK1
        EMAX=EK2
      ELSE
        EMIN=EK2
        EMAX=EK1
      ENDIF
!
      T=EMIN/EMAX
!
      IF(T.LT.D1O6)THEN
        FDIP=FDIP1(EK1,L1,EK2,L2)
        IF(FDIP*FDIP.LT.D1M40.AND.T.GT.D1O34)FDIP=FDIP2(EK1,L1,EK2,L2)
      ELSE
        FDIP=FDIP2(EK1,L1,EK2,L2)
      ENDIF
!
      IF(FDIP*FDIP.LT.D1M40)THEN
        IFAIL=2
        IF(IPRINT.EQ.-2)WRITE(MW6,10010)IFAIL
        RETURN
      ENDIF
!
      IF(FDIP.LT.DZERO.OR.FDIP.GT.DONE)THEN
        IFAIL=3
        IF(IPRINT.EQ.-2)WRITE(MW6,10010)IFAIL
        FDIP=DZERO
        RETURN
      ENDIF
!
      IFAIL=0
      FA=FDIPA(EK1,L1,EK2,L2)
!
      IF(FA.EQ.DZERO)THEN
        FA=FDIP0(EK1,L1,EK2,L2,EPS,IFAIL)
        IFAIL=-IFAIL
        IF(FA.EQ.DZERO)RETURN
      ENDIF
!
      RAT=FDIP/FA
      IF(RAT.GT.DTEN)THEN
        IFAIL=4
        IF(IPRINT.EQ.-2)WRITE(MW6,10010)IFAIL
        FDIP=DZERO
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT('***FDIP FAILURE: IFAIL=',I2)
!
!-----------------------------------------------------------------------
!
      END FUNCTION FDIP
!
!                             *******************
!
      FUNCTION FDIP0(EK1,L1,EK2,L2,EPS,IFAIL)
!
!-----------------------------------------------------------------------
!
! FN.FDIP0:
!    CALCULATES THE FUNCTION I0(K1,L1,K2,L2,1)
!    DEFINED IN PHIL. TRANS. ROY. SOC. A266,255,1970,
!    WHERE EK1=K1*K1, EK2=K2*K2,
!    AND THE RELATIVE ACCURACY IS APPROXIMATELY EPS.
!    IT IS SUITABLE FOR USE IN EQUATIONS (13) ETC. OF
!    J. PHYS. B. 7,L364, (1974)
! ALAN BURGESS, DEPT OF APPLIED MATHS. AND THEORETICAL PHYSICS,CAMBRIDGE
!
! NRB - IFAIL
!     - REWORKED CONVERGENCE TEST, CASE MODEST EPS.
!
!  IT IS CALLED BY:
!    SR.FDIP
!    SR.TOP1
!
!  IT CALLS:
!    FN.F21
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
      IPRINT=IFAIL
      IFAIL=0
      BTWO=.FALSE.
!
      IF(L1.LT.L2)THEN
        L=L1
      ELSEIF(L1.GT.L2)THEN
        L=L2
      ELSE
        IF(IPRINT.EQ.-2)WRITE(MW6,10010)L1
        IFAIL=1
        FDIP0=DZERO
        L=0                            !JUST SUPPRESS NOT INIT. WARNINGS
        RETURN
      ENDIF
!
      EL=L
      FDIP0=DHALF/(EL+DONE)
!
      IF(EK1.LT.EK2)THEN
        E=EK1/EK2
        P=L1-L
      ELSEIF(EK1.GT.EK2)THEN
        E=EK2/EK1
        P=L2-L
      ELSE
        E=DZERO                        !JUST SUPPRESS NOT INIT. WARNINGS
        P=DZERO                        !JUST SUPPRESS NOT INIT. WARNINGS
        RETURN
      ENDIF
!
      FDIP0=FDIP0*E**((EL+P+DHALF)*DHALF)
!
! TO OBTAIN THE FUNCTION EK1 OF M.J. SEATON, PROC. PHYS. SOC. A68,457,
! 1955, REMOVE THE 'C' ON THE NEXT LINE.
!     FDIP0=DONE
!
      IF(E.GE.DHALF)THEN
!
        P1=P-DHALF
        T=P1*(EL+DONE)*(E-DONE)
        I0=L+1
        H0=DZERO
!
        DO I=1,I0
          TI=I
          H0=H0+DONE/TI
        ENDDO
!
        X=DONE-E
        H=DONE-(P+P+H0+LOG(DQUART*X))
        S=DONE+T*H
        A=EL+DONE
        Y=P1
        C=DONE
        D=DZERO
!
   50   A=A+DONE
        Y=Y+DONE
        C=C+DONE
        D=D+DONE
        T=T*A*Y*X/(C*D)
        H=H+P1/(D*Y)+EL/(C*A)
        T1=T*H
        S=S+T1
!
        IF(ABS(T1).GE.EPS*ABS(S))THEN
          BTWO=.FALSE.
          IF(C.LT.D300)GO TO 50
          IF(IPRINT.EQ.-2)WRITE(MW6,10020)
          IFAIL=2
!          FDIP0=DZERO
!          RETURN
        ENDIF
!
        IF(BTWO)THEN
          FDIP0=FDIP0*S
        ELSE
          BTWO=.TRUE.
          GO TO 50
        ENDIF
!
      ELSE
!
        A=EL+DONE
        Y=P-DHALF
        C=EL+P+D3HALF
!
        F=F21(A,Y,C,E,EPS,IFAIL)
!
        L=L+1
        EL=L
!
        IF(P.LE.DHALF)THEN
          C1=EL+EL+DONE
        ELSE
          C1=DONE
        ENDIF
!
        DO I=1,L
          AI=I
          AII=AI+AI
          C1=C1*AI*AI*DFOUR/(AII*(AII+DONE))
        ENDDO
!
        FDIP0=FDIP0*F*C1
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(' FAILED IN FDIP0, L1=L2=',I5)
10020 FORMAT(' FAILED TO CONVERGE IN FDIP0')
!
!-----------------------------------------------------------------------
!
      END FUNCTION FDIP0
!
!                             *******************
!
      FUNCTION FDIP1(EK1,L1,EK2,L2)
!
!-----------------------------------------------------------------------
!
! FN.FDIP1 EVALUATES DIPOLE INTERGALS IN TERMS OF MONOPOLE INTEGRALS -
!          SEE EQU (A3) OF BHT(1970)  - CASE EMAX/EMIN.GT.6.
!
!  IT IS CALLED BY:
!    SR.FDIP
!
!  IT CALLS:
!    FN.FMON1
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
      IF(L1.LT.L2)THEN
        L=L1
        A1=EK1
        A2=EK2
      ELSEIF(L1.GT.L2)THEN
        L=L2
        A1=EK2
        A2=EK1
      ELSE
        FDIP1=DZERO
        RETURN
      ENDIF
!
      LP=L+1
      ELP=LP
!
      T1=SQRT(DONE+ELP*ELP*A2)*FMON1(EK1,EK2,L)
      T2=SQRT(DONE+ELP*ELP*A1)*FMON1(EK1,EK2,LP)
!
      IF(T1*T2.LT.D1M40)THEN
        FDIP1=DZERO
      ELSE
        FDIP1=(T1-T2)/ELP
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION FDIP1
!
!                             *******************
!
      FUNCTION FDIP2(EK1,L1,EK2,L2)
!
!-----------------------------------------------------------------------
!
! EVALUATE DIPOLE INTERGALS IN TERMS OF MONOPOLE INTEGRALS -
! SEE EQU (A3) OF BHT(1970) - CASE EMAX/EMIN.LT.6.
! NRB: BASED ON ALAN'S ORIGINAL.
!
!  IT IS CALLED BY:
!    SR.FDIP
!
!  IT CALLS:
!    SR.ARGAM
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
      PI=ACOS(-DONE)
      WMAX=D200
      DBIG=HUGE(DBIG)/D1P30
!
      ETA1=DONE/SQRT(EK1)
      ETA2=DONE/SQRT(EK2)
      W1=ETA2-ETA1
      A=ABS(W1)
      PIA=PI*A
!
      IF(PIA.LE.D1M2)THEN
        C=DTHREE/(DTHREE-PIA*(DTHREE-PIA*(DTWO-PIA)))
        C=SQRT(C)
      ELSEIF(PIA.GE.D4TEEN)THEN
        C=SQRT(PIA+PIA)
      ELSE
        PIA=PIA+PIA
        C1=DONE-EXP(-PIA)
        C=SQRT(PIA/C1)
      ENDIF
!
      C=C/(SQRT(ETA1*ETA2)*DTWO)
      C2=ETA1+ETA2
      C1=DFOUR*ETA1*ETA2/(C2*C2)
!
      IF(L2.LE.L1)THEN
        L=L2
        T1=ETA1
        ETA1=ETA2
        ETA2=T1
        W1=-W1
      ELSE
        L=L1
      ENDIF
!
      C=C*C1**(L+1)
      U0=L+1
      U1=ETA1
      V0=U0
      V1=-ETA2
      W0=DONE
      X0=W1/(C2*C2)
      Y2=-ETA2-ETA2
      Y0=-U0*W1+Y2
      Y1=ETA2*W1
      T1=X0/(DONE+W1*W1)
      Z0=U0*T1
      Z1=U1*T1
      T=Z0-Z1*W1
      Z1=Z0*W1+Z1
      Z0=T
      S0=-DONE+Z0*Y0-Z1*Y1
      S1=Z0*Y1+Z1*Y0
      X=W1*X0
!
  100 U0=U0+DONE
      V0=V0+DONE
      W0=W0+DONE
!
      IF(W0.GT.WMAX.OR.T1.GT.DBIG)THEN
        FDIP2=DZERO
        RETURN
      ENDIF
!
      Y0=Y0+Y2
      T=Z0*U0-Z1*U1
      Z1=Z0*U1+Z1*U0
      Z0=T
      T=Z0*V0-Z1*V1
      Z1=Z0*V1+Z1*V0
      Z0=T
      T=Z0*W0-Z1*W1
      Z1=Z0*W1+Z1*W0
      Z0=T
      X0=X/(W0*(W0*W0+W1*W1))
      Z0=Z0*X0
      Z1=Z1*X0
      T0=Z0*Y0-Z1*Y1
      T1=Z0*Y1+Z1*Y0
      S0=S0+T0
      S1=S1+T1
      T1=T0*T0+T1*T1
      T0=S0*S0+S1*S1
!
      IF(T0.LT.D1P24*T1)GO TO 100
!
      J1=0
      J2=L+1
      P=ARGAM(REAL(J1,WP),W1)+ARGAM(REAL(L,WP),ETA1)                    &
     &  -ARGAM(REAL(J2,WP),ETA2)
!      IW0=W0
      IF(A.GT.D1M40)P=P+W1*LOG(C2/A)
!
      P0=COS(P)
      P1=SIN(P)
      T=P0*S0-P1*S1
      S1=P0*S1+P1*S0
      S0=T
      FDIP2=C*S1
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION FDIP2
!
!                             *******************
!
      FUNCTION FDIPA(EK1,L1,EK2,L2)
!
!-----------------------------------------------------------------------
!
! FN.FDIPA EVALUATES ASYMPTOTIC EXPRESSIONS FOR I(KAPPA1,L1,KAPPA2,L2,1)
!          BASED ON A40,1 OF BHT. NRB
!
!  IT IS CALLED BY:
!    SR.FDIP
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
      IF(EK1*EK2.LT.D1M50)THEN
        FDIPA=DZERO
        RETURN
      ENDIF
!
      X1=DONE/SQRT(EK1)
      X2=DONE/SQRT(EK2)
      X12=ABS(X1-X2)
      IF(X12.GT.D100)THEN
        FDIPA=DZERO
        RETURN
      ENDIF
!
      PI=ACOS(-DONE)
      X12P=EXP(PI*X12/DTWO)
!
      IF(EK1.LE.EK2)THEN
!
        E=EK1/EK2
        IF(L1.LE.L2)THEN
          L=L1
          GO TO 100
        ELSE
          L=L2
          GO TO 200
        ENDIF
!
      ELSE
!
        E=EK2/EK1
        IF(L1.LE.L2)THEN
          L=L1
          GO TO 200
        ELSE
          L=L2
          GO TO 100
        ENDIF
!
      ENDIF
!
! A40
!
  100 TL=L
      T0=DONE-E
      IF(TL*T0.LT.E)THEN
        FDIPA=DZERO
        RETURN
      ENDIF
!
      T=PI*TL
      EE=SQRT(E)
      F0=SQRT(T*T0*EE)*EE**L
      TL=L+L+1
      FDIPA=F0*X12P/TL
      RETURN
!
! A41
!
  200 T0=DONE-E
      TL=L
      IF(TL*T0.LT.E)THEN
        FDIPA=DZERO
        RETURN
      ENDIF
!
      T0=DONE/T0
      T=TL*PI
      EE=SQRT(E)
      F0=SQRT(T*T0*EE)*EE**(L+1)
      TL=L+L+1
      TL2=L+L+3
      FDIPA=F0*X12P/(TL*TL2)
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION FDIPA
!
!                             *******************
!
      SUBROUTINE FILON(L,V,RMAX,IMAX,F,FB,FO)
!
!-----------------------------------------------------------------------
!
!  SR.FILON EVALUATES BORN INETGRALS USING FILON'S RULE.
!
!  A. BURGESS, DAMTP, CAMBRIDGE - SEE ALSO J.PHYS.B30, 33 (1997).
!
!  IT IS CALLED BY:
!    SR.ROMB
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(XP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      REAL(WP) V,RMAX,F,FB,FO
!
      PARAMETER (X8P6=XEIGHT*X1P6)
!
      DIMENSION F(0:*)
!
!-----------------------------------------------------------------------
!
      H=RMAX/IMAX
      A0=XONE
!
      IF(L.GT.0)THEN
        DO I=1,L
          A0=(I+I+1)*A0
        ENDDO
        A0=XONE/A0
        A1=XONE/(L*4+6)
        A2=A1/(L*8+20)
        TT=L*XQUART
      ELSE
        S2=XZERO
        S3=XZERO
        T1=XONE/5040
        TT=X1M1
      ENDIF
!
      R=XZERO
      S0=XZERO
      S1=XZERO
      V2=V*V
!
      DO I=1,IMAX
!
        R=R+H
        T=V*R
        IF(T.LT.TT)THEN
          T2=T*T
          IF(L.GT.0)THEN
            T1=((A2*T2-A1)*T2+XONE)*A0
            DO K=1,L
              T1=R*T1
            ENDDO
          ELSE
            T0=((42-T2)*T2-840)*T1*R*R
            T2=V2*T0+XONE
          ENDIF
        ELSE
          IF(T.LT.X8P6)THEN
            S=SIN(T)
            C=COS(T)
          ELSE
            S=XZERO
            C=XZERO
          ENDIF
          IF(L.EQ.0)THEN
            T2=S/T
            T0=(T2-XONE)/V2
          ELSE
            U=XONE/T
            T1=(S*U-C)*U
            IF(L.GT.1)THEN
              T0=S*U
              DO K=1,L-1
                T2=(2*K+1)*T1*U-T0
                T0=T1
                T1=T2
              ENDDO
            ENDIF
            U=XONE/V
            DO K=1,L
              T1=T1*U
            ENDDO
          ENDIF
        ENDIF
!
        T=F(I)
        IF(MOD(I,ITWO).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
!
      ENDDO
!
      T=V*H
      IF(T.LE.X0PT3)THEN
        T2=T*T
        A0=(T2*10-108)*T2+378
        C0=(54-T2)*T2-1512
        IF(L.GT.0)THEN
          A=(A0*T2+1890)/2835
          C=(C0*T2+15120)/11340
        ELSE
          A0=A0*H*H/2835
          A=A0*V2+X2THRD
          C0=C0*H*H/11340
          C=C0*V2+X4THRD
        ENDIF
      ELSE
        IF(T.LT.X8P6)THEN
          S=SIN(T)
          C=COS(T)
          T0=C*C
        ELSE
          S=XZERO
          C=XZERO
          T0=XHALF
        ENDIF
        T1=XONE/T
        T2=T1*T1
        A=(XONE+T0-XTWO*S*C*T1)*T2*XTWO
        C=(S*T1-C)*T2*XFOUR
        IF(L.EQ.0)THEN
          C0=(C-X4THRD)/V2
          A0=(A-X2THRD)/V2
        ENDIF
      ENDIF
!
      IF(L.GT.0)THEN
        FB=(A*S0+C*S1)*H
        FO=XZERO
      ELSE
        FO=(A*S2+C*S3)*H
        FB=((S0*XTWO+S1*XFOUR)/XTHREE+A0*S2+C0*S3)*H
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE FILON
!
!                             *******************
!
      SUBROUTINE FILONW(L,V,dx,mnh,dhns,mjh,maxrs,F,FB,FO)
!
!-----------------------------------------------------------------------
!
!  SR.FILONW IS AN ADAPTATION OF
!  SR.FILON, WHICH EVALUATES BORN INETGRALS USING FILON'S RULE.
!  (A. BURGESS, DAMTP, CAMBRIDGE - SEE ALSO J.PHYS.B30, 33 (1997))
!  TO USE THE STANDARD SS/AS DOUBLING MESH.
!  IT ASSUMES AN EVEN NUMBER OF STEPS MNH(JH) FOR JH=1,MJH
!  WHICH IS THE NORM.
!
!*** SET PARAMETER:
!
!  XJAY0 = 1 TO RETAIN THE DELTA(LAMBDA,0) SUBTRACTION FACTOR (AS FILON)
!  XJAY0 = 0 TO OMIT THE DELTA(LAMBDA,0) FACTOR
!
!  IT IS CALLED BY:
!    SR.RK4PI
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(XP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      REAL(WP) V,dx,dhns,F,FB,FO
!
      PARAMETER (X8P6=XEIGHT*X1P6)
!
      PARAMETER (XJAY0=XZERO)
!
      DIMENSION F(maxrs),dx(maxrs),dhns(mjh),mnh(mjh)
!
!-----------------------------------------------------------------------
!
      ih=0
      fo=xzero
      fb=xzero
!
      A0=XONE
!
      IF(L.GT.0)THEN
        DO I=1,L
          A0=(I+I+1)*A0
        ENDDO
        A0=XONE/A0
        A1=XONE/(L*4+6)
        A2=A1/(L*8+20)
        TT=L*XQUART
      ELSE
        S2h=XZERO
!        S3=XZERO
!        T1=XONE/5040
        TT=X1M1
      ENDIF
!
!      H=RMAX/IMAX
!      R=XZERO
      S0h=XZERO
!      S1=XZERO
      V2=V*V
!
      do jh=1,mjh
!
        h=dhns(jh)
        imax=mnh(jh)
        s0=s0h
        S1=XZERO
        IF(L.EQ.0)THEN
          s2=s2h
          S2h=XZERO
          S3=XZERO
          T1=XONE/5040                  !reset as overwritten later...
        ENDIF
!
        DO I=1,IMAX
!
          ih=ih+1
          R=dx(ih)
          T=V*R
          IF(T.LT.TT)THEN
            T2=T*T
            IF(L.GT.0)THEN
              T1=((A2*T2-A1)*T2+XONE)*A0
              DO K=1,L
                T1=R*T1
              ENDDO
            ELSE
              T0=((42-T2)*T2-840)*T1*R*R
              t0=t0+(xone-xjay0)/v2
              T2=V2*T0+xjay0
            ENDIF
          ELSE
            IF(T.LT.X8P6)THEN
              S=SIN(T)
              C=COS(T)
            ELSE
              S=XZERO
              C=XZERO
            ENDIF
            IF(L.EQ.0)THEN
              T2=S/T
              T0=(T2-xjay0)/V2
            ELSE
              U=XONE/T
              T1=(S*U-C)*U
              IF(L.GT.1)THEN
                T0=S*U
                DO K=1,L-1
                  T2=(2*K+1)*T1*U-T0
                  T0=T1
                  T1=T2
                ENDDO
              ENDIF
              U=XONE/V
              DO K=1,L
                T1=T1*U
              ENDDO
            ENDIF
          ENDIF
!
          T=F(Ih)
          IF(MOD(I,ITWO).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
!
        ENDDO
!
        IF(MOD(Ih,ITWO).EQ.0)THEN
          IF(L.EQ.0)THEN
            s0h=t*t0/2
            S0=-s0h+S0
            s2h=t*t2/2
            S2=-s2h+S2
          ELSE
            s0h=t*t1/2
            S0=-s0h+S0
          ENDIF
        ELSE
          if(jh.lt.mjh)stop 'filonw: mesh error - should be even steps'
        ENDIF
!
        T=V*H
        IF(T.LE.X0PT3)THEN
          T2=T*T
          A00=(T2*10-108)*T2+378
          C0=(54-T2)*T2-1512
          IF(L.GT.0)THEN
            A=(A00*T2+1890)/2835
            C=(C0*T2+15120)/11340
          ELSE
            A00=A00*H*H/2835
            A=A00*V2+X2THRD
            C0=C0*H*H/11340
            C=C0*V2+X4THRD
          ENDIF
        ELSE
          IF(T.LT.X8P6)THEN
            S=SIN(T)
            C=COS(T)
            T0=C*C
          ELSE
            S=XZERO
            C=XZERO
            T0=XHALF
          ENDIF
          T1=XONE/T
          T2=T1*T1
          A=(XONE+T0-XTWO*S*C*T1)*T2*XTWO
          C=(S*T1-C)*T2*XFOUR
          IF(L.EQ.0)THEN
            C0=(C-X4THRD)/V2
            A00=(A-X2THRD)/V2
          ENDIF
        ENDIF
!
        IF(L.GT.0)THEN
          FB=fb+(A*S0+C*S1)*H
          FO=XZERO
        ELSE
          FO=fo+(A*S2+C*S3)*H
          FB=fb+((S0*XTWO+S1*XFOUR)/XTHREE+A00*S2+C0*S3)*H
        ENDIF
!
      enddo
!
      if(l.gt.0)fb=fb*v**l             !standard filon omits this factor
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE FILONW
!
!                             *******************
!
      SUBROUTINE FIT(A0,M,H,A,C)
!
!-----------------------------------------------------------------------
!
!  N.R.BADNELL D.A.M.T.P. CAMBRIDGE
!
!  SR.FIT FITS A RADIAL FUNCTION NEAR THE ORIGIN BY A POWER SERIES.
!  INPUT TABULATED FUNCTION A(I) WITH I .GE. 5, STEP H AND BEHAVIOUR
!  A0*X**M FOR X SMALL.
!  OUTPUT C(I) (I.GT.5 UNDEFINED) A POWER SERIES EXPANSION OF FORM
!  (A0+C(1)*X+..............C(5)*X**5)*X**M
!  NOTE THAT A0 IS CORRECT LEADING ORDER TERM AND IS NOT REDEFINED.
!  THIS FIT IS DERIVED FROM ALAN BURGESS'S SR.YLAM.
!
!  IT IS CALLED BY:
!    SR.RADCON
!    SR.RADCX0
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION A(5),C(5)
!
!-----------------------------------------------------------------------
!
      X1=H
      C1=A(1)/X1**M-A0
      X2=X1+H
      C2=A(2)/X2**M-A0
      X3=X2+H
      C3=A(3)/X3**M-A0
      X4=X3+H
      C4=A(4)/X4**M-A0
      X5=X4+H
      C5=A(5)/X5**M-A0
!
      H1=DONE/H
      Z=H1/120
      C(1)=(600*(C1-C2)+400*C3-150*C4+24*C5)*Z
      Z=H1*Z
      C(2)=(-770*C1+1070*C2-780*C3+305*C4-50*C5)*Z
      Z=H1*Z
      C(3)=(355*C1-590*C2+490*C3-205*C4+35*C5)*Z
      Z=H1*Z
      C(4)=(-70*C1+130*C2-120*C3+55*C4-10*C5)*Z
      Z=H1*Z
      C(5)=(5*C1+10*(C3-C2)-5*C4+C5)*Z
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE FIT
!
!                             *******************
!
      SUBROUTINE FLGL1(KC,KMAX,NF,JYI,JYF,QLMC,BAM,MAXEL)
!
!-----------------------------------------------------------------------
!
!  SR.FLGL1: EXPANDS THE ENERGY MATRIX ELEMENT <CASL! H !C'A'SL>
!  IN TERMS OF TWO SORTS OF RADIAL INTEGRALS, EQ.1.6,7,8 IN E&N,
!  AND CALCULATES THE COEFFICIENTS AS DESCRIBED IN SECT.3.2 OF E&N
!
!**THIS VERSION DETERMINES THE SLATER STATE INTERACTIONS ONLY,
!  FOR A GIVEN SLP  -  NRB.
!
!  INPUT: KMAX CONFIGURATIONS C.
!  AM(J)=TRUE FOR ALL SLST J WITH TOTAL MS,ML OTHER THAN CONSIDERED.
!  NF VALENCE ELECTRONS, NW CORE ELECTRONS.
!  2*ML , 2*MS OF I'TH ELECTRON IN J'TH SLATER STATE
!            =QLMC(I,J)  +-1, IF QLMC EVEN
!            =QLMC(I,J)-1++1, IF QLMC ODD
!  QCG(I,K)=G OF I'TH ELECTRON IN K'TH CONF; G=1,2,3.. FOR 1S,2S,
!  2P..  IF NOT REDEFINED, GENERALLY NK=QN(K),LK=QL(K)/2.
!  FOR THE CORE  NNL(I)=G, NNL(I+MAXCL)=QLMC AS ABOVE, (I=1,NW)
!  KC IS CONFIG OF FIRST SYMMETRY, USED FOR CORE.
!
!  OUTPUT: COEFFICIENTS DRKS(J) AND ARGUMENT-ADRESSES L=NRKS(J) STORED
!  SEQUENTIALLY FROM IRKS0 ONWARDS; ARGUMENTS QRLS(1...5,L)=A,B,C,D,LD
!  TEMPORARILY LISTED IN NEW SECTION OF REF.-LIST FROM IRLS00 ONWARDS
!  AT THE END ALL QRLS THAT HAD PREVIOUSLY BEEN LISTED ARE CANCELLED.
!  QLMC(K,1) IS USED AS BUFFER (K=1,2,..NF.LE.ME),  AM(1) IS I/O.
!
!  IT IS CALLED BY:
!    SR.ALGEB2
!
!  IT CALLS:
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!    FN.VCC
!
!  IT CONTAINS:
!    FN.MVC
!
!-----------------------------------------------------------------------
!
      USE COMMON_ALGEB,  ONLY: BFANO
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_CFCT,   ONLY: VCA,VCB,MXLL,MAXLL0,MAXLL1,BVC,BDLBD
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DXRLS,  ONLY: DRKS,DEKS,QRLS,NRKS,BFALLS
      USE COMMON_DXRLS,  ONLY: IRKS,IRKS0,IRLS,IRLS0
      USE COMMON_NSTS,   ONLY: NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT
!
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL2, ONLY: MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX                     &
     &                        ,MXBORB,MXVORB,MXFORB,NGRP
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M6)
!
      DIMENSION BAM(*),QLMC(MAXEL,*),JYI(*),JYF(*)                      &
     &         ,Q1(2,2),MM(2,2),Q3(2,2),Q4(2,2)                         &
     &         ,NEN(2,2),NEJ(2),MRL(5),NEK(2)
!
      ALLOCATABLE :: IGRGR(:)
!
      POINTER :: MJ11,MJ12,ML
      TARGET :: MM,MRL
!
      MJ11=>MM(1,1)
      MJ12=>MM(1,2)
      ML=>MRL(5)
!
!      EQUIVALENCE (MJ11,MM(1,1)),(MJ12,MM(1,2)),(ML,MRL(5))
!
!-----------------------------------------------------------------------
!
      BPLANT=MXORB.LT.67.OR.SP.EQ.8
      JPLANT(1)=0
      BSKP=MXLL.EQ.-1
      BKUTOO=KUTOO.NE.0
!
      ALLOCATE(IGRGR(MXORB))
!
      DO I=1,MB                                                     !MB0
        IGRGR(I)=I
      ENDDO
!
! INITIALIZE
!
      IRLS=0
      IRKS=0
      NCF=0
      NADS(0)=0
!
      IDIR=0                                               !ALLOW DIRECT
      IXCH=0                                              !ALLOW ECHANGE
!t      idir=1
!t      ixch=1
!
      MXLAM=ABS(MAXLAM)                             !MAX MULTIPOLE VALUE
      NMULT=NMULTE-1                              !LIMIT NO OF MULIPOLES
!
      IF(NADS(-1).EQ.-1)THEN
        NE=NF
        NF=0
        BEQCFS=.TRUE.
        KF1=KC
        KG1=KC
      ELSE
        KF1=1
        KG1=1
      ENDIF
!
! LOOP OVER ALL CONFIG PAIRS
!
  100 DO KF=KF1,KMAX
!
        JA=JYI(KF)
        JB=JYF(KF)
        NEK(1)=KF
!
        DO KG=KG1,KF
!
          IF(NF.NE.0)THEN
            NCF=NCF+1
            BSKPCF=NADS(NCF).LT.0     !KF AND/OR KG NOT CONTRIB
            NADS(NCF)=NADS(NCF-1)
            IF(BSKPCF)GO TO 300
!
            BEQCFS=KG.EQ.KF
          ENDIF
!
! COMPUTE COEFFICIENTS A AND B (SEE E+N SECTION 3.2, DO55 AND DO57
! ARE THE TWO SUMMATIONS OVER SLATER STATES IN EQ.3.17).
!
          IRLS00=IRLS
          IRLS1=IRLS00+1
          IRKS00=IRKS+1
! EVTL IF(BAM(1))  IRLS00=0
          DDA=DONE
          DDB=DZERO
!
          JAP=JYI(KG)
          JBP=JYF(KG)
          NEK(2)=KG
!
! BEGIN MAIN SLATER-STATE LOOPS OVER 55 AND 57
!
          DO J=JA,JB
!
            IF(BAM(J))GO TO 220
            NEJ(1)=J
            IF(BEQCFS)JBP=J
            IF(NF.EQ.0)JAP=J
!
            DO JD=JAP,JBP
!
              IF(BAM(JD))GO TO 200
              DDH=DONE
!
! THIS NEXT STATEMENT RESOLVES INTERACTIONS BY SLATER STATE, NOT TERM
!OLD      IRKS0=IRKS+1
!
              DO I=IRLS1,IRLS
                IORIG(I)=0
                JORIG(I)=0
              ENDDO
!
              BEQTMS=NF.EQ.0   !NEED EQUI AND NON-EQUI CASES
!
              NEJ(2)=JD
              NK=0
              NU=-NW
              IF(JD.EQ.J)GO TO 115           !SO BEQCFS=.TRUE.
              IF(NF.EQ.0)STOP 'FLGL1: NF=0????'    !GO TO 57
!
! CALCULATE NK-THE NUMBER OF INDIVIDUAL SETS IN WHICH SLATER
! STATE JD DIFFERS FROM J; THE PHASE FACTOR THAT RESULTS FROM
! THE REMAINING NF-NK SETS WILL BE ABSORBED INTO DDH:
!
              MU=0
              DO I=1,NF
                KB=QLMC(I,J)
                KA=QCG(I,KF)
                KAC=IEQ(KA)
                DO L=1,NF
                  IF(QLMC(L,JD).NE.KB)GO TO 102
                  IF(IEQ(QCG(L,KG)).NE.KAC)GO TO 102
                  LP=L
                  IGRGR(KA)=QCG(L,KG)
                  GO TO 104
  102           ENDDO
                NK=NK+1
                IF(NK.GT.2)GO TO 200
                NEN(1,NK)=I
                MU=I+MU
                LP=0
  104           QLMC(I,1)=INT(LP,QP)
              ENDDO
!
              K=0
              DO L=1,NF
                DO I=1,NF
                  IF(QLMC(I,1).EQ.L)GO TO 105
                ENDDO
                K=K+1
                NEN(2,K)=L
                MU=L+MU
                IF(K.EQ.NK)GO TO 110
  105         ENDDO
!
  110         DDH=(1-2*MOD(MU,ITWO))*DDH
!
              IF(NK.EQ.2)GO TO 135
!
! NOW NK=1, WHICH IMPLIES NDP1.NE.ND1
              N1=NEN(1,1)
              N2=NEN(2,1)
              IF(N1.EQ.0.OR.N2.EQ.0)THEN
                WRITE(MW6,*)
                WRITE(MW6,*)'***SR.FLGL1: DUPLICATE CONFIGURATIONS',KF, &
     &                      ' AND',KG,' ????'
                WRITE(MW0,*)'SR.FLGL1: DUPLICATION CONFIGURATIONS?'
                NF=-1
                GO TO 400
              ENDIF
!
!      if(nk.eq.1)go to 75                !assume cancel with 2-bdy ml=0
              ML=QCG(N1,KF)
              MU=QCG(N2,KG)
              IF(QL(MU).NE.QL(ML))GO TO 115
              IF(QN(ML).GE.90.AND.QN(MU).GE.90)GO TO 115
              IF(.NOT.BSKP)DDA=DDH
!
              DDB=DZERO
              IF(MU.GE.ML)THEN
                LP=ML
                ML=MU
                MU=LP
              ENDIF
              MRL(1)=ML
              MRL(2)=-0
              MRL(3)=MU
              MRL(4)=-0
              ML=-1
              BFALL0=.FALSE.
              GO TO 155
!
  115         IF(DDH.EQ.DZERO)GO TO 200
!
              IF(.NOT.BEQTMS.AND.BEQCFS)NU=0
!
  120         NU=NU+1
              IF(NU.GT.NF)GO TO 190
              NEN(1,2)=NU
              IF(NK.NE.0)GO TO 130
              ND=NU
              IF(ND*NF.LT.0)ND=0
  125         ND=ND+1
              IF(ND.GT.NF)GO TO 120
              NEN(1,1)=ND
  130         IF(NEN(1,1).EQ.NEN(1,2))GO TO 185
!
  135         IMT=0
!                                       !test - need to exc kcor as well
!      nval=0                                     !test - exclude "core"
              kp0=1
              DO L=1,2
                !=1 FOR SLATER STATES J (OF CONFIG KF),=2 FOR JD (OF KG)
                I=L
                DO K=1,2
                 !=1 FOR FOR FIRST PAIR OF ELECTRON STATES,=2 FOR SECOND
                  IF(NK.LT.K)I=1
                  KP=NEN(I,K)
                  IF(KP.LE.0)THEN
                    KP=KP+NW
                    LP=NNL(KP,1)
                    if(irlx.lt.0.and.nf.gt.0)then     !srlx core-valence
                      kp0=-1
                      if(l.eq.1)kk=kf
                      if(l.eq.2)kk=kg
                      ng=icfgp(kk)
                      lp=lp+(ng-1)*mxborb    !re-map non-unique core orb
                    endif
                    MU=NNL(KP,2)
                  ELSE
                    LP=NEJ(I)
                    MU=QLMC(KP,LP)
                    LP=NEK(I)
                    LP=QCG(KP,LP)
                    IF(QN(LP).GE.90)IMT=IMT+1
                    IF(IMT.GT.1)GO TO 185
                  ENDIF
                  ML=((QL(LP)+MU)/2)*2-QL(LP)
                  Q4(L,K)=INT((MU-ML)*2-1,QP)
                  Q3(L,K)=INT(ML,QP)
                  MM(L,K)=QL(LP)
                  Q1(L,K)=INT(LP,QP)
!          if(qn(lp).ge.80)nval=nval+1            !test - exclude "core"
                ENDDO
              ENDDO
!      if(nval.ne.2)go to 65                      !test - exclude "core"
              IF(NK.EQ.1.and.kp0.gt.0)Q1(2,2)=INT(IGRGR(Q1(2,2)),QP)
!
! DIRECT
!
              KP=0
!
! EQU  MJ11=Q2(1,1)
! EQU  MJ12=Q2(1,2)
              MM11=-Q3(1,1)
              MM12=-Q3(1,2)
              MV11=MVC(MJ11,MM11)
              MV12=MVC(MJ12,MM12)
!
              IF(IDIR.EQ.1)GO TO 180                          !NO DIRECT
!
! EXCHANGE RE-ENTRY POINT
!
  140         IF(.NOT.BSKP.AND.Q4(2,1+KP).NE.Q4(1,1))GO TO 180
!
              MJ21=MM(2,KP+1)
              MJ22=MM(2,2-KP)
!
! MU=MAX LAM
              MU=MIN(MJ11+MJ21,MJ12+MJ22)
              MP=MOD(MU/ITWO+MXLAM,ITWO)      !ALIGN
              MU=MIN(MU,ITWO*(MXLAM-MP))
!
! ML=MIN LAM
              ML=MAX(ABS(MJ11-MJ21),ABS(MJ12-MJ22))
!
! LIMIT NUMBER
              MU=MIN(MU,ML+IFOUR*NMULT)
!
! AGAIN (SEE BELOW) ORBIT-ORBIT "LESS RESTRICTIVE" -
!    add .not.BKUTOO !!!!!      HOW I MISSED THIS FOR SO LONG...
              IF(.not.BKUTOO.and..not.BEQTMS.and.KP+NK+ML.EQ.0)ML=4
              IF(ML.GT.MU)GO TO 180
!
!      if(ml.eq.0.and.kp.eq.0.and.nk.eq.1)go to 10  !assume cancel ml=-1
!
              IF(.NOT.BSKP)THEN
                MM21=Q3(2,KP+1)
                MMD1=MM21+MM11
                MM22=Q3(2,2-KP)
                MMD2=MM12+MM22
!
! INCREASE MIN LAM BECAUSE OF ML1-ML2
                K=MAX(ABS(MMD1),ABS(MMD2))
!
! ORBIT-ORBIT LAM+1, SO "LESS RESTRICTIVE" -
!                                  THIS WAS IN MY ORIGINAL CODING OF O-O
                IF(BKUTOO)K=K-2
                IF(K.GT.ML)ML=((K+2-ML)/4)*4+ML
                IF(ML.GT.MU)GO TO 180
!
                DSJ=SQRT(REAL((MJ11+1)*(MJ12+1)*(MJ21+1)*(MJ22+1),WP))  &
     &              *REAL((1-MOD(ABS(MM22-MM11),IFOUR))*(1-2*KP),WP)*DDH
!
                MV21=MVC(MJ21,MM21)
                MV22=MVC(MJ22,MM22)
              ENDIF
!
! REORDER A,B,C,D IN AS MUCH FALLING ORDER AS SYMMETRY ALLOWS FOR
!
              L=0
              K=0
              IF(Q1(2,2-KP).GT.Q1(1,2))K=2               !FO
              I=0
              IF(Q1(2,1+KP).GT.Q1(1,1))I=2               !FO
              BFALL0=BKUTOO.AND.I+K.EQ.2
!
  145         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 145              !FO
!
! LAMBDA RE-ENTRY POINT
!
  150         IF(.NOT.BSKP)THEN
                LP=ML/4+1
                IF(BVC.OR.(MJ11.LE.MXLL.AND.MJ21.LE.MXLL))THEN
                  DDA=VCA(MV11,MV21,LP)
                  IF(BKUTOO)DDB=VCB(MV11,MV21,LP)
                ELSE
                  DVC=VCC(MJ11,MJ21,ML,IZERO,IZERO,IZERO)
                  DDA=DVC*VCC(MJ11,MJ21,ML,MM11,MM21,MMD1)/(ML+1)
                  IF(BKUTOO)DDB=DVC*VCC(MJ11,MJ21,ML+2,MM11,MM21,MMD1)
                ENDIF
                IF(BVC.OR.(MJ22.LE.MXLL.AND.MJ12.LE.MXLL))THEN
                  DDA=DDA*VCA(MV22,MV12,LP)
                  IF(BKUTOO)DDB=DDB*VCB(MV22,MV12,LP)
                ELSE
                  DVC=VCC(MJ22,MJ12,ML,IZERO,IZERO,IZERO)
                  DDA=DDA*DVC*VCC(MJ22,MJ12,ML,MM22,MM12,MMD2)/(ML+1)
                  IF(BKUTOO)DDB=DDB*DVC*VCC(MJ22,MJ12,ML+2,MM22,MM12,   &
     &                          MMD2)
                ENDIF
!
                IF(ABS(DDA)+ABS(DDB).EQ.DZERO)GO TO 175
!
                IF(BFANO)THEN
                  IFANO=QL(Q1(2,1+KP))-QL(Q1(1,1))
                  IF(MRL(5).GE.0)IFANO=IFANO+QL(Q1(2,2-KP))-QL(Q1(1,2))
                  IFANO=IFANO/4
                  IFANO=1-2*mod(abs(IFANO),ITWO)          !(-1)**IFANO
                  DDA=DDA*IFANO
                  IF(BKUTOO)DDB=DDB*IFANO
                ENDIF
!
                DDA=DDA*DSJ
                IF(BKUTOO)DDB=DDB*DSJ
              ENDIF
!
! STORE CONTRIBUTION TO (EXISTING) COEFFICIENT
!
  155         IF(BPLANT)IPLANT=MRL(5)                                   &
     &                         /2+((((MRL(4)*MXORB+MRL(3))*MXORB+MRL(2))&
     &                         *MXORB)+MRL(1))*100
!
!      if(qn(mrl(1)).lt.80)go to 84          !test - exclude "core"
!
              DO I=IRLS1,IRLS
                IF(.NOT.BPLANT)THEN
                  DO K=5,1,-1
                    IF(MRL(K).NE.QRLS(K,I))GO TO 160
                  ENDDO
                ELSE
                  IF(IPLANT.NE.JPLANT(I))GO TO 160
                ENDIF
                IF(BEQTMS)THEN
                  LP=-I
                  K=JORIG(I)
                ELSE
                  LP=I
                  K=IORIG(I)
                ENDIF
                IF(K.GT.0)THEN
                  DRKS(K)=DDA+DRKS(K)
                  IF(BKUTOO)THEN
                    DEKS(K)=DDB+DEKS(K)
                    IF(BFALLS(K).NEQV.BFALL0)THEN
                      WRITE(MW6,*)'FLGL1: PROBLEM WITH ORBIT-ORBIT ALG.'
                      WRITE(MW0,*)'FLGL1: PROBLEM WITH ORBIT-ORBIT ALG.'
                      NF=-1
                      GO TO 400
                    ENDIF
                  ENDIF
                  GO TO 170
                ENDIF
!  83  CONTINUE
                GO TO 165
  160         ENDDO
!
! CANNOT FIND OLD SET OF ARGUMENTS, SO START CONSTRUCTING A NEW SET
!
              LP=IRLS+1
              IF(LP.GT.IXRLS)THEN                             !GO TO 999
!
                IXXX=7*(IXRLS/5+1)
!
                WRITE(MW6,*)'*** FLGL1: increasing MXRLS from ',IXRLS,  &
     &                      ' to: ',IXXX
                WRITE(MW0,*)'*** FLGL1: increasing MXRLS from ',IXRLS,  &
     &                      ' to: ',IXXX
!
                CALL RE_ALLOC2(QRLS,IONE,IFIVE,IONE,IXRLS,IFIVE,IXXX,   &
     &                         IERR)
!
                IF(IERR.NE.0)THEN
                  WRITE(MW0,*)'FLGL1: RE-ALLOCATION FAILS FOR QRLS'
                  NF=0
                  GO TO 400
                ENDIF
!
                IXXX0=MAX(IXRLS,IAXRL)
                IXXX2=MAX(IXXX,IAXRL)
                IF(IXXX2.GT.IXXX0)CALL RE_ALLOC(IORIG,IONE,IXXX0,IXXX2, &
     &             IERR)
                CALL RE_ALLOC(JORIG,IONE,IXRLS,IXXX,IERR)
                CALL RE_ALLOC(JPLANT,IONE,IXRLS,IXXX,IERR)
!
                IF(IERR.NE.0)THEN
                  WRITE(MW0,*)                                          &
     &               'FLGL1: RE-ALLOCATION FAILS FOR IORIG,JORIG,JPLANT'
                  NF=0
                  GO TO 400
                ENDIF
!
                IXRLS=IXXX
!
              ENDIF
!
              IRLS=LP
              DO K=1,5
                QRLS(K,LP)=INT(MRL(K),QP)
              ENDDO
              IF(BPLANT)JPLANT(LP)=IPLANT
!
              IF(BEQTMS)LP=-LP
!
!      K=-IRKS
  165         IRKS=IRKS+1
              IF(IRKS.GT.IXRKS)THEN                           !GO TO 999
!
                IXXX=7*(IXRKS/5+1)
!
                WRITE(MW6,*)'*** FLGL1: increasing MXRKS from ',IXRKS,  &
     &                      ' to: ',IXXX
                WRITE(MW0,*)'*** FLGL1: increasing MXRKS from ',IXRKS,  &
     &                      ' to: ',IXXX
!
                CALL RE_ALLOC(DRKS,IONE,IXRKS,IXXX,IERR)
                IF(BKUTOO)THEN
                  CALL RE_ALLOC(DEKS,IONE,IXRKS,IXXX,IERR)
                  CALL RE_ALLOC(BFALLS,IONE,IXRKS,IXXX,IERR)
                ENDIF
!
                IF(IERR.NE.0)THEN
                  WRITE(MW0,*)'FLGL1: RE-ALLOCATION FAILS FOR DRKS,DEKS'
                  NF=0
                  GO TO 400
                ENDIF
!
                CALL RE_ALLOC(NRKS,IONE,IXRKS,IXXX,IERR)
                CALL RE_ALLOC(NSTJ,IONE,IXRKS,IXXX,IERR)
                CALL RE_ALLOC(NSTJD,IONE,IXRKS,IXXX,IERR)
!
                IF(IERR.NE.0)THEN
                  WRITE(MW0,*)'FLGL1: RE-ALLOCATION FAILS FOR NRKS,NSTJ'
                  NF=0
                  GO TO 400
                ENDIF
!
                IXRKS=IXXX
!
              ENDIF
!
              DRKS(IRKS)=DDA
              IF(BKUTOO)THEN
                DEKS(IRKS)=DDB
                BFALLS(IRKS)=BFALL0
              ENDIF
!
              IF(LP.GT.0)THEN
                IORIG(LP)=IRKS
                JORIG(LP)=0
              ELSE
                JORIG(-LP)=IRKS
              ENDIF
!
              NRKS(IRKS)=LP
              NSTJ(IRKS)=J
              NSTJD(IRKS)=JD
!
  170         CONTINUE
!
!      write(mw6,998)  j,jd,nk,lp,kp, mrl,dda
! 998  format(5i5,4x,5i3,2f12.5)
!
              IF(ML.LT.0)GO TO 120
  175         ML=ML+4
              IF(ML.LE.MU)GO TO 150                  !NEXT LAMBDA
!
  180         KP=KP+1+IXCH
              IF(KP.EQ.1)GO TO 140                   !EXCHANGE
!
  185         IF(NK.LT.1)GO TO 125
              IF(NK.EQ.1)GO TO 120
!
  190         IF(J.EQ.JD.AND..NOT.BEQTMS)THEN        !SO BEQCFS=.TRUE.
                BEQTMS=.TRUE.
                NU=-NW
                GO TO 115
              ENDIF
!
!
  200       ENDDO         !END INNER SLATER-STATE LOOP
!
  220     ENDDO          !END OUTER SLATER-STATE LOOP
!
!
! ELIMINATE COEFFICIENTS /DRKS/.LT.TYNY AND ARGUMENTS QRLS THAT HAVE
! BEEN LISTED BEFORE IN THE REFERENCE LIST
!
!  89  IF(KF.GT.0)GO TO 98
          IF(IRKS.LT.IRKS00)GO TO 300
!
          K=IRKS00-1
          KP=0
          DO I=IRLS1,IRLS
            IORIG(I)=0
          ENDDO
!
          DO I=IRKS00,IRKS
!
            JD0=NRKS(I)
            JD=ABS(JD0)
            DD=ABS(DRKS(I))
            IF(BKUTOO)DD=DD+ABS(DEKS(I))
            IF(ABS(DD).LT.TYNY)THEN
              IF(IORIG(JD).GT.0)GO TO 260
              JD0=0           !RE-INDEX QRLS AS MAY OCCUR LATER
              GO TO 230
            ENDIF
!
            K=K+1
            DRKS(K)=DRKS(I)
            IF(BKUTOO)THEN
              DEKS(K)=DEKS(I)
              BFALLS(K)=BFALLS(I)
            ENDIF
            NSTJ(K)=NSTJ(I)
            NSTJD(K)=NSTJD(I)
!
  230       IF(JD.LE.IRLS00)THEN
              IF(IRLS.LE.MXRLS)THEN
                                  !SHOULD NOT GET HERE
                WRITE(MW6,*)'FLGL1: INFORM NRB OF STOP HERE'
                WRITE(MW0,*)'FLGL1: INFORM NRB OF STOP HERE'
                NF=-1
                GO TO 400
              ELSE      !GRACEFUL EXIT TO DIMENSION STOP
                LP=JD
                GO TO 240
              ENDIF
            ENDIF
!
            IF(IORIG(JD).EQ.0)THEN
              LP=JD-KP
              DO L=1,IRLS00
                DO J=1,5
                  IF(QRLS(J,JD).NE.QRLS(J,L))GO TO 235
                ENDDO
                KP=KP+1
                IORIG(JD)=L
                LP=L
                GO TO 240
  235         ENDDO
            ELSE
              LP=IORIG(JD)
              GO TO 240
            ENDIF
!
            IORIG(JD)=LP
            DO J=1,5
              QRLS(J,LP)=QRLS(J,JD)
            ENDDO
!
  240       IF(JD0.NE.0)THEN
              NRKS(K)=LP
              IF(JD0.LT.0)NRKS(K)=-NRKS(K)
            ENDIF
!
  260     ENDDO
!
          IRLS=IRLS-KP
          IRKS=K
!  98  CONTINUE
          NADS(NCF)=IRKS
!
          IF(NF.EQ.0)THEN
            NADS(-1)=0
            NF=NE
            KF1=1
            KG1=1
            GO TO 100
          ENDIF
!
!
  300   ENDDO                 !END OF INNER CF LOOP
!
      ENDDO                  !END OF OUTER CF LOOP
!
!-----------------------------------------------------------------------
!
  400 DEALLOCATE(IGRGR)
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION MVC(M1,M2)
!
      INTEGER(SP) M1,M2,MVC
!
      MVC=((M1+2)*M1/2+M2)/2+1
!
      END FUNCTION MVC
!-----------------------------------------------------------------------
!
      END SUBROUTINE FLGL1
!
!                             *******************
!
      SUBROUTINE FLGL2(mam,nam,KK)
!
!-----------------------------------------------------------------------
!
!  SR.FLGL2 EXPANDS THE ENERGY MATRIX ELEMENT <CASL! H !C'A'SL>
!  IN TERMS OF TWO SORTS OF RADIAL INTEGRALS, EQ.1.6,7,8 IN E&N,
!  AND CALCULATES THE COEFFICIENTS AS DESCRIBED IN SECT.3.2 OF E&N
!
!  INPUT: KK INDEXES KF,KG CONFIGURATION C,C'
!  DRKS, NRKS CONTAIN AND INDEX SLATER STATE INTERACTIONS BETWEEN
!  SLATER STATES J AND JD ASSOCIATED WITH C AND C' - NRB;
!  DC(J+ND2)=VCC OF J'TH SLATERSTATE TO TERM ND2
!  DC(JD+NDP2)       JD
!
!  OUTPUT: COEFFICIENTS DRL(J) AND ARGUMENT-ADRESSES L=NRK(J) STORED
!  SEQUENTIALLY FROM IRK0 ONWARDS; ARGUMENTS QRL(1...5,L)=A,B,C,D,LD
!  TEMPORARILY LISTED IN NEW SECTION OF REF.-LIST FROM IRL00 ONWARDS
!  AT THE END ALL QRL THAT HAD PREVIOUSLY BEEN LISTED ARE CANCELLED.
!
!  IT IS CALLED BY:
!    SR.ALGEB2
!
!  IT CALLS:
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!
!-----------------------------------------------------------------------
!
!!      COMMON /BASIC/NF,KF,KG,JGAP(4),ND1,NDP1,ND2,NDP2,NGAP
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,IBSK4=>IBSK4,IBSK5=>IBSK5      &
     &              ,IBSK6=>IBSK6,IBSK7=>IBSK7,ND1=>IBSK8,NDP1=>IBSK9   &
     &              ,ND2=>IBSK10,NDP2=>IBSK11,IBSK12=>IBSK12
      USE COMMON_DC,     ONLY: BFAST,DC
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL
      USE COMMON_DXRL,   ONLY: IRK,IRK0,IOS,IOS0
      USE COMMON_DXRLS,  ONLY: DRKS,DEKS,QRLS,NRKS,BFALLS
      USE COMMON_DXRLS,  ONLY: IRKS,IRKS0,IRLS,IRLS0
      USE COMMON_NSTS,   ONLY: NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT
!
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX                     &
     &                        ,MXBORB,MXVORB,MXFORB,NGRP
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M8)
      PARAMETER (TTYNY=TYNY/D1P3)
!
      DIMENSION mam(*),nam(*)
!
!-----------------------------------------------------------------------
!
      BKUTOO=KUTOO.NE.0
      DDB=DZERO
!
      IRL00=IRL                                 !EVTL IF(AM(1))  IRL00=0
!
      DO J=1,IRLS
        JORIG(J)=0
      ENDDO
!
      BEQCFS=KG.EQ.KF
      BEQTMS=NDP1.EQ.ND1
!
!p      IF(KK.EQ.0.AND.IRLX.LT.0)THEN       !UNPACK
!p        NGRP=-IRLX/100000                  !UNTIL /NRBORB/ IN A MODULE
!p        MXBORB=-IRLX-100000*NGRP
!p      ELSE
!p        MXBORB=0
!p      ENDIF
!
!      write(mw6,*)'kf=',kf,'  kg=',kg
!
! BEGIN MAIN LOOP OVER SLATER INTERACTIONS
!
!      m0=0
!      t0=dzero
!      md0=0
!      td0=dzero
      K0=NADS(KK-1)+1
!
      DO KS=K0,NADS(KK)
!
        J=NSTJ(KS)
        JD=NSTJD(KS)
!
        II=NRKS(KS)
        IF(J.EQ.JD)THEN
          IF(BEQTMS.AND.II.GT.0)GO TO 100
          IF(.NOT.BEQTMS.AND.II.LT.0)GO TO 100
          II=ABS(II)
        ENDIF
!
        IF(BFAST)THEN
          DDH=DC(J+ND2)*DC(JD+NDP2)
          IF(BEQCFS.AND.JD.NE.J)DDH=DC(J+NDP2)*DC(JD+ND2)+DDH
        ELSE
!          write(mw6,*)m,md
          m=mam(j)
          md=nam(jd)
          if(m.gt.0.and.md.gt.0)then             !m*md can over flow I*4
!          if(m.ne.m0)then
!            t0=dc(m)
!            m0=m
!          endif
!          if(md.ne.md0)then
!            td0=dc(md)
!            md0=md
!          endif
!          DDH=t0*td0
            DDH=DC(m)*DC(md)
          else
            ddh=dzero
          endif
          IF(BEQCFS.AND.JD.NE.J)then
            md=mam(jd)
            m=nam(j)
            if(m.gt.0.and.md.gt.0)then           !m*md can over flow I*4
              DDH=DC(md)*DC(m)+DDH
            endif
          endif
        ENDIF
!
        DDA=DDH*DRKS(KS)
        IF(BKUTOO)DDB=DDH*DEKS(KS)
        IF(ABS(DDA)+ABS(DDB).LT.TTYNY)GO TO 100
!        write(mw6,*)ks,j,jd,ddh,drks(ks),dda
!
        LP=JORIG(II)
        IF(LP.GT.0)THEN
          K=IORIG(LP)
          DRK(K)=DRK(K)+DDA
!          write(mw6,*)lp,k,drk(k)
          IF(BKUTOO)THEN
            DEK(K)=DDB+DEK(K)
            IF(BFALL(K).NEQV.BFALLS(KS))THEN
              WRITE(MW6,*)'FLGL2: PROBLEM WITH ORBIT-ORBIT ALG.'
              WRITE(MW0,*)'FLGL2: PROBLEM WITH ORBIT-ORBIT ALG.'
              NF=-1
              GO TO 300
            ENDIF
          ENDIF
        ELSE
!
!     CANNOT FIND AN OLD SET OF ARGUMENTS EQUAL TO THE NEW SET, SO
!     MUST START CONSTRUCTING A NEW COEFFICIENT.
!
          LP=IRL+1
          IF(LP.GT.IAXRL)THEN                                  !GO TO 90
!
            IXXX=7*(IAXRL/5+1)
!
            WRITE(MW6,*)'*** FLGL2: increasing MAXRL from ',IAXRL,      &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** FLGL2: increasing MAXRL from ',IAXRL,      &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC2(QRL,IONE,IFIVE,IONE,IAXRL,IFIVE,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'FLGL2: RE-ALLOCATION FAILS FOR QRL'
              NF=0
              GO TO 300
            ENDIF
!
            IXXX0=MAX(IAXRL,IXRLS)
            IXXX2=MAX(IAXRL,IXXX)
            IF(IXXX2.GT.IXXX0)CALL RE_ALLOC(IORIG,IONE,IXXX0,IXXX2,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'FLGL2: RE-ALLOCATION FAILS FOR IORIG'
              NF=0
              GO TO 300
            ENDIF
!
            IAXRL=IXXX
!
          ENDIF
!
          IRK=IRK+1
          IF(IRK.GT.IAXRK)THEN                                 !GO TO 90
!
            IXXX=7*(IAXRK/5+1)
!
            WRITE(MW6,*)'*** FLGL2: increasing MAXRK from ',IAXRK,      &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** FLGL2: increasing MAXRK from ',IAXRK,      &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC(DRK,IONE,IAXRK,IXXX,IERR)
            IF(BKUTOO)THEN
              CALL RE_ALLOC(DEK,IONE,IAXRK,IXXX,IERR)
              CALL RE_ALLOC(BFALL,IONE,IAXRK,IXXX,IERR)
            ENDIF
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'FLGL2: RE-ALLOCATION FAILS FOR DRK,DEK'
              NF=0
              GO TO 300
            ENDIF
!
            CALL RE_ALLOC(NRK,IONE,IAXRK,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'FLGL2: RE-ALLOCATION FAILS FOR NRK'
              NF=0
              GO TO 300
            ENDIF
!
            IAXRK=IXXX
!
          ENDIF
!
          IRL=LP
          DO K=1,5
            QRL(K,LP)=QRLS(K,II)
          ENDDO
          JORIG(II)=LP
          IORIG(LP)=IRK
          NRK(IRK)=LP
          DRK(IRK)=DDA
          IF(BKUTOO)THEN
            DEK(IRK)=DDB
            BFALL(IRK)=BFALLS(KS)
          ENDIF
!          write(mw6,*)-lp,irk,drk(irk)
!
!p          IF(MXBORB.NE.0)THEN     !DUPLICATE CORE FOR EACH GROUP
          IF(KK.EQ.0.AND.IRLX.LT.0)THEN   !DUPLICATE CORE FOR EACH GROUP
            DO N=1,NGRP-1
              LP=LP+1             !ASSUME INITIAL ALLOC O.K. FOR CORE...
              DO K=1,4
                QRL(K,LP)=QRL(K,IRL)+INT(N*MXBORB,QP)
              ENDDO
              QRL(5,LP)=QRL(5,IRL)
            ENDDO
            IRL=LP
          ENDIF
!
        ENDIF
!
  100 ENDDO
!
!     ELIMINATE COEFFICIENTS /DRK/.LT.TYNY AND ARGUMENTS QRL THAT HAVE
!     BEEN LISTED BEFORE IN THE REFERENCE LIST
!
!      IF(IRK.LT.IRK0)GO TO 90
      K=IRK0-1
      KP=0
!
      DO I=IRK0,IRK
!
        JD=INT(NRK(I),SP)
        DD=ABS(DRK(I))
        IF(BKUTOO)DD=DD+ABS(DEK(I))
!
        IF(ABS(DD).LT.TYNY)THEN
          IF(JD.GT.IRL00)KP=KP+1
          GO TO 200
        ENDIF
!
        K=K+1
        DRK(K)=DRK(I)
        IF(BKUTOO)THEN
          DEK(K)=DEK(I)
          BFALL(K)=BFALL(I)
        ENDIF
!
        LP=JD
        IF(JD.GT.IRL00)THEN
          LP=JD-KP
          DO L=1,IRL00
            DO J=1,5
              IF(QRL(J,JD).NE.QRL(J,L))GO TO 120
            ENDDO
            KP=KP+1
            LP=L
            GO TO 150
  120     ENDDO
          DO J=1,5
            QRL(J,LP)=QRL(J,JD)
          ENDDO
        ENDIF
!
  150   NRK(K)=LP
!
  200 ENDDO
!
      IRL=IRL-KP
      IRK=K
!
!-----------------------------------------------------------------------
!
  300 RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE FLGL2
!
!                             *******************
!
      SUBROUTINE FLGLX0(KK,QLMC,MAXEL1)
!
!-----------------------------------------------------------------------
!
!  SR.FLGLX0 CHECKS WHICH SLATER-STATES OF TWO CFS DIFFER BY ZERO OR ONE
!  PAIR, AND SETS POINTERS TO THEM FOR LATER USE BY FLGLX1.
!
!  IT IS CALLED BY:
!    SR.ALGXLS
!
!  IT CALLS:
!    SR.RE_ALLOC
!
!-----------------------------------------------------------------------
!
!!      COMMON /BASIC/NF,KF,KG,JA,JB,JAP,JBP,JGAP(5)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,JA=>IBSK4,JB=>IBSK5            &
     &              ,JAP=>IBSK6,JBP=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9    &
     &              ,IBSK10=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
!
      USE COMMON_NRBFL0, ONLY: KINTI,KINTF,KEN2,KPTCFM,KINT,MPOINT
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION QLMC(MAXEL1,*),NEN(2,2)
!
      ALLOCATABLE :: BTEMP(:,:),KTEMP(:),LTEMP(:),MTEMP(:)              &
     &              ,JTEMP(:),NTEMP(:)
!
!-----------------------------------------------------------------------
!
      NF1=NF+1
      NF2=NF*NF
!
      BEQCFS=KG.EQ.KF
!
! LOCAL (SMALL)
!
      ALLOCATE(BTEMP(NF,NF),KTEMP(NF2+1),LTEMP(NF2),MTEMP(NF))
      ALLOCATE(JTEMP(NF),NTEMP(NF))
!
      DO L=1,NF
        J=QCG(L,KG)
        JTEMP(L)=IEQ(J)
        K=QCG(L,KF)
        NTEMP(L)=IEQ(K)
      ENDDO
!
      K=0
      DO I=NF,1,-1
        DO L=NF,1,-1
          BTEMP(L,I)=JTEMP(L).EQ.NTEMP(I)
          IF(BTEMP(L,I))THEN
            K=K+1
            LTEMP(K)=L
            KTEMP(K)=I
          ENDIF
        ENDDO
      ENDDO
      KTEMP(K+1)=0
      KMX=K
!
      DEALLOCATE(JTEMP,NTEMP)
!
! INITIALIZE GROUP RANGES
!
      IXD02=QCL0/2
!
      MG2=IXD02
      MG1=-IXD02
!
      MG2P=IXD02
      MG1P=-IXD02
!
! LOOP OVER INITIAL ML GROUPS OF CONFIG KF
!
      DO MG=MG2,MG1,-1
!
        M1=MPOINT(MG+1,KF)+1                      !SLATER-STATE RANGE
        M2=MPOINT(MG,KF)
!
! LOOP OVER FINAL MLP GROUPS OF CONFIG KG
!
        IF(BEQCFS)MG1P=MG
!
        DO MGP=MG2P,MG1P,-1
!
          M1P=MPOINT(MGP+1,KG)+1                  !SLATER-STATE RANGE
          M2P=MPOINT(MGP,KG)
!
! LOOP OVER INITIAL SLATER STATES OF ML
!
          DO M=M1,M2
!
            J=M
!
! LOOP OVER FINAL SLATER STATES OF MLP
!
            IF(BEQCFS.AND.MG.EQ.MGP)M2P=M
!
            DO MP=M1P,M2P
!
              JD=MP
!
              NEN2=0
              IF(JD.EQ.J)GO TO 20             !SO BEQCFS=.TRUE.
!
              NK=1                            !FOR CONTINUUM PAIR
              DO K=1,2                        !INITIALIZE NK=1 CONT-CONT
                NEN(K,1)=NF1
              ENDDO
!
! DETERMINE THE SECOND PAIR OF INDIVIDUAL SETS IN WHICH SLATER
! STATE JD DIFFERS FROM J, AND THE PHASE FACTOR THAT RESULTS FROM
! THE REMAINING NF-2 SETS:
!
              NEN(1,2)=0
              MU=0
              DO I=1,NF
                MTEMP(I)=0
              ENDDO
!
! CASES WHERE ORBITAL NL'S MATCH
!
              I0=0
              DO K=1,KMX
                I=KTEMP(K)
                L=LTEMP(K)
                IF(I.NE.I0)THEN                   !NEED TO CHECK L STILL
                  IF(QLMC(L,JD).EQ.QLMC(I,J))THEN
                    MTEMP(I)=L
                    I0=I
                  ELSEIF(KTEMP(K+1).NE.I)THEN     !HAVE MOVED TO A NEW I
                    NK=NK+1
                    IF(NK.GT.2)GO TO 25
                    NEN(1,NK)=I                   !NEN(1,2)
                    MU=I+MU
                  ENDIF
                ENDIF
              ENDDO
!
! CASES WHERE ORBITALS DO NOT MATCH, SEE IF A DIFFERENCE
! HAS ALREADY BEEN FLAGGED, IF NOT, DO SO.
!
              DO I=NF,1,-1
                IF(MTEMP(I).EQ.0.AND.NEN(1,2).NE.I)THEN
                  DO L=NF,1,-1
                    IF(.NOT.BTEMP(L,I))THEN
                      NK=NK+1
                      IF(NK.GT.2)GO TO 25
                      NEN(1,NK)=I                  !NEN(1,2)
                      MU=I+MU
                      GO TO 5
                    ENDIF
                  ENDDO
                ENDIF
    5         ENDDO
!
              K=1                           !0->1 SINCE CONT-CONT IS ONE
              DO L=NF,1,-1
                DO I=NF,1,-1
                  IF(MTEMP(I).EQ.L)GO TO 10
                ENDDO
                K=K+1
                NEN(2,K)=L                         !NEN(2,2)
                MU=L+MU
                IF(K.EQ.NK)GO TO 15
   10         ENDDO
!
   15         IPHASE=(1-2*MOD(MU,ITWO))               !*IPHASE
!
!  NK.EQ.2 HERE
!
              IF(NK.NE.2)THEN
                WRITE(MW6,*)'SR.FLGLX0: ERROR, SHOULD NOT BE HERE',KF,  &
     &                      KG,J,JD
                STOP 'FLGLX0: ERROR, SHOULD NOT BE HERE'
              ENDIF
!
              NEN2=NF1*NEN(1,2)+NEN(2,2)
              NEN2=NEN2*IPHASE
!
! FLAG THIS PAIR AS INTERACTING (TBD DON'T BOTHER TO STORE J=JD CASE?)
!
   20         KINT=KINT+1
              IF(KINT.GT.IXSTX)THEN               !COULD PACK FURTHER...
!
                IXXX=7*(IXSTX/5)
!
                WRITE(MW6,*)'*** FLGLX0: increasing MXSTX from ',IXSTX, &
     &                      ' TO: ',IXXX
                WRITE(MW0,*)'*** FLGLX0: increasing MXSTX from ',IXSTX, &
     &                      ' TO: ',IXXX
!
                CALL RE_ALLOC(KINTI,IONE,IXSTX,IXXX,IERR)
                CALL RE_ALLOC(KINTF,IONE,IXSTX,IXXX,IERR)
                CALL RE_ALLOC(KEN2,IONE,IXSTX,IXXX,IERR)
!
                IF(IERR.NE.0)THEN
                  WRITE(MW0,*)'FLGLX0:RE-ALLOCATION FAILS FOR KINTI etc'
                  NF=0
                  GO TO 100
                ENDIF
!
                IXSTX=IXXX
!
              ENDIF
!
              KINTI(KINT)=J
              KINTF(KINT)=JD
              KEN2(KINT)=NEN2
!              WRITE(MW6,*)KF,J,'  **  ',KG,JD
!
   25         CONTINUE
!
            ENDDO           !END FINAL ML SLATER STATE LOOP
!
          ENDDO           !END INITIAL ML SLATER STATE LOOP
!
          KPTCFM(MGP,MG,KK)=KINT
          IF(BEQCFS)KPTCFM(MG,MGP,KK)=KINT
!
        ENDDO           !END FINAL MLP GROUP LOOP FOR KG
!
      ENDDO           !END INITIAL ML GROUP LOOP FOR KF
!
  100 DEALLOCATE(BTEMP,KTEMP,LTEMP,MTEMP)
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE FLGLX0
!
!                             *******************
!
      SUBROUTINE FLGLX1(QLMC,NAM,MAXEL1)
!
!-----------------------------------------------------------------------
!
!  SR.FLGLX1 CALCULATES THE SLATER-STATE ELECTROSTATIC AND, OPTIONALLY,
!  ORBIT-ORBIT INTERACTION BETWEEN PAIRS OF ELECTRONS, ONE PAIR BEING
!  CONTINUUM.
!
!  IT IS CALLED BY:
!    SR.ALGXLS
!
!  IT CALLS:
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!    FN.VCC
!
!  IT CONTAINS:
!    FN.MVC
!
!-----------------------------------------------------------------------
!
      USE COMMON_ALGEB,  ONLY: BFANO
!!      COMMON /BASIC/NF,KF,KG,JA,JB,JAP,JBP,ND1,NDP1,LI,LF,MGAP
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,JA=>IBSK4,JB=>IBSK5            &
     &              ,JAP=>IBSK6,JBP=>IBSK7,ND1=>IBSK8,NDP1=>IBSK9       &
     &              ,LI=>IBSK10,LF=>IBSK11,IBSK12=>IBSK12
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_CFCT,   ONLY: VCA,VCB,MXLL,MAXLL0,MAXLL1,BVC,BDLBD
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DXRLS,  ONLY: DRKS,DEKS,QRLS,NRKS,BFALLS
      USE COMMON_DXRLS,  ONLY: IRKS,IRKS0,IRLS,IRLS0
      USE COMMON_NSTS,   ONLY: NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,INAST0=>NASTB                            &
     &                        ,INASTJ0=>NASTJB,LFACT,JFACT              &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDW1, ONLY: MXORB,ma0,mb0
      USE COMMON_NRBDW2, ONLY: LCONDW,MTS,MTSP,MTL,MTLP,MTP,LCONDWJ,MTJ &
     &                        ,LVMIN,LVMAX
      USE COMMON_NRBDW3, ONLY: DVC12O=>DVC12,ICLRR,BLX,BEQUALM
!T      USE COMMON_NRBDWX, ONLY: MAXLX0
      USE COMMON_NRBFL0, ONLY: KINTI,KINTF,KEN2
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M6)
!
      INTEGER(SP) Q1(2,2),MM(2,2),Q3(2,2),Q4(2,2)
!
      DIMENSION  QLMC(MAXEL1,*),NAM(*)                                  &
     &          ,NEN(2,2),NEJ(2),MRL(5),NEK(2),LLCH(2)
!
      POINTER :: MJ11,MJ12,ML
      TARGET :: MM,MRL
!
      MJ11=>MM(1,1)
      MJ12=>MM(1,2)
      ML=>MRL(5)
!
!      EQUIVALENCE (MJ11,MM(1,1)),(MJ12,MM(1,2)),(ML,MRL(5))
!
!-----------------------------------------------------------------------
!
!      MVC(M,MA)=((M+2)*M/2+MA)/2+1 !SEE INTRNL FUNCTN ABVE END FLGLX1
!
!-----------------------------------------------------------------------
!
!t      if(maxlx.ne.maxlx0)stop 'flglx1: maxlx...'
!
      MPOSC=MXORB+(LCONDWJ-1)/2-(LCONDW-1)/2             !BUFFER SPACE
      MXORBC=MPOSC+LCONDW
      BPLANT=MXORBC.LT.67.OR.SP.EQ.8
      MPOSC=MPOSC+(LCONDW+1)/2
!
      BSKP=MXLL.EQ.-1
      BKUTOO=KUTOOX.NE.0
!
      IRLS1=IRLS0+1
      IF(ICLRR.LT.0)GO TO 700
!
      brev=kf.lt.kg
      BEQCFS=KG.EQ.KF
      IF(.NOT.BEQCFS.AND.MXLAMX.LT.0)GO TO 1000   !SINGLE CONFIG
      BEQGRP=ND1.EQ.NDP1                          !WITHIN A GROUP
!
      NF1=NF+1
!
      NEK(1)=KF
      NEK(2)=KG
      LLCH(1)=LI
      LLCH(2)=LF
!
      NMULT=NMULTX-1                              !LIMIT NO OF MULIPOLES
!
      IDIR=0                             !DIRECT SET=0/1 TO INCLUDE/DROP
      IF(QSI(ND1).NE.QSI(NDP1))IDIR=1             !NO DIRECT THEN
!
      IXCH=0                           !EXCHANGE SET=0/1 TO INCLUDE/DROP
      IF(MTL.GT.2*MAXLX)IXCH=1                    !NO EXCHANGE THEN
!
      IF(IDIR+IXCH.EQ.2)GO TO 1000                !NULL
!
      DDA=DONE
      DDB=DZERO
      DVC12=DVC12O
!
! BEGIN MAIN SLATER-STATE INTERACTION LOOP (57)
!
      DO J1=JA,JB
!
        kk=nam(j1)
        if(brev.or.kk.lt.0)then
          kk=abs(kk)
          i1=2
          i2=1
        else
          i1=1
          i2=2
        endif
        nej(i1)=kinti(kk)
        nej(i2)=kintf(kk)
        j=nej(1)
        jd=nej(2)
!
!      write(mw6,*)kf,j,'      ',kg,jd
!
        IF(BEQUALM)THEN
          IF(JD.GT.J)GO TO 600
          IF(JD.LT.J)THEN
            DVC12=2*DVC12O
          ELSE
            DVC12=DVC12O
          ENDIF
        ENDIF
!
        DO I=IRLS1,IRLS
          IORIG(I)=0
          JORIG(I)=0
        ENDDO
!
        DDH=DONE
        BEQTMS=.FALSE.
!
        NK=1                                !0->1 SINCE CONT-CONT IS ONE
        DO K=1,2                            !INITIALIZE NK=1 CONT-CONT
          NEN(K,1)=NF1
        ENDDO
!
        NU=0
        IF(JD.EQ.J)GO TO 50                 !SO BEQCFS=.TRUE.
!
!  NK.EQ.2 HERE
!
        nk=2
        nen2=ken2(kk)
!                              if(nen2.eq.0)stop 'nen2 error'
        if(nen2.lt.0)then
          ddh=-ddh
          nen2=-nen2
        endif
        nen(i1,2)=nen2/nf1
!                     if(nen(i1,2).eq.0)stop 'nen(1,2) error'
        nen(i2,2)=nen2-nen(i1,2)*nf1
!                     if(nen(i2,2).eq.0)stop 'nen(2,2) error'
!
        go to 100
!
! NOW NK=1 (CASE J.EQ.JD ONLY NOW)
!
   50   NU=NU+1
        IF(NU.GT.NF)GO TO 550
        NEN(1,2)=NU
!
  100   DO L=1,2
                !=1 FOR SLATER STATES J (OF CONFIG KF),=2 FOR JD (OF KG)
          I=L
          DO K=1,2
                 !=1 FOR FOR FIRST PAIR OF ELECTRON STATES,=2 FOR SECOND
            IF(NK.LT.K)I=1
            KP=NEN(I,K)
            IF(KP.LE.0)THEN
              KP=KP+NW
              MU=NNL(KP,2)      !PACKED
              LP=NNL(KP,1)
              Q1(L,K)=LP
              MM(L,K)=QL(LP)
!            Q3(L,K)=NNL(KP,2)  !UNPACKED
!            Q4(L,K)=NNL(KP,3)  !UNPACKED
            ELSE
              LP=NEJ(I)
              MU=QLMC(KP,LP)
              LP=NEK(I)
              LP=QCG(KP,LP)
              IF(LP.GT.MXORB)THEN          !CONTINUUM
                MM(L,K)=LLCH(L)
                Q1(L,K)=(LLCH(L)-MTL)/2+MPOSC
              ELSE
                MM(L,K)=QL(LP)
                Q1(L,K)=LP
              ENDIF
            ENDIF               !PACKED
            ML=MM(L,K)
            ML=((ML+MU)/2)*2-ML
            Q3(L,K)=ML
            Q4(L,K)=(MU-ML)*2-1
!          ENDIF                !UNPACKED
          ENDDO
        ENDDO
!
! DIRECT (KP=0)
!
        KP=0
!        mxlamd=999
!
! EQU  MJ11=Q2(1,1)
! EQU  MJ12=Q2(1,2)
        MM11=-Q3(1,1)
        MM12=-Q3(1,2)
        MV11=MVC(MJ11,MM11)
        MV12=MVC(MJ12,MM12)
!
        IF(IDIR.EQ.1)GO TO 500                                !NO DIRECT
!
        MXLAM=ABS(MXLAMX)                       !RESTRICT DIRECT LAMBDA
!
! EXCHANGE (KP=1) RE-ENTRY POINT
!
  150   IF(.NOT.BSKP.AND.Q4(2,1+KP).NE.Q4(1,1))GO TO 500
!
        MJ21=MM(2,KP+1)
        MJ22=MM(2,2-KP)
!
! MU=MAX LAM
        MU=MIN(MJ11+MJ21,MJ12+MJ22)
        MP=MOD(MU/ITWO+MXLAM,ITWO)            !ALIGN
        MU=MIN(MU,ITWO*(MXLAM-MP))
!
! ML=MIN LAM
        ML=MAX(ABS(MJ11-MJ21),ABS(MJ12-MJ22))
!
! LIMIT NUMBER
        MU=MIN(MU,ML+IFOUR*NMULT)
!
        IF(ML.GT.MU)GO TO 500
!
        IF(.NOT.BSKP)THEN
          MM21=Q3(2,KP+1)
          MMD1=MM21+MM11
          MM22=Q3(2,2-KP)
          MMD2=MM12+MM22
!
! INCREASE MIN LAM BECAUSE OF ML1-ML2
          K=MAX(ABS(MMD1),ABS(MMD2))
!
! ORBIT-ORBIT LAM+1, SO "LESS RESTRICTIVE"
          IF(BKUTOO)K=K-2
          IF(K.GT.ML)ML=((K+2-ML)/4)*4+ML
          IF(ML.GT.MU)GO TO 500
!
          DSJ=SQRT(REAL((MJ11+1)*(MJ12+1)*(MJ21+1)*(MJ22+1),WP))        &
     &        *REAL((1-MOD(ABS(MM22-MM11),IFOUR))*(1-2*KP),WP)*DDH*DVC12
!
          MV21=MVC(MJ21,MM21)
          MV22=MVC(MJ22,MM22)
        ENDIF
!
! test limit exchange multipole to max of direct, not great,
! might as well switch-off exchange.
!
!        if(kp.eq.0)then
!          mxlamd=mu
!        else
!          mu=min(mu,mxlamd)
!          if(ml.gt.mu)go to 500
!        endif
!
! REORDER A,B,C,D IN AS MUCH FALLING ORDER AS SYMMETRY ALLOWS FOR
!
        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
        BFALL0=BKUTOO.AND.I+K.EQ.2
!
  200   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 200
        btest=mrl(2).eq.mrl(1).and.mrl(4).gt.mrl(3)
        if(btest)go to 200      !cont in pos nk=1
!
! LAMBDA RE-ENTRY POINT
!
  250   IF(.NOT.BSKP)THEN
          LP=ML/4+1
          IF(BVC.OR.(MJ11.LE.MXLL.AND.MJ21.LE.MXLL))THEN
            DDA=VCA(MV11,MV21,LP)
            IF(BKUTOO)DDB=VCB(MV11,MV21,LP)
          ELSE
            DVC=VCC(MJ11,MJ21,ML,IZERO,IZERO,IZERO)
            DDA=DVC*VCC(MJ11,MJ21,ML,MM11,MM21,MMD1)/(ML+1)
            IF(BKUTOO)DDB=DVC*VCC(MJ11,MJ21,ML+2,MM11,MM21,MMD1)
          ENDIF
          IF(BVC.OR.(MJ22.LE.MXLL.AND.MJ12.LE.MXLL))THEN
            DDA=DDA*VCA(MV22,MV12,LP)
            IF(BKUTOO)DDB=DDB*VCB(MV22,MV12,LP)
          ELSE
            DVC=VCC(MJ22,MJ12,ML,IZERO,IZERO,IZERO)
            DDA=DDA*DVC*VCC(MJ22,MJ12,ML,MM22,MM12,MMD2)/(ML+1)
            IF(BKUTOO)DDB=DDB*DVC*VCC(MJ22,MJ12,ML+2,MM22,MM12,MMD2)
          ENDIF
!
          IF(ABS(DDA)+ABS(DDB).EQ.DZERO)GO TO 450
!
          IF(BFANO)THEN
            IFANO=QL(Q1(2,1+KP))-QL(Q1(1,1))
            IF(MRL(5).GE.0)IFANO=IFANO+QL(Q1(2,2-KP))-QL(Q1(1,2))
            IFANO=IFANO/4
            IFANO=1-2*mod(abs(IFANO),ITWO)              !(-1)**IFANO
            DDA=DDA*IFANO
            IF(BKUTOO)DDB=DDB*IFANO
          ENDIF
!
          DDA=DDA*DSJ
          IF(BKUTOO)DDB=DDB*DSJ
        ENDIF
!
! STORE CONTRIBUTION TO (EXISTING) COEFFICIENT
!
        IF(BPLANT)IPLANT=MRL(5)                                         &
     &                   /2+((((MRL(4)*MXORBC+MRL(3))*MXORBC+MRL(2))    &
     &                   *MXORBC)+MRL(1))*100
!
        DO I=IRLS1,IRLS
          IF(.NOT.BPLANT)THEN
            DO K=5,1,-1
              IF(MRL(K).NE.QRLS(K,I))GO TO 300
            ENDDO
          ELSE
            IF(IPLANT.NE.JPLANT(I))GO TO 300
          ENDIF
          IF(BEQTMS)THEN
            LP=-I
            K=JORIG(I)
          ELSE
            LP=I
            K=IORIG(I)
          ENDIF
          IF(K.GT.0)THEN
            DRKS(K)=DDA+DRKS(K)
            IF(BKUTOO)THEN
              DEKS(K)=DDB+DEKS(K)
              IF(BFALLS(K).NEQV.BFALL0)THEN
                WRITE(MW6,*)'FLGL1: PROBLEM WITH ORBIT-ORBIT ALG.'
                WRITE(MW0,*)'FLGL1: PROBLEM WITH ORBIT-ORBIT ALG.'
                NF=-1
                GO TO 1000
              ENDIF
            ENDIF
            GO TO 400
          ENDIF
          GO TO 350
  300   ENDDO
!
! CANNOT FIND OLD SET OF ARGUMENTS, SO START CONSTRUCTING A NEW SET
!
        LP=IRLS+1
        IF(LP.GT.IXRLS)THEN                                   !GO TO 999
!
          IXXX=7*(IXRLS/5+1)
!
          WRITE(MW6,*)'*** FLGLX1: increasing MXRLS from ',IXRLS,       &
     &                ' to: ',IXXX
          WRITE(MW0,*)'*** FLGLX1: increasing MXRLS from ',IXRLS,       &
     &                ' to: ',IXXX
!
          CALL RE_ALLOC2(QRLS,IONE,IFIVE,IONE,IXRLS,IFIVE,IXXX,IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'FLGLX1: RE-ALLOCATION FAILS FOR QRLS'
            NF=0
            GO TO 1000
          ENDIF
!
          IXXX0=MAX(IXRLS,IAXRL)
          IXXX2=MAX(IXXX,IAXRL)
          IF(IXXX2.GT.IXXX0)CALL RE_ALLOC(IORIG,IONE,IXXX0,IXXX2,IERR)
          CALL RE_ALLOC(JORIG,IONE,IXRLS,IXXX,IERR)
          CALL RE_ALLOC(JPLANT,IONE,IXRLS,IXXX,IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)                                                &
     &              'FLGLX1: RE-ALLOCATION FAILS FOR IORIG,JORIG,JPLANT'
            NF=0
            GO TO 1000
          ENDIF
!
          IXRLS=IXXX
!
        ENDIF
!
        IRLS=LP
        DO K=1,5
          QRLS(K,LP)=INT(MRL(K),QP)
        ENDDO
        IF(BPLANT)JPLANT(LP)=IPLANT
!
        IF(BEQTMS)LP=-LP
!
  350   IRKS=IRKS+1
        IF(IRKS.GT.IXRKS)THEN                                 !GO TO 999
!
          IXXX=7*(IXRKS/5+1)
!
          WRITE(MW6,*)'*** FLGLX1: increasing MXRKS from ',IXRKS,       &
     &                ' to: ',IXXX
          WRITE(MW0,*)'*** FLGLX1: increasing MXRKS from ',IXRKS,       &
     &                ' to: ',IXXX
!
          CALL RE_ALLOC(DRKS,IONE,IXRKS,IXXX,IERR)
          IF(BKUTOO)THEN
            CALL RE_ALLOC(DEKS,IONE,IXRKS,IXXX,IERR)
            CALL RE_ALLOC(BFALLS,IONE,IXRKS,IXXX,IERR)
          ENDIF
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'FLGLX1: RE-ALLOCATION FAILS FOR DRKS,DEKS'
            NF=0
            GO TO 1000
          ENDIF
!
          CALL RE_ALLOC(NRKS,IONE,IXRKS,IXXX,IERR)
          CALL RE_ALLOC(NSTJ,IONE,IXRKS,IXXX,IERR)
          CALL RE_ALLOC(NSTJD,IONE,IXRKS,IXXX,IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'FLGLX1: RE-ALLOCATION FAILS FOR NRKS,NSTJ'
            NF=0
            GO TO 1000
          ENDIF
!
          IXRKS=IXXX
!
        ENDIF
!
        DRKS(IRKS)=DDA
        IF(BKUTOO)THEN
          DEKS(IRKS)=DDB
          BFALLS(IRKS)=BFALL0
        ENDIF
!
        IF(LP.GT.0)THEN
          IORIG(LP)=IRKS
          JORIG(LP)=0
        ELSE
          JORIG(-LP)=IRKS
        ENDIF
!
        NRKS(IRKS)=LP
        NSTJ(IRKS)=J
        NSTJD(IRKS)=JD
!
  400   CONTINUE
!
!      write(mw6,998)  j,jd,lp,kp, mrl,dda,irks,kf,kg
! 998  format(4i5,4x,5i3,f12.5,i4,2i6)
!
  450   ML=ML+4
        IF(ML.LE.MU)GO TO 250                !NEXT LAMBDA
!
  500   KP=KP+1+IXCH
        MXLAM=MXLAMX                         !RESTRICT EXCHANGE LAMBDA
        IF(KP.EQ.1)GO TO 150                 !EXCHANGE
!
        IF(NK.EQ.1)GO TO 50
!
  550   IF(J.EQ.JD.AND..NOT.BEQTMS)THEN      !SO BEQCFS=.TRUE.
          BEQTMS=.TRUE.
          IF(LLCH(1).EQ.LLCH(2).AND.BEQGRP)THEN
            NU=-NW
          ELSE
            NU=0
          ENDIF
          GO TO 50
        ENDIF
!
!
  600 ENDDO               !END SLATER-STATE INTERACTION LOOP
!
!
! IF THE COEFFICIENTS OF THE MATRIX ELEMENT HAVE NOT BEEN COMPLETELY
! CALCULATED, RETURN - WILL CALL AGAIN, FOR DIFFERENT (MS,ML).
!
      IF(BLX)RETURN
!
!
! ELIMINATE COEFFICIENTS /DRKS/.LT.TYNY AND ARGUMENTS QRLS THAT HAVE
! BEEN LISTED BEFORE IN THE REFERENCE LIST
!
  700 ICLRR=0
      IF(IRKS.LT.IRKS0)GO TO 1000
!
      K=IRKS0-1
      KP=0
      DO I=IRLS1,IRLS
        IORIG(I)=0
      ENDDO
!
      DO I=IRKS0,IRKS
!
        JD0=NRKS(I)
        JD=ABS(JD0)
        DD=ABS(DRKS(I))
        IF(BKUTOO)DD=DD+ABS(DEKS(I))
        IF(ABS(DD).LT.TYNY)THEN
          IF(IORIG(JD).GT.0)GO TO 900
          JD0=0               !RE-INDEX QRLS AS MAY OCCUR LATER
          GO TO 750
        ENDIF
!
        K=K+1
        DRKS(K)=DRKS(I)
        IF(BKUTOO)THEN
          DEKS(K)=DEKS(I)
          BFALLS(K)=BFALLS(I)
        ENDIF
        NSTJ(K)=NSTJ(I)
        NSTJD(K)=NSTJD(I)
!
  750   IF(JD.LE.IRLS0)THEN
          IF(IRLS.LE.IXRLS)THEN   !SHOULD NOT GET HERE
            WRITE(MW6,*)'FLGLX1: INFORM NRB OF STOP HERE'
            WRITE(MW0,*)'FLGLX1: INFORM NRB OF STOP HERE'
            NF=-1
            GO TO 1000
          ELSE          !GRACEFUL EXIT TO DIMENSION STOP
            LP=JD
            GO TO 800
          ENDIF
        ENDIF
!
        IF(IORIG(JD).EQ.0)THEN
          LP=JD-KP
          DO L=1,IRLS0
            DO J=1,5
              IF(QRLS(J,JD).NE.QRLS(J,L))GO TO 760
            ENDDO
            KP=KP+1
            IORIG(JD)=L
            LP=L
            GO TO 800
  760     ENDDO
        ELSE
          LP=IORIG(JD)
          GO TO 800
        ENDIF
!
        IORIG(JD)=LP
        DO J=1,5
          QRLS(J,LP)=QRLS(J,JD)
        ENDDO
!
  800   IF(JD0.NE.0)THEN
          NRKS(K)=LP
          IF(JD0.LT.0)NRKS(K)=-NRKS(K)
        ENDIF
!
  900 ENDDO
!
      IRLS=IRLS-KP
      IRKS=K
!
!-----------------------------------------------------------------------
!
 1000 RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION MVC(M,MA)
!
      INTEGER(SP) M,MA,MVC
!
      MVC=((M+2)*M/2+MA)/2+1
!
      END FUNCTION MVC
!-----------------------------------------------------------------------
!
      END SUBROUTINE FLGLX1
!
!                             *******************
!
      SUBROUTINE FLGLX2(iam,ibm,KK)
!
!-----------------------------------------------------------------------
!
!  SR.FLGLX2 CALCULATES THE TERM-RESOLVED ELECTROSTATIC AND, OPTIONALLY,
!  ORBIT-ORBIT INTERACTION BETWEEN PAIRS OF ELECTRONS, ONE PAIR BEING
!  CONTINUUM.
!
!  IT IS CALLED BY:
!    SR.ALGXLS
!
!  IT CALLS:
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!
!-----------------------------------------------------------------------
!
!!      COMMON /BASIC/NF,KF,KG,ND1,ND2,NDP1,NDP2,NGAP(5)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,ND1=>IBSK4,ND2=>IBSK5          &
     &              ,NDP1=>IBSK6,NDP2=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9  &
     &              ,IBSK10=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_DC,     ONLY: BFAST,DC
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,IRL
      USE COMMON_DXRL,   ONLY: IRK,IRK0,IOS,IOS0
      USE COMMON_DXRLS,  ONLY: DRKS,DEKS,QRLS,NRKS,BFALLS
      USE COMMON_DXRLS,  ONLY: IRKS,IRKS0,IRLS,IRLS0
      USE COMMON_NSTS,   ONLY: NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT
!
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,KUTOOX,MAXLOO
      USE COMMON_NRBDW1, ONLY: MXORB,ma0,mb0
      USE COMMON_NRBDW2, ONLY: LCONDW,MTS,MTSP,MTL,MTLP,MTP,LCONDWJ,MTJ &
     &                        ,LVMIN,LVMAX
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M8)
      PARAMETER (TTYNY=TYNY/D1P3)
!
      DIMENSION iam(*),ibm(*)
!
!-----------------------------------------------------------------------
!
      BKUTOO=KUTOOX.NE.0
      DDB=DZERO
!
      IRK0=IRK+1
      IRL00=IRL
!
      DO J=1,IRLS
        JORIG(J)=0
      ENDDO
!
      BEQTMS=NDP1.EQ.ND1
!
!
! BEGIN MAIN LOOP 57 OVER SLATER INTERACTIONS
!
      K0=NADS(KK-1)+1
!
      DO KS=K0,NADS(KK)
!
        J=NSTJ(KS)
        m=iam(j)
        if(m.eq.0)go to 100
!
        JD=NSTJD(KS)
!
        II=NRKS(KS)
        IF(J.EQ.JD)THEN
          IF(BEQTMS.AND.II.GT.0)GO TO 100
          IF(.NOT.BEQTMS.AND.II.LT.0)GO TO 100
          II=ABS(II)
        ENDIF
!
        IF(BFAST)THEN
          DDH=DC(m)*DC(JD+NDP2)                       !DC(J+ND2)
        ELSE
          md=ibm(jd)
          if(md.eq.0)go to 100
          DDH=DC(m)*DC(md)
        ENDIF
!
        DDA=DDH*DRKS(KS)
!        write(mw6,*)ks,j,jd,ddh,drks(ks),dda
        IF(BKUTOO)DDB=DDH*DEKS(KS)
        IF(ABS(DDA)+ABS(DDB).LT.TTYNY)GO TO 100
!
        LP=JORIG(II)
        IF(LP.GT.0)THEN
          K=IORIG(LP)
          DRK(K)=DRK(K)+DDA
!          write(mw6,*)lp,k,drk(k)
          IF(BKUTOO)THEN
            DEK(K)=DDB+DEK(K)
            IF(BFALL(K).NEQV.BFALLS(KS))THEN
              WRITE(MW6,*)'FLGL2: PROBLEM WITH ORBIT-ORBIT ALG.'
              WRITE(MW0,*)'FLGL2: PROBLEM WITH ORBIT-ORBIT ALG.'
              NF=-1
              GO TO 300
            ENDIF
          ENDIF
        ELSE
!
! CANNOT FIND AN OLD SET OF ARGUMENTS EQUAL TO THE NEW SET, SO
! MUST START CONSTRUCTING A NEW COEFFICIENT.
!
          LP=IRL+1
          IF(LP.GT.IAXRL)THEN                                  !GO TO 90
!
            IXXX=7*(IAXRL/5+1)
!
            WRITE(MW6,*)'*** FLGLX2: increasing MAXRL from ',IAXRL,     &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** FLGLX2: increasing MAXRL from ',IAXRL,     &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC2(QRL,IONE,IFIVE,IONE,IAXRL,IFIVE,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'FLGLX2: RE-ALLOCATION FAILS FOR QRL'
              NF=0
              GO TO 300
            ENDIF
!
            IXXX0=MAX(IAXRL,IXRLS)
            IXXX2=MAX(IAXRL,IXXX)
            IF(IXXX2.GT.IXXX0)CALL RE_ALLOC(IORIG,IONE,IXXX0,IXXX2,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'FLGLX2: RE-ALLOCATION FAILS FOR IORIG'
              NF=0
              GO TO 300
            ENDIF
!
            IAXRL=IXXX
!
          ENDIF
!
          IRK=IRK+1
          IF(IRK.GT.IAXRK)THEN                                 !GO TO 90
!
            IXXX=7*(IAXRK/5+1)
!
            WRITE(MW6,*)'*** FLGLX2: increasing MAXRK from ',IAXRK,     &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** FLGLX2: increasing MAXRK from ',IAXRK,     &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC(DRK,IONE,IAXRK,IXXX,IERR)
            IF(BKUTOO)THEN
              CALL RE_ALLOC(DEK,IONE,IAXRK,IXXX,IERR)
              CALL RE_ALLOC(BFALL,IONE,IAXRK,IXXX,IERR)
            ENDIF
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'FLGLX2: RE-ALLOCATION FAILS FOR DRK,DEK'
              NF=0
              GO TO 300
            ENDIF
!
            CALL RE_ALLOC(NRK,IONE,IAXRK,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'FLGLX2: RE-ALLOCATION FAILS FOR NRK'
              NF=0
              GO TO 300
            ENDIF
!
            IAXRK=IXXX
!
          ENDIF
!
          IRL=LP
          DO K=1,5
            QRL(K,LP)=QRLS(K,II)
          ENDDO
          if(qrl(2,lp).gt.mxorb)qrl(5,lp)=qrl(5,lp)-INT(mtl,QP)  !exchng
          JORIG(II)=LP
          IORIG(LP)=IRK
          NRK(IRK)=LP
          DRK(IRK)=DDA
          IF(BKUTOO)THEN
            DEK(IRK)=DDB
            BFALL(IRK)=BFALLS(KS)
          ENDIF
!          write(mw6,*)-lp,irk,drk(irk)
!
        ENDIF
!
  100 ENDDO
!
! ELIMINATE COEFFICIENTS /DRK/.LT.TYNY AND ARGUMENTS QRL THAT HAVE
! BEEN LISTED BEFORE IN THE REFERENCE LIST
!
      K=IRK0-1
      KP=0
!
      DO I=IRK0,IRK
!
        JD=INT(NRK(I),SP)
        DD=ABS(DRK(I))
        IF(BKUTOO)DD=DD+ABS(DEK(I))
!
        IF(ABS(DD).LT.TYNY)THEN
          IF(JD.GT.IRL00)KP=KP+1
          GO TO 200
        ENDIF
!
        K=K+1
        DRK(K)=DRK(I)
        IF(BKUTOO)THEN
          DEK(K)=DEK(I)
          BFALL(K)=BFALL(I)
        ENDIF
!
        LP=JD
        IF(JD.GT.IRL00)THEN
          LP=JD-KP
          DO L=1,IRL00
            DO J=1,5
              IF(QRL(J,JD).NE.QRL(J,L))GO TO 120
            ENDDO
            KP=KP+1
            LP=L
            GO TO 150
  120     ENDDO
          DO J=1,5
            QRL(J,LP)=QRL(J,JD)
          ENDDO
        ENDIF
!
  150   NRK(K)=LP
!
  200 ENDDO
!
      IRL=IRL-KP
      IRK=K
!
!-----------------------------------------------------------------------
!
  300 RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE FLGLX2
!
!                             *******************
!
      SUBROUTINE FLGLX3(IFLAG1,IFLAG2,LA1,LA2,L1,L2,MTL,MTLO,NCORX)
!
!-----------------------------------------------------------------------
!
!  SR.FLGLX3 CALCULATES THE TERM-RESOLVED ELECTROSTATIC AND, OPTIONALLY,
!  ORBIT-ORBIT INTERACTION USING SYMMTERY RELATION FOR A PRECEEDING L.
!
!  IT IS CALLED BY:
!    SR.ALGXLS
!
!  IT CALLS:
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!    FN.SJS
!    FN.VCC
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_DXRL,   ONLY: DRK,QRL,NRK,NAD
      USE COMMON_DXRL,   ONLY: IRK,IRK0,IOS,IOS0
!
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,KUTOOX,MAXLOO
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M6)
!
      ALLOCATABLE :: DRKO(:),DEKO(:)
!
      SAVE K1,K2,K1P,K2P,MTLN,IXD16
!
      SAVE K00,DRKO,DEKO
!
!-----------------------------------------------------------------------
!
      BFIRST=.NOT.ALLOCATED(DRKO)
      IF(BFIRST)THEN
        K1=0
        K2=0
        K1P=0
        K2P=0
        MTLN=0
        IXD16=100
      ENDIF
!
      BLAST=NCORX.LT.0
      IF(BLAST)NCORX=-NCORX
!
      BKUTOO=KUTOOX.NE.0
!
      IF(BFIRST)THEN
        IXD16=MAX(MAXRK/10,IAXRK/10,IXD16)
        ALLOCATE(DRKO(IXD16),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'FLGLX3: ALLOCATION FAILS FOR DRKO'
          NCORX=0
          NF=0
          RETURN
        ENDIF
        IF(BKUTOO)THEN
          ALLOCATE(DEKO(IXD16),STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'FLGLX3: ALLOCATION FAILS FOR DEKO'
            NCORX=0                                             !TRACKED
            NF=0                                            !NOT TRACKED
            RETURN
          ENDIF
        ENDIF
      ENDIF
!
      LD=MTL-MTLO
      if(mod(ld,ifour).ne.0)stop 'sr.flglx3: phase error!' !shouldn't be
!
! SET OLD FLGL
!
      IF(IFLAG1.EQ.1.OR.IFLAG2.EQ.1)THEN
        IF(IFLAG1.EQ.1)THEN
          K1=MAX(K1,K2P)
          K0=MAX(K1,K1P)
        ENDIF
        IF(IFLAG2.EQ.1)THEN
          K2=MAX(K2,K1P)
          K0=MAX(K2,K2P)
        ENDIF
!
        L1O=L1-LD
        L2O=L2-LD
        DDO=SQRT(REAL((L1O+1)*(L2O+1),WP))
!
        IXXX=K0+NAD(NCORX)-NAD(NCORX-1)
!
        IF(IXXX.GT.IXD16)THEN                                  !GO TO 99
!
          IXXX=7*(IXXX/5+1)
!
          WRITE(MW6,*)'*** FLGLX3: increasing MXD16 from ',IXD16,       &
     &                ' to: ',IXXX
          WRITE(MW0,*)'*** FLGLX3: increasing MXD16 from ',IXD16,       &
     &                ' to: ',IXXX
!
          CALL RE_ALLOC(DRKO,IONE,IXD16,IXXX,IERR)
          IF(BKUTOO)THEN
            CALL RE_ALLOC(DEKO,IONE,IXD16,IXXX,IERR)
          ENDIF
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'FLGLX3: RE-ALLOCATION FAILS FOR DRKO,DEKO'
            NF=0
            GO TO 100
          ENDIF
!
          IXD16=IXXX
!
        ENDIF
!
        DO K=NAD(NCORX-1)+1,NAD(NCORX)
!
          K0=K0+1
!          IF(K0.LE.MXD16)THEN
          J=INT(NRK(K),SP)
          MLAM=QRL(5,J)
!
!            write(66,*)'k=',k
!            write(66,*)l1o,l2o,mlam
          D3O=VCC(L1O,L2O,MLAM,IZERO,IZERO,IZERO)
!            write(66,*)d3o
!            call flush(66)
!
          IF(ABS(DRK(K)).GT.TYNY)THEN               !FOR CASE BKUTOO=.T.
!              write(66,*)j,la1,l1o,mtlo,l2o,la2,mlam
            D6O=SJS(LA1,L1O,MTLO,L2O,LA2,MLAM)
!              write(66,*)d6o
!              call flush(66)
            if(d3o*d6o.eq.dzero)then
              if(abs(drk(k)).gt.10*tyny)then
                write(mw6,*)'sr.flglx3: 3j-/6j-symbol zero'
                write(mw6,*)'3j=',d3o
                write(mw6,*)j,la1,l1o,mtlo,l2o,la2,mlam
                write(mw6,*)'6j=',d6o
                write(mw6,*)'k=',k,'drk(k)=',drk(k)
!                  call flush(mw6)
                stop 'sr.flglx3: 3j-/6j-symbol zero'
              else
                drk(k)=dzero
                d3o=done
                d6o=done
              endif
            endif
            DRKO(K0)=DRK(K)/(DDO*D3O*D6O)
          ELSE
            DRKO(K0)=DZERO
          ENDIF
!
          IF(BKUTOO)THEN
            IF(ABS(DEK(K)).GT.TYNY)THEN
!              write(66,*)j,la1,l1o,mtlo,l2o,la2,mlam+2
              D6O=SJS(LA1,L1O,MTLO,L2O,LA2,MLAM+2)      !LAM+1
!                write(66,*)d6o
!                call flush(66)
              if(d3o*d6o.eq.dzero)then
                if(abs(dek(k)).gt.10*tyny)then
                  write(mw6,*)'sr.flglx3: 3j-/6j-symbol zero'
                  stop 'sr.flglx3: 3j-/6j-symbol zero'
                else
                  dek(k)=dzero
                  d3o=done
                  d6o=done
                endif
              endif
              DEKO(K0)=DEK(K)/(DDO*D3O*D6O)
            ELSE
              DEKO(K0)=DZERO
            ENDIF
          ENDIF
!          ENDIF
!
        ENDDO
!
        IF(IFLAG1.EQ.1)K1P=K0
        IF(IFLAG2.EQ.1)K2P=K0
!
        IF(K0.GT.IXD16)THEN
          WRITE(MW6,*)'*** SR.FLGLX3: MAY NEED TO ADJUST MXD16 SETTING'
          NCORX=0
          BLAST=.TRUE.
          GO TO 100
        ENDIF
!
      ENDIF
!
! GET NEW FLGL FROM OLD
!
      IF(MTL.GT.MTLN)THEN
        MTLN=MTL
        IF(IFLAG1.GT.0)K00=K1
        IF(IFLAG2.GT.0)K00=K2
      ENDIF
!
      IRK0=IRK+1
      IXXX=IRK+NAD(NCORX)-NAD(NCORX-1)                         !IRK=
!
      IF(IXXX.GT.IAXRK)THEN                                    !GO TO 99
!
        IXXX=7*(IXXX/5+1)
!
        WRITE(MW6,*)'*** FLGLX3: increasing MAXRK from ',IAXRK,' to: ', &
     &              IXXX
        WRITE(MW0,*)'*** FLGLX3: increasing MAXRK from ',IAXRK,' to: ', &
     &              IXXX
!
        CALL RE_ALLOC(DRK,IONE,IAXRK,IXXX,IERR)
        IF(BKUTOO)THEN
          CALL RE_ALLOC(DEK,IONE,IAXRK,IXXX,IERR)
          CALL RE_ALLOC(BFALL,IONE,IAXRK,IXXX,IERR)
        ENDIF
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'FLGLX3: RE-ALLOCATION FAILS FOR DRK,DEK'
          NF=0
          GO TO 100
        ENDIF
!
        CALL RE_ALLOC(NRK,IONE,IAXRK,IXXX,IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'FLGLX3: RE-ALLOCATION FAILS FOR NRK'
          NF=0
          GO TO 100
        ENDIF
!
        IAXRK=IXXX
!
      ENDIF
!
!      IRK=IRK0-1
!
      DD=SQRT(REAL((L1+1)*(L2+1),WP))
!
      DO K=NAD(NCORX-1)+1,NAD(NCORX)
!
        IRK=IRK+1
!
        NRK(IRK)=NRK(K)
        J=INT(NRK(K),SP)
        MLAM=QRL(5,J)
        IF(MLAM.LT.0)STOP 'SR.FLGLX3: LAMBDA ERROR!'
!
!        write(66,*)'k=',k
!        write(66,*)j,la1,l1,mtl,l2,la2,mlam
        D6=SJS(LA1,L1,MTL,L2,LA2,MLAM)
!        write(66,*)d6
!        write(66,*)l1,l2,mlam
        D3=VCC(L1,L2,MLAM,IZERO,IZERO,IZERO)
!        write(66,*)d3
!
        K00=K00+1
!
        IF(ABS(DRKO(K00)).GT.TYNY)THEN
          DDA=DRKO(K00)                            !DRK(K)/(DDO*D3O*D6O)
          DRK(IRK)=DD*DDA*D3*D6
        ELSE
          DRK(IRK)=DZERO
        ENDIF
!
!        write(66,*)k,irk,j,drk(irk)
!
        IF(BKUTOO)THEN
          IF(ABS(DEKO(K00)).GT.TYNY)THEN
            D6=SJS(LA1,L1,MTL,L2,LA2,MLAM+2)       !RANK LAM+1
!            write(66,*)d6
            DDB=DEKO(K00)                          !DEK(K)/(DDO*D3O*D6O)
            DEK(IRK)=DD*DDB*D3*D6
            BFALL(IRK)=BFALL(K)
          ELSE
            DEK(IRK)=DZERO
          ENDIF
        ENDIF
!
      ENDDO
!
  100 IF(BLAST)THEN
        DEALLOCATE(DRKO,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'FLGLX3: DE-ALLOCATION FAILS FOR DRKO'
          NCORX=0
          NF=0
          RETURN
        ENDIF
        IF(BKUTOO)THEN
          DEALLOCATE(DEKO,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'FLGLX3: DE-ALLOCATION FAILS FOR DEKO'
            NCORX=0                                             !TRACKED
            NF=0                                            !NOT TRACKED
            RETURN
          ENDIF
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE FLGLX3
!
!                             *******************
!
      FUNCTION FMON1(EK1,EK2,L)
!
!-----------------------------------------------------------------------
!
! FN.FMON1 EVALUATES MONOPOLE INTEGRALS NEEDED FOR DETERMINATION OF THE
!          DIPOLE ONE - SEE EQUS (A3) & (A4) OF BHT.
! NRB: BASED ON ALAN'S ORIGINAL.
!
! NOTE: THIS ROUTINE MAY SUFFER FROM CANCELLATION ERROR - SEE BELOW.
!
!  IT IS CALLED BY:
!    SR.FDIP1
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,XP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
! SET XP=16 IN MODULE PRECSN IF CANCELLATION IS AN ISSUE
!
      IMPLICIT REAL(XP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
      REAL(WP) EK1,EK2,FMON1                               !MUST KEEP WP
!
      PARAMETER (X1O64=XONE/X64)
!
!-----------------------------------------------------------------------
!
      IF(EK1+EK2.LT.D1M40)THEN
        FMON1=D1P50
        GO TO 700
      ENDIF
!
      VMAX=200                   !MAX NUMBER TERMS TO CONVERGE EXPANSION
!
      X1=SQRT(EK1)
      X2=SQRT(EK2)
      X3=X1+X2
      X4=X3*X3
      X5=X1*X2
      X6=X2-X1
      X7=XFOUR/X4
      PI=ACOS(-XONE)        !PI->XPI WHEN PI SET IN MODULE CONSTATS_MATH
!
      IF(EK1.LT.EK2)THEN
        ETA=XONE/X2
      ELSE
        ETA=XONE/X1
      ENDIF
!
      G=PI*EXP(-PI*ETA)/XTWO
!
      IF(G.lt.x1m40)THEN                        !NRB OVERFLOW ZEROES OUT
        FMON1=XZERO
        GO TO 700
      ENDIF
!
      A1=XONE
      A2=XONE
      MG=0
      MA1=0
      MA2=0
!
      M=-1
  100 M=M+1
      EM=M
      T=EM+EM+XONE
      G=G*X7/(T*(T+XONE))
      EMM=EM*EM
      A1=A1*(XONE+EMM*EK1)
      A2=A2*(XONE+EMM*EK2)
!
  200 IF(G.LT.X1O64)THEN
        G=X64*G
        MG=MG-1
        GO TO 200
      ENDIF
!
  300 IF(G.GT.X64)THEN
        G=G/X64
        MG=MG+1
        GO TO 300
      ENDIF
!
  400 IF(A1.GT.X64)THEN
        A1=A1/X64
        MA1=MA1+1
        GO TO 400
      ENDIF
!
  500 IF(A2.GT.X64)THEN
        A2=X1O64*A2
        MA2=MA2+1
        GO TO 500
      ENDIF
!
      IF(M.LT.L)GO TO 100
!
      G=G*(T+XONE)
!
      IF(X1.GE.X300)THEN
        XB=PI/X1
        A1=X1PT5*A1/(XB*(XTHREE-XB*(XTHREE-XB*(XTWO-XB))))
      ELSEIF(X1.GT.X0PT2)THEN
        XB=-PI/X1
        A1=A1/(XONE-EXP(XB+XB))
      ENDIF
!
      IF(X2.GE.X300)THEN
        XB=PI/X2
        A2=X1PT5*A2/(XB*(XTHREE-XB*(XTHREE-XB*(XTWO-XB))))
      ELSEIF(X2.GT.X0PT2)THEN
        XB=-PI/X2
        A2=A2/(XONE-EXP(XB+XB))
      ENDIF
!
      G=G*SQRT(A1*A2)*XEIGHT**(MG+MG+MA1+MA2)
!
      S0=XONE
      S1=XZERO
      U=L
      V=XZERO
      W=U+U+XONE
      T0=XONE
      T1=XZERO
!
! NRB: THE LOOP BELOW CAN SUFFER FROM CANCELLATION ERROR,
! AS DO OTHERS OF ITS ILK - THEIR "SOLUTON" REAL *16...
!
  600 U=U+XONE
      V=V+XONE
      W=W+XONE
!
      IF(V.GT.VMAX)THEN
        FMON1=XZERO
        GO TO 700
      ENDIF
!
      U0=U*U*X5+XONE
      U1=U*X6
      T=T0*U0-T1*U1
      T1=T0*U1+T1*U0
      T0=T
      T=X7/(V*W)
      T0=T*T0
      T1=T*T1
      S0=S0+T0
      S1=S1+T1
      S=S0*S0+S1*S1
      T=T0*T0+T1*T1
      SM=XONE/S
      TM=XONE/T
!
      IF(SM*TM.EQ.XZERO)THEN                    !NRB OVERFLOW ZEROES OUT
        FMON1=XZERO
        GO TO 700
      ENDIF
!
      IF(S.LT.X1P24*T)GO TO 600
!
      FMON1=G*SQRT(S)
!      IV=V
!
!-----------------------------------------------------------------------
!
  700 RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION FMON1
!
!                             *******************
!
      SUBROUTINE FSINT(BPRNT0)
!
!-----------------------------------------------------------------------
!
!  SR.FSINT CALCULATES THE TWO-BODY FINE-STRUCTURE INTEGRALS (N & V)
!  FOR HAMILTONIAN.
!
!  THE FOUR ELECTRON-ARGUMENTS (1,2,3.. FOR 1S,2S,2P..) HAVE BEEN
!  STORED IN QSS(I,L),I=1,4, AND 2*LAMBDA IN QRSS(5,L).
!
!  IT IS CALLED BY:
!    SR.DIAGFS
!
!  IT CALLS:
!    SR.DIFF
!    SR.WEDDLE
!    SR.YLAMKR
!    SR.YLAMK
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DMQSS3, ONLY: QSS                                      &
     &                        ,NL000=>NL,NL=>NL000
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
      USE COMMON_RELINT, ONLY: DRLP1,DNL
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD
      USE COMMON_NRBAL2, ONLY: MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBFSI, ONLY: BNRBFSI,DNLI,NLI
      USE COMMON_NRBINT, ONLY: DRLI,DYY,IYY,NRLI,MENG,NREL,NLAG,NLAGP   &
     &                        ,BLAG,BBC2
      USE COMMON_NRBOLP, ONLY: OVLPGR,OVLPCF,IPAIR
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBVAL, ONLY: FACT,IVAL,NNEW,NNOLD,BJUMP,BJUMP2,BRAD
      use common_nrbtmp, only: rnorm
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      ALLOCATABLE :: DPA(:),DP(:)
!
!-----------------------------------------------------------------------
!
! THE NAMES HERE ARE NOT NECESSARILY SIGNIFICANT THEY ARE COMMON LEGACY.
!
! LOCAL
      ALLOCATE(DPA(MAXRS),DP(MAXRS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'FSINT: ALLOCATION FAILS FOR DPA,DP'
        NF=0
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
      IF(NL.LT.NL000)NL=NL+1
      NN=NL000
!
      IF(BPRNT0)WRITE(MW6,10020)
!
      IF(BREL)THEN
        BREL2=ABS(IREL).EQ.2
        DZ=NZION
        T=DALF4*DTWO
      ENDIF
!
      IF(BJUMP)THEN                 !JUST RE-COMPUTE OR RE-SCALE RYDBERG
!
        DO J=1,NN
          M=0
          TM=DONE
          DO I=1,4
            N=QSS(I,J)
            M=M+IVAL(N)
            TM=TM*FACT(N)
          ENDDO
          KK=NLI(J)
          IF(M.GT.0)THEN
            IF(BJUMP2)THEN
              DNL(J)=DNL(J)*TM      !RE-SCALE
              IF(KK.GT.0)THEN
                DO I=1,MENG
                  DNLI(I,KK)=DNLI(I,KK)*TM
                ENDDO
              ENDIF
            ELSE
              DNL(J)=DZERO          !ZERO-OUT FOR RE-COMPUTE
            ENDIF
          ENDIF
!
          IF(BJUMP2.AND.BPRNT0)THEN
            IF(KK.GT.0)WRITE(MW6,10010)J,(QSS(I,J),I=1,5),              &
     &                                 (DNLI(IC,KK),IC=1,MENG)
            IF(KK.EQ.0)WRITE(MW6,10010)J,(QSS(I,J),I=1,5),DNL(J)
          ENDIF
!
        ENDDO
!
        IF(BJUMP2)GO TO 200                                      !RETURN
!
      ELSE                                 !INITIALIZE AND COMPUTE *ALL*
!
        DO J=1,NN
          DNL(J)=DZERO
        ENDDO
!
      ENDIF
!
! OUTER LOOP TO DETERMINE FINE-STRUCTURE INETGRALS
!
      DO J=1,NN                      !START MAGNETIC TWO-BODY OUTER LOOP
!                                    !OVER INNER ORBITAL PAIR (YLAMK)
        IF(DNL(J).NE.DZERO)GO TO 100
!
        M=QSS(5,J)
        MM=(M+2)/100
        BINT=MM.EQ.2                     !FALSE V; TRUE N
        IF(.NOT.BINT.AND.MM.NE.1)THEN
          WRITE(MW6,*)'FSINT ERROR: ITYPE=',MM
          WRITE(MW6,*)'J',J,'  QSS(J):',(QSS(M,J),M=1,5)
          WRITE(MW0,*)'FSINT ITYPE ERROR'
          NF=-1
          GO TO 200                                              !RETURN
        ENDIF
!
        M1=(M-100*MM)/2
        IF(M1.GT.MAXLAM)GO TO 100
!
        MJ=M-197
        IF(MJ.GT.0)MJ0=3                 !N
        IF(MJ.LT.0)MJ0=-3                !V
        K=0                              !V
        IF(BINT)K=1                      !N
!
        N1=QSS(K+1,J)
        N2=QSS(K+3,J)
        IF(MODE.LT.3)THEN
          IMT=0
          IF(IYY(N1).GT.0)IMT=IMT+1
          IF(IYY(N2).GT.0)IMT=IMT+1
          IF(IMT.GT.1)GO TO 100
        ENDIF
!
        M2=(QL(N1)+QL(N2))/2+2
        IF(BINT)THEN
          DO I=1,MAXRS
            DPA(I)=DPNL(I,N2)*DPNL(I,N1)
          ENDDO
        ELSE
          IF(QL(N2).GT.0)M2=M2-1
!
          DO I=1,MAXRS
            DPA(I)=DPNL(I,N2)/DX(I)
          ENDDO
!
          CALL DIFF(DPA,DP,MNH,DHNS,MJH)
!
          DO I=1,MAXRS
            DPA(I)=DPNL(I,N1)*DP(I)*DX(I)
          ENDDO
        ENDIF
!
        IF(BREL)THEN
          IN1=ICOL(N1,N1,IZERO)
          IN2=ICOL(N2,N2,IZERO)
          DE1=DEY(N1)-DUY(IN1)
          DE2=DEY(N2)-DUY(IN2)
          DEL=DE1-DE2                                   ! A.U.
          IF(BREL2)THEN
            DO I=1,MAXRS
              DD1=DONE+T*(DE1+DZ/DX(I))
              DD2=DONE+T*(DE2+DZ/DX(I))
!              DD1=DONE+T*(DE1+POT(I,1))
!              DD2=DONE+T*(DE2+POT(I,1))
              DSQ=DD1*DD2
              DSQ=SQRT(DSQ)
              DPA(I)=DPA(I)/DSQ
            ENDDO
          ELSE
            dnorm=rnorm(n1)*rnorm(n2)
            DO I=1,MAXRS
              DD1=DONE+DALF4*(DQNL(I,N1)/DPNL(I,N1)+DTWO*DZ/DX(I))
              if(dd1.le.dzero)dd1=done+t*(de1+dz/dx(i))
              DD2=DONE+DALF4*(DQNL(I,N2)/DPNL(I,N2)+DTWO*DZ/DX(I))
              if(dd2.le.dzero)dd2=done+t*(de2+dz/dx(i))
              DSQ=DD1*DD2
              DSQ=SQRT(DSQ)
              DPA(I)=DPA(I)*dnorm/DSQ
            ENDDO
          ENDIF
          CALL YLAMKR(M1,M2,DEL,DPA,DP,DD1,DD2,MNH,DHNS,MJH,MJ0)
        ELSE
          CALL YLAMK(M1,M2,DPA,DP,DD1,DD2,MNH,DHNS,MJH,MJ0)
        ENDIF
!
        IF(.NOT.BINT)THEN
          DO I=1,MAXRS
            DP(I)=DP(I)*DX(I)
          ENDDO
        ENDIF
!
        DO L=J,NN                             !START INNER MAGNETIC LOOP
!                                             !OVER OUTER ORBITAL PAIR
          IF(QSS(5,L).NE.M)GO TO 50
          IF(QSS(K+1,L).NE.N1)GO TO 50
          IF(QSS(K+3,L).NE.N2)GO TO 50
!
          L1=QSS(2-K,L)
          L2=QSS(4-K,L)
          JMT=0
          IF(MODE.LT.3)THEN
            IF(IYY(L1).GT.0)JMT=JMT+1
            IF(IYY(L2).GT.0)JMT=JMT+1
            IF(IMT+JMT.GT.1)GO TO 50
          ENDIF
!
          DO I=1,MAXRS
            DPA(I)=DPNL(I,L1)*DP(I)*DPNL(I,L2)
          ENDDO
!
          IF(BREL)THEN
            IL1=ICOL(L1,L1,IZERO)
            IL2=ICOL(L2,L2,IZERO)
            DE1=DEY(L1)-DUY(IL1)
            DE2=DEY(L2)-DUY(IL2)
!            DEL=DE1-DE2                                   ! A.U.
            IF(BREL2)THEN
              DO I=1,MAXRS
                DD1=DONE+T*(DE1+DZ/DX(I))
                DD2=DONE+T*(DE2+DZ/DX(I))
!                DD1=DONE+T*(DE1+POT(I,1))
!                DD2=DONE+T*(DE2+POT(I,1))
                DSQ=DD1*DD2
                DSQ=SQRT(DSQ)
                DPA(I)=DPA(I)/DSQ
              ENDDO
            ELSE
              dnorm=rnorm(l1)*rnorm(l2)
              DO I=1,MAXRS
                DD1=DONE+DALF4*(DQNL(I,L1)/DPNL(I,L1)+DTWO*DZ/DX(I))
                if(dd1.le.dzero)dd1=done+t*(de1+dz/dx(i))
                DD2=DONE+DALF4*(DQNL(I,L2)/DPNL(I,L2)+DTWO*DZ/DX(I))
                if(dd2.le.dzero)dd2=done+t*(de2+dz/dx(i))
                DSQ=DD1*DD2
                DSQ=SQRT(DSQ)
                DPA(I)=DPA(I)*dnorm/DSQ
              ENDDO
            ENDIF
          ENDIF
!
          CALL WEDDLE(DZERO,DPA,DD,MNH,DHNS,MJH,MAXRS)
!
          OVL=DONE
          IF(IRLX.EQ.2)THEN        !OVERLAPS
            KF=IGRCF(N1)
            KG=IGRCF(N2)
            IF(KG.EQ.0)KG=IGRCF(L1)
            IF(KF.NE.KG.AND.KG.GT.0)THEN
              K1=MIN(KF,KG)
              K2=MAX(KF,KG)
              KK=((K2-1)*(K2-2))/2+K1
              OVL=OVLPCF(KK)
              IF(IPAIR(KK).EQ.1)THEN
                                    !SURELY THIS CAN BE SIMPLIFIED...
                IF(IEQ(N1).EQ.IEQ(N2))THEN
                  K1=MIN(N1,N2)
                  K2=MAX(N1,N2)
                ELSEIF(IEQ(L1).EQ.IEQ(L2))THEN
                  IF(IGRCF(L1).EQ.0)GO TO 20
                  K1=MIN(L1,L2)
                  K2=MAX(L1,L2)
                ELSEIF(KF.NE.IGRCF(L1))THEN
                  IF(IEQ(N1).EQ.IEQ(L1))THEN
                    K1=MIN(N1,L1)
                    K2=MAX(N1,L1)
                  ELSEIF(IEQ(L2).EQ.IEQ(N2))THEN
                    IF(IGRCF(L2).EQ.0)GO TO 20
                    K1=MIN(L2,N2)
                    K2=MAX(L2,N2)
                  else
                    write(mw6,*)'fsint: why are we here?',kf,kg,n1,l1,  &
     &                          n2,l2
                    write(mw0,*)'fsint: why are we here?'
                    nf=-1
                    go to 200                                    !return
                  ENDIF
                ELSE
                  IF(IEQ(N1).EQ.IEQ(L2))THEN
                    K1=MIN(N1,L2)
                    K2=MAX(N1,L2)
                  ELSEIF(IEQ(L1).EQ.IEQ(N2))THEN
                    K1=MIN(L1,N2)
                    K2=MAX(L1,N2)
                  else
                    write(mw6,*)'fsint: why are we here?',kf,kg,n1,l1,  &
     &                          n2,l2
                    write(mw0,*)'fsint: why are we here?'
                    nf=-1
                    go to 200                                    !return
                  ENDIF
                ENDIF
                KK=((K2-1)*(K2-2))/2+K1
                OVL=OVL/OVLPGR(KK)
              ENDIF
            ENDIF
          ENDIF
!
   20     DNL(L)=DD*DALF4*OVL
          IF(BNRBFSI)THEN
            KK=NLI(L)
            IF(KK.GT.0)THEN
              IF(IRLX.EQ.2)THEN
                DO I=1,MENG
                  DNLI(I,KK)=DNLI(I,KK)*OVL
                ENDDO
              ENDIF
              DNLI(NREL,KK)=DNL(L)
            ENDIF
          ENDIF
!
   50   ENDDO                                            !END INNER LOOP
!
  100   KK=0
        IF(BNRBFSI)KK=NLI(J)
        IF(BPRNT0.AND.KK.EQ.0)WRITE(MW6,10010)J,(QSS(I,J),I=1,5),DNL(J)
        IF(BPRNT0.AND.KK.GT.0)WRITE(MW6,10010)J,(QSS(I,J),I=1,5),       &
     &                              (DNLI(IC,KK),IC=1,MENG)
!
      ENDDO                                              !END OUTER LOOP
!
  200 CONTINUE
!
! LOCAL
      DEALLOCATE(DPA,DP,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'FSINT: DE-ALLOCATION FAILS FOR DPA,DP'
        IF(NF.GT.0)NF=0
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(I5,3X,2(I5,I4),I6,7F14.8,1X/(32X,7F14.8))
10020 FORMAT(//5X,"N&V(   A   B    C   D  2LBD') = MAGNETIC INTEGRALS")
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE FSINT
!
!                             *******************
!
      SUBROUTINE FSINTI(ICOUNT,N,KK,FR,GR)
!
!-----------------------------------------------------------------------
!
!  SR.FSINTI CALCULATES THE TWO-BODY FINE-STRUCTURE INTEGRALS (N&V)
!  INVOLVING CONTINUUM FUNCTIONS (ORBITAL N) AT THE ICOUNT'TH
!  INTERPOLATION ENERGY, INDEXED BY KK.
!
!  IT IS CALLED BY:
!    SR.RADCON
!
!  IT CALLS:
!    SR.DIFF
!    SR.WEDDLE
!    SR.YLAMKR
!    SR.YLAMK
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DMQSS3, ONLY: QSS                                      &
     &                        ,NL000=>NL,NL=>NL000
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD
      USE COMMON_NRBAL2, ONLY: MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBFSI, ONLY: DNLI,NLI
      USE COMMON_NRBINT, ONLY: DRLI,DYY,IYY,NRLI,MENG,NREL,NLAG,NLAGP   &
     &                        ,BLAG,BBC2
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      use common_nrbtmp, only: rnorm
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION FR(*),GR(*)
!
      ALLOCATABLE :: DPA(:),DP(:)
!
!-----------------------------------------------------------------------
!
! THE NAMES HERE ARE NOT NECESSARILY SIGNIFICANT THEY ARE COMMON LEGACY.
!
! LOCAL
      ALLOCATE(DPA(MAXRS),DP(MAXRS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'FSINTI: ALLOCATION FAILS FOR DPA,DP'
        NF=0
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
      IF(NL.LT.NL000)NL=NL+1
      NN=NL000
!
      DDY=DYY(ICOUNT)
      DD=DZERO
!
      IF(BREL)THEN
        BREL2=ABS(IREL).EQ.2
        DZ=NZION
        T=DALF4*DTWO
      ENDIF
!                                                          !ELSE COMPUTE
      DO J=1,NN                      !START MAGNETIC TWO-BODY OUTER LOOP
!                                    !OVER INNER ORBITAL PAIR (YLAMK)
        KP=NLI(J)
!  ****TEST                                       108
        IF(KP.GT.0)then                   !.AND. for stupid compilers
          if(DNLI(ICOUNT,KP).NE.DZERO)GO TO 200
        endif
!
        M=QSS(5,J)
        MM=(M+2)/100
        BINT=MM.EQ.2                     !FALSE V; TRUE N
        IF(.NOT.BINT.AND.MM.NE.1)THEN
          WRITE(MW6,*)'FSINTI ERROR: ITYPE=',MM
          WRITE(MW0,*)'FSINTI ITYPE ERROR'
          KK=-1
          GO TO 300
        ENDIF
!
        M1=(M-100*MM)/2
        IF(M1.GT.MAXLAM)GO TO 200
!
        DO I=1,4              !NO ASSUMPTION ABOUT POSITION OF CONTINUUM
          IF(N.EQ.QSS(I,J))GO TO 50
        ENDDO
        GO TO 200
!
   50   IN=N                        !SUPERFLUOUS WHEN ONLY ONE CONTINUUM
        MJ=M-197
        IF(MJ.GT.0)MJ0=3                 !N
        IF(MJ.LT.0)MJ0=-3                !V
        K=0                              !V
        IF(BINT)K=1                      !N
!
        N1=QSS(K+1,J)
        N2=QSS(K+3,J)
        IF(MODE.LT.3)THEN
          IMT=0
          IF(IYY(N1).GT.0)IMT=IMT+1
          IF(IYY(N2).GT.0)IMT=IMT+1
          IF(IMT.GT.1)GO TO 200
        ENDIF
!
        BCALC=N1.EQ.IN.OR.N2.EQ.IN
!
        IF(.NOT.BLAG)GO TO 100
!
        M2=(QL(N1)+QL(N2))/2+2
        IF(BINT)THEN
          IF(N1.EQ.IN)THEN
            DO I=1,MAXRS
              DPA(I)=DPNL(I,N2)*FR(I)
            ENDDO
          ELSEIF(N2.EQ.IN)THEN
            DO I=1,MAXRS
              DPA(I)=FR(I)*DPNL(I,N1)
            ENDDO
          ELSE
            DO I=1,MAXRS
              DPA(I)=DPNL(I,N2)*DPNL(I,N1)
            ENDDO
          ENDIF
        ELSE
          IF(QL(N2).GT.0)M2=M2-1
!
          IF(N2.EQ.IN)THEN
            DO I=1,MAXRS
              DPA(I)=FR(I)/DX(I)
            ENDDO
          ELSE
            DO I=1,MAXRS
              DPA(I)=DPNL(I,N2)/DX(I)
            ENDDO
          ENDIF
!
          CALL DIFF(DPA,DP,MNH,DHNS,MJH)
!
          IF(N1.EQ.IN)THEN
            DO I=1,MAXRS
              DPA(I)=FR(I)*DP(I)*DX(I)
            ENDDO
          ELSE
            DO I=1,MAXRS
              DPA(I)=DPNL(I,N1)*DP(I)*DX(I)
            ENDDO
          ENDIF
        ENDIF
!
        IF(BREL)THEN
          IN1=ICOL(N1,N1,IZERO)
          IN2=ICOL(N2,N2,IZERO)
          DE1=DEY(N1)-DUY(IN1)
          DE2=DEY(N2)-DUY(IN2)
          DEL=DE1-DE2                                   ! A.U.
          IF(BREL2)THEN
            IF(N1.EQ.IN)DE1=DDY
            IF(N2.EQ.IN)DE2=DDY
            DO I=1,MAXRS
              DD1=DONE+T*(DE1+DZ/DX(I))
              DD2=DONE+T*(DE2+DZ/DX(I))
!              DD1=DONE+T*(DE1+POT(I,1))
!              DD2=DONE+T*(DE2+POT(I,1))
              DPA(I)=DPA(I)/SQRT(DD1*DD2)
            ENDDO
          ELSE
            dnorm=rnorm(n1)*rnorm(n2)          !use nrel value
            IF(N1.EQ.IN)THEN
              DE1=DDY
              DO I=1,MAXRS
                DD1=DONE+DALF4*(GR(I)/FR(I)+DTWO*DZ/DX(I))
                DD2=DONE+DALF4*(DQNL(I,N2)/DPNL(I,N2)+DTWO*DZ/DX(I))
                if(dd1.le.dzero)dd1=done+t*(de1+dz/dx(i))
                if(dd2.le.dzero)dd2=done+t*(de2+dz/dx(i))
                DPA(I)=DPA(I)*dnorm/SQRT(DD1*DD2)
              ENDDO
            ELSEIF(N2.EQ.IN)THEN
              DE2=DDY
              DO I=1,MAXRS
                DD1=DONE+DALF4*(DQNL(I,N1)/DPNL(I,N1)+DTWO*DZ/DX(I))
                DD2=DONE+DALF4*(GR(I)/FR(I)+DTWO*DZ/DX(I))
                if(dd1.le.dzero)dd1=done+t*(de1+dz/dx(i))
                if(dd2.le.dzero)dd2=done+t*(de2+dz/dx(i))
                DPA(I)=DPA(I)*dnorm/SQRT(DD1*DD2)
              ENDDO
            ELSE
              DO I=1,MAXRS
                DD1=DONE+DALF4*(DQNL(I,N1)/DPNL(I,N1)+DTWO*DZ/DX(I))
                DD2=DONE+DALF4*(DQNL(I,N2)/DPNL(I,N2)+DTWO*DZ/DX(I))
                if(dd1.le.dzero)dd1=done+t*(de1+dz/dx(i))
                if(dd2.le.dzero)dd2=done+t*(de2+dz/dx(i))
                DPA(I)=DPA(I)*dnorm/SQRT(DD1*DD2)
              ENDDO
            ENDIF
          ENDIF
          CALL YLAMKR(M1,M2,DEL,DPA,DP,DD1,DD2,MNH,DHNS,MJH,MJ0)
        ELSE
          CALL YLAMK(M1,M2,DPA,DP,DD1,DD2,MNH,DHNS,MJH,MJ0)
        ENDIF
!
        IF(.NOT.BINT)THEN
          DO I=1,MAXRS
            DP(I)=DP(I)*DX(I)
          ENDDO
        ENDIF
!
  100   DO L=J,NN                             !START INNER MAGNETIC LOOP
!                                             !OVER OUTER ORBITAL PAIR
          IF(QSS(5,L).NE.M)GO TO 150
          IF(QSS(K+1,L).NE.N1)GO TO 150
          IF(QSS(K+3,L).NE.N2)GO TO 150
!
          L1=QSS(2-K,L)
          L2=QSS(4-K,L)
          JMT=0
          IF(MODE.LT.3)THEN
            IF(IYY(L1).GT.0)JMT=JMT+1
            IF(IYY(L2).GT.0)JMT=JMT+1
            IF(IMT+JMT.ne.1)GO TO 150   !NEED ONE AND ONLY ONE CONTINUUM
          ENDIF
!
          IF(.NOT.BCALC)THEN                      !NOT YET MATCHED ORB N
            IF(L1.NE.IN.AND.L2.NE.IN)GO TO 150    !NOT FOUND
          ENDIF
!
          IF(.NOT.BLAG)GO TO 120
!
          IF(L1.EQ.IN)THEN
            DO I=1,MAXRS
              DPA(I)=FR(I)*DP(I)*DPNL(I,L2)
            ENDDO
          ELSEIF(L2.EQ.IN)THEN
            DO I=1,MAXRS
              DPA(I)=DPNL(I,L1)*DP(I)*FR(I)
            ENDDO
          ELSE
            DO I=1,MAXRS
              DPA(I)=DPNL(I,L1)*DP(I)*DPNL(I,L2)
            ENDDO
          ENDIF
!
          IF(BREL)THEN
            IL1=ICOL(L1,L1,IZERO)
            IL2=ICOL(L2,L2,IZERO)
            DE1=DEY(L1)-DUY(IL1)
            DE2=DEY(L2)-DUY(IL2)
            IF(BREL2)THEN
              IF(L1.EQ.IN)DE1=DDY
              IF(L2.EQ.IN)DE2=DDY
              DO I=1,MAXRS
                DD1=DONE+T*(DE1+DZ/DX(I))
                DD2=DONE+T*(DE2+DZ/DX(I))
!                DD1=DONE+T*(DE1+POT(I,1))
!                DD2=DONE+T*(DE2+POT(I,1))
                DPA(I)=DPA(I)/SQRT(DD1*DD2)
              ENDDO
            ELSE
              dnorm=rnorm(l1)*rnorm(l2)         !use nrel value
              IF(L1.EQ.IN)THEN
!                DE1=DDY
                DO I=1,MAXRS
                  DD1=DONE+DALF4*(GR(I)/FR(I)+DTWO*DZ/DX(I))
                  DD2=DONE+DALF4*(DQNL(I,L2)/DPNL(I,L2)+DTWO*DZ/DX(I))
                  if(dd1.le.dzero)dd1=done+t*(de1+dz/dx(i))
                  if(dd2.le.dzero)dd2=done+t*(de2+dz/dx(i))
                  DPA(I)=DPA(I)*dnorm/SQRT(DD1*DD2)
                ENDDO
              ELSEIF(L2.EQ.IN)THEN
!                DE2=DDY
                DO I=1,MAXRS
                  DD1=DONE+DALF4*(DQNL(I,L1)/DPNL(I,L1)+DTWO*DZ/DX(I))
                  DD2=DONE+DALF4*(GR(I)/FR(I)+DTWO*DZ/DX(I))
                  if(dd1.le.dzero)dd1=done+t*(de1+dz/dx(i))
                  if(dd2.le.dzero)dd2=done+t*(de2+dz/dx(i))
                  DPA(I)=DPA(I)*dnorm/SQRT(DD1*DD2)
                ENDDO
              ELSE
                DO I=1,MAXRS
                  DD1=DONE+DALF4*(DQNL(I,L1)/DPNL(I,L1)+DTWO*DZ/DX(I))
                  DD2=DONE+DALF4*(DQNL(I,L2)/DPNL(I,L2)+DTWO*DZ/DX(I))
                  if(dd1.le.dzero)dd1=done+t*(de1+dz/dx(i))
                  if(dd2.le.dzero)dd2=done+t*(de2+dz/dx(i))
                  DPA(I)=DPA(I)*dnorm/SQRT(DD1*DD2)
                ENDDO
              ENDIF
            ENDIF
          ENDIF
!
          CALL WEDDLE(DZERO,DPA,DD,MNH,DHNS,MJH,MAXRS)
!
  120     KP=NLI(L)
          IF(KP.LE.0)THEN
            KK=KK+1
            IF(KK.GT.IXFSS)GO TO 150
            KP=KK
            NLI(L)=KK
          ENDIF
!
          DNLI(ICOUNT,KP)=DD*DALF4
!
  150   ENDDO                                            !END INNER LOOP
!
! **TEST PRINT
!  108 KP=NLI(J)
!      WRITE(MW6,140)ICOUNT,J,(QSS(I,J),I=1,5),DNLI(ICOUNT,KP)
!  140 FORMAT(2I5,3X,2(I5,I4),I6,F14.8)
!
  200 ENDDO                                              !END OUTER LOOP
!
!-----------------------------------------------------------------------
!
  300 CONTINUE
!
! LOCAL
      DEALLOCATE(DPA,DP,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'FSINTI: DE-ALLOCATION FAILS FOR DPA,DP'
        NF=0
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE FSINTI
!
!                             *******************
!
      SUBROUTINE FSINTX(FRX,PSHFTX,MDIM1,MDIM2,MDIM3                    &
     &                 ,DNL                                             &
     &                 ,M1,M2,JNEW,MPOSC)
!
!-----------------------------------------------------------------------
!
!  SR.FSINTX CALCULATES THE DEIE TWO-BODY FINE-STRUCTURE INTEGRALS (N&V)
!
!  THE FOUR ELECTRON-ARGUMENTS (1,2,3.. FOR 1S,2S,2P..) HAVE BEEN
!  STORED IN QSS(I,L),I=1,4, AND 2*LAMBDA IN QSS(5,L).
!
!  IT IS CALLED BY:
!   SR.DWXBP_DAXPY
!   SR.DWXBP_DDOT
!
! IT CALLS:
!   SR.VNRKX
!   SR.VNYKX
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DMQSS3, ONLY: QSS                                      &
     &                        ,NL000=>NL,NL=>NL000
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
!
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDW5, ONLY: DYY,MENG,NLAG
      USE COMMON_NRBDW6, ONLY: QPOS,QPOS0
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      use common_nrbtmp, only: rnorm
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION FRX(MDIM1,MDIM2,MDIM3),PSHFTX(MDIM2,MDIM3)              &
     &         ,DNL(*)
!
      ALLOCATABLE :: DPA(:),DP(:)
!
!-----------------------------------------------------------------------
!
! THE NAMES HERE ARE NOT NECESSARILY SIGNIFICANT THEY ARE COMMON LEGACY.
!
! LOCAL
      ALLOCATE(DPA(MAXRS),DP(MAXRS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'FSINTX: ALLOCATION FAILS FOR DPA,DP'
        NF=0
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
! SUPPRESS COMPILER WARNINGS (SIGH...)
!
      DUM=PSHFTX(1,1)
!
      NN=NL000
!
      BPRNT0=JPRINT.GE.4                      !FOR DETAILED PRINTOUT
!      BPRNT0=JPRINT.NE.-3
      BREL2=ABS(IREL).EQ.2
!
      MAXRS1=MAXRS
      IF(BREL2)MAXRS1=MAXRS1+1
!
      IF(BPRNT0)WRITE(MW6,10020)M1,DYY(M1),M2,DYY(M2)
!
! INITIALIZE
!
      DO J=1,NN
        DNL(J)=DZERO
      ENDDO
!
! OUTER LOOP TO DETERMINE FINE-STRUCTURE INETGRALS
!
      DO J=1,NN                      !START MAGNETIC TWO-BODY OUTER LOOP
!                                    !OVER INNER ORBITAL PAIR (YLAMK)
        IF(DNL(J).NE.DZERO)GO TO 100
!
        M5=QSS(5,J)
        IF(M5.LT.100.OR.M5.LT.198.AND.M5.GT.160+JNEW)GO TO 100
                                                  !NO NEED FOR THIS JTOT
!
        MM=(M5+2)/100
        BINT=MM.EQ.2                     !FALSE V; TRUE N
        IF(.NOT.BINT.AND.MM.NE.1)THEN
          WRITE(MW6,*)'FSINTX ERROR: ITYPE=',MM
          WRITE(MW6,*)'J',J,'  QSS(J):',(QSS(M,J),M=1,5)
          WRITE(MW0,*)'FSINTX ITYPE ERROR'
          NF=-1
          GO TO 200                                              !RETURN
        ENDIF
!
        MI=(M5-100*MM)/2
        IF(MI.GT.MXLAMX)GO TO 100
!
        K=0                              !V
        IF(BINT)K=1                      !N
!
        N1=QSS(K+1,J)
        N2=QSS(K+3,J)
        IF(QL(N1).LT.0)GO TO 100
        IF(QL(N2).LT.0)GO TO 100
!
        ML=(QL(N1)+QL(N2))/2+2
        IF(.NOT.BINT.AND.QL(N2).GT.0)ML=ML-1
!
        if(brel)dnorm=rnorm(n1)*rnorm(n2)
!
! DETERMINE "YLAMK"
!
        IF(QN(N1).LT.0)THEN
          Q1=QPOS(N1-MPOSC)
          q1=abs(q1)
          DE1=DYY(M1)/DTWO
        ELSE
          IN1=ICOL(N1,N1,IZERO)
          DE1=DEY(N1)-DUY(IN1)
        ENDIF
!
        IF(QN(N2).LT.0)THEN
          Q2=QPOS(N2-MPOSC)
          q2=abs(q2)
          DE2=DYY(M2)/DTWO
          IF(QN(N1).LT.0)THEN
! ICASE=1
            CALL VNYKX(FRX(1,M1,Q1),FRX(1,M2,Q2),FRX(MAXRS1,M1,Q1),     &
     &                 FRX(MAXRS1,M2,Q2),BINT,MI,ML,DE1,DE2,DPA,DP,DX,  &
     &                 dnorm)
          ELSE
! ICASE=3
            M=M1
            CALL VNYKX(DPNL(1,N1),FRX(1,M2,Q2),DQNL(1,N1),              &
     &                 FRX(MAXRS1,M2,Q2),BINT,MI,ML,DE1,DE2,DPA,DP,DX,  &
     &                 dnorm)
          ENDIF
        ELSE
          IN2=ICOL(N2,N2,IZERO)
          DE2=DEY(N2)-DUY(IN2)
          IF(QN(N1).LT.0)THEN
! ICASE=2
!            if(bint)then                             !and falling order
!              m0=m2
!              m=m1
!              de1=dyy(m2)/dtwo
!            else
            M0=M1
            M=M2
!            endif
            CALL VNYKX(FRX(1,M0,Q1),DPNL(1,N2),FRX(MAXRS1,M0,Q1),       &
     &                 DQNL(1,N2),BINT,MI,ML,DE1,DE2,DPA,DP,DX,dnorm)
          ELSE
! ICASE=4
            M=M1
            CALL VNYKX(DPNL(1,N1),DPNL(1,N2),DQNL(1,N1),DQNL(1,N2),BINT,&
     &                 MI,ML,DE1,DE2,DPA,DP,DX,dnorm)
          ENDIF
        ENDIF
!
        DO L=J,NN                             !START INNER MAGNETIC LOOP
!                                             !OVER OUTER ORBITAL PAIR
          IF(QSS(5,L).NE.M5)GO TO 50
          IF(QSS(K+1,L).NE.N1)GO TO 50
          IF(QSS(K+3,L).NE.N2)GO TO 50
          L1=QSS(2-K,L)
          L2=QSS(4-K,L)
          IF(QL(L1).LT.0)GO TO 50
          IF(QL(L2).LT.0)GO TO 50
!
          if(brel)dnorm=rnorm(l1)*rnorm(l2)
!
! DETERMINE "RK" (A.U.)
!
          IF(QN(L1).LT.0)THEN
            Q1=QPOS(L1-MPOSC)
            q1=abs(q1)
            DE1=DYY(M)/DTWO
          ELSE
            IL1=ICOL(L1,L1,IZERO)
            DE1=DEY(L1)-DUY(IL1)
          ENDIF
!
          IF(QN(L2).LT.0)THEN
            Q2=QPOS(L2-MPOSC)
            q2=abs(q2)
            DE2=DYY(M2)/DTWO
            IF(QN(L1).LT.0)THEN
! JCASE=4
              CALL VNRKX(FRX(1,M1,Q1),FRX(1,M2,Q2),FRX(MAXRS1,M1,Q1),   &
     &                   FRX(MAXRS1,M2,Q2),DE1,DE2,DPA,DP,DX,dnorm,DD)
            ELSE
! JCASE=2
              CALL VNRKX(DPNL(1,L1),FRX(1,M,Q2),DQNL(1,L1),             &
     &                   FRX(MAXRS1,M,Q2),DE1,DE2,DPA,DP,DX,dnorm,DD)
            ENDIF
          ELSE
            IL2=ICOL(L2,L2,IZERO)
            DE2=DEY(L2)-DUY(IL2)
            IF(QN(L1).LT.0)THEN
! JCASE=3
              CALL VNRKX(FRX(1,M,Q1),DPNL(1,L2),FRX(MAXRS1,M,Q1),       &
     &                   DQNL(1,L2),DE1,DE2,DPA,DP,DX,dnorm,DD)
            ELSE
! JCASE=1
              CALL VNRKX(DPNL(1,L1),DPNL(1,L2),DQNL(1,L1),DQNL(1,L2),   &
     &                   DE1,DE2,DPA,DP,DX,dnorm,DD)
            ENDIF
          ENDIF
!
          DNL(L)=DD
!
   50   ENDDO                                            !END INNER LOOP
!
  100   IF(BPRNT0)WRITE(MW6,10010)J,(QSS(I,J),I=1,5),DNL(J)
!
      ENDDO                                              !END OUTER LOOP
!
!-----------------------------------------------------------------------
!
  200 CONTINUE
!
! LOCAL
      DEALLOCATE(DPA,DP,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'FSINTX: DE-ALLOCATION FAILS FOR DPA,DP'
        IF(NF.GT.0)NF=0
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(I5,3X,2(I5,I4),I6,F14.8)
10020 FORMAT(/5X,"N&V(   A   B    C   D  2LBD') = MAGNETIC INTEGRALS",  &
     &       3X,'FOR    E(',I2,')=',F10.3,5X,'E(',I2,')=',F10.3,'  RYD')
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE FSINTX
!
!                             *******************
!
      SUBROUTINE FZALF(ZEFF,I,SLFE)
!
!-----------------------------------------------------------------------
!
!  This routine obtains an estimate of the self energy contribution
!  to the energy resulting from either 1s, 2s, 2p- or 2p orbital in
!  the field of a point nucleus with effective charge ZEFF.
!  The values are interpolated among the values supplied by P.J. Mohr
!
!  Subroutine called: INTRPG
!
!  Based on PHN's GRASP0 routine and freely adapted by NRB.
!
!  IT IS CALLED BY:
!    SR.QEDINT
!
!  IT CALLS:
!    SR.INTRPG
!
!-----------------------------------------------------------------------
!
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION ARG(11),VAL1S(11),VAL2P1(11)
      DIMENSION VAL2P3(11),VAL2S(11)
!
!-----------------------------------------------------------------------
!
!  1s data :
!
      DATA VAL1S/4.654_WP,3.246_WP,2.5519_WP,2.1351_WP,1.8644_WP        &
     &,1.6838_WP,1.5675_WP,1.5032_WP,1.4880_WP,1.5317_WP,1.6614_WP/
!
!  2s data :
!
      DATA VAL2S/4.8930_WP,3.5063_WP,2.8391_WP,2.4550_WP,2.2244_WP      &
     &,2.0948_WP,2.0435_WP,2.0650_WP,2.1690_WP,2.3870_WP,2.7980_WP/
!
!  2p- data :
!
      DATA VAL2P1/-0.1145_WP,-0.0922_WP,-0.0641_WP,-0.0308_WP,0.0082_WP &
     &,0.0549_WP,0.1129_WP,0.1884_WP,0.2934_WP,0.4530_WP,0.7250_WP/
!
!  2p data
!
      DATA VAL2P3/0.1303_WP,0.1436_WP,0.1604_WP,0.1794_WP,0.1999_WP     &
     &,0.2215_WP,0.2440_WP,0.2671_WP,0.2906_WP,0.3141_WP,0.3367_WP/
!
!  Z data values :
!
      DATA ARG/10.0_WP,20.0_WP,30.0_WP,40.0_WP,50.0_WP,60.0_WP,70.0_WP  &
     &,80.0_WP,90.0_WP,100.0_WP,110.0_WP/
!
!  Number of data points
!
      DATA NUMVAL/11/
!
!-----------------------------------------------------------------------
!
      IF(QN(I).EQ.1)THEN
!
!  1s case
!
        CALL INTRPG(ARG,VAL1S,ZEFF,NUMVAL,SLFE)
!
      ELSE
!
!  ns case
!
        IF(QL(I).EQ.0)THEN
!
          CALL INTRPG(ARG,VAL2S,ZEFF,NUMVAL,SLFE)
!
        ELSEIF(QL(I).EQ.2)THEN
!
!  np- case
!
          CALL INTRPG(ARG,VAL2P1,ZEFF,NUMVAL,SLFE1)
!
!  np case
!
          CALL INTRPG(ARG,VAL2P3,ZEFF,NUMVAL,SLFE3)
!
! FORM KAPPA AVERAGE
!
          SLFE=(SLFE1+DTWO*SLFE3)/DTHREE
!
        ELSE
!
          SLFE=DZERO
!
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE FZALF
!
!***********************************************************************
!
! GAMMA FUNCTION LIBRARY (FOR NON-F2008)
!
!***********************************************************************
!
      FUNCTION GAMA7(XX)
!
!-----------------------------------------------------------------------
!
!  FN.GAMA7 EVALUATES THE GAMMA FUNCTION OF ARGUMENT X,
!  USING THE 7-POINT APPROXIMATE FORM OF ABRAMOWITZ AND STEGUN.
!
!  IT IS CALLED BY:
!    FN.WHITEX
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
! LARGEST GAMA7 ARGUMENT FOR WP=4,8,16
      PARAMETER (ARGFCT=34*((WP/4)**2+(WP-4)/4)*(1+9*nint(real(WP)/16)))
!
      PARAMETER (C1=0.57710166_WP)
      PARAMETER (C2=0.98585399_WP)
      PARAMETER (C3=0.87642182_WP)
      PARAMETER (C4=0.8328212_WP)
      PARAMETER (C5=0.5684729_WP)
      PARAMETER (C6=0.25482049_WP)
      PARAMETER (C7=0.05149930_WP)
!
!-----------------------------------------------------------------------
!
      IER=2
      X=XX
      IF(ABS(X).GT.ARGFCT)GO TO 300
!
      GX=DONE
  100 IF(X.GE.DTWO)THEN
        X=X-DONE
        GX=GX*X
        GO TO 100
      ENDIF
!
      XMIN=TINY(XMIN)
      IF(X.LT.XMIN)THEN
        IER=1
        Y=REAL(NINT(X,SP),WP)-X
        IF(ABS(Y).LT.XMIN)GO TO 300
      ENDIF
!
  200 IF(X.EQ.DONE)THEN
        GAMA7=GX
        RETURN
      ENDIF
      IF(X.LT.DONE)THEN
        GX=GX/X
        X=X+DONE
        GO TO 200
      ENDIF
!
      Y=X-DONE
      GX=(((((((-C7*Y+C6)*Y-C5)*Y+C4)*Y-C3)*Y+C2)*Y-C1)*Y+DONE)*GX
!
      GAMA7=GX
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
! SHOULD NOT OCCUR AS ALL USES OF GAMA7 CHECK FOR VALID RANGE BEFOREHAND
!
  300 WRITE(MW6,10010)IER
      WRITE(MW0,*)'***ERROR IN FUNCTION GAMA7'
      STOP '***ERROR IN FUNCTION GAMA7'
10010 FORMAT('***ERROR',I3,' IN FUNCTION GAMA7')
!
!-----------------------------------------------------------------------
!
      END FUNCTION GAMA7
!
!                             *******************
!
      FUNCTION GAMA(X)
!
!-----------------------------------------------------------------------
!
!  FN.GAMA EVALUATES THE GAMMA FUNCTION OF ARGUMENT X>-4 USING A
!  6-POINT LANCZOS' FORMULA. THUS, GIVEN THE SUBTRACTION OF THE
!  FIRST 6 POLES, IT CAN BE USED FOR X>-5 EXCLUDING -4,-3,-2,-1,0.
!  BUT IT IS BEST RESTRICTED TO >-4. <-6 WILL LIKELY GIVE NaNs.
!
!  IT IS CALLED BY:
!    SR.BDCF3
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
! LARGEST GAMA ARGUMENT FOR WP=4,8,16
      PARAMETER (ARGFCT=34*((WP/4)**2+(WP-4)/4)*(1+9*nint(real(WP)/16)))
!
      PARAMETER (NMAX=6)
!
      DIMENSION COEF(NMAX)
!
      DATA COEF,STP,SER0 /76.18009172947146D0,  -86.50532032941677D0,   &
     &                    24.01409824083091D0,   -1.231739572450155D0,  &
     &                     0.1208650973866179D-2,-0.5395239384953D-5,   &
     &                     2.5066282746310005D0,  1.000000000190015D0/
!
      IF(X.GT.ARGFCT)THEN
        WRITE(MW6,*)                                                    &
     &            '***ERROR IN FN.GAMA: ARGUMENT TOO LARGE (OVERFLOW) ='&
     &            ,X
        IF(X.GT.DZERO)WRITE(MW6,*)'*** USE LOG(GAMMA)? E.G.FN.GAMLN ***'
        WRITE(MW0,*)'***ERROR IN FN.GAMA: ARGUMENT TOO LARGE (OVERFLOW)'
        GO TO 100
      ENDIF
!
      XMIN=TINY(XMIN)
      IF(X.LT.XMIN)THEN
        IX=NINT(X,SP)
        XX=ABS(X-REAL(IX,WP))
        IF(XX.LT.XMIN)THEN
          WRITE(MW6,*)'***ERROR IN FN.GAMA: ARGUMENT NEGATIVE INTEGER ='&
     &                ,X
          WRITE(MW0,*)'***ERROR IN FN.GAMA: ARGUMENT NEGATIVE INTEGER'
          GO TO 100
        ENDIF
        IF(X.LT.-DFOUR)THEN
          WRITE(MW6,*)'***ERROR IN FN.GAMA: ARGUMENT NEGATIVE, .LT.-4 ='&
     &                ,X
          WRITE(MW6,*)'*** USE FN.GAMA7?'
          WRITE(MW0,*)'***ERROR IN FN.GAMA: ARGUMENT NEGATIVE, .LT.-4'
          GO TO 100
        ENDIF
      ENDIF
!
      G=NMAX-1
      TE=X+DHALF
      TMP=G+TE
      TH=EXP(-TMP*DHALF)*TMP**(TE*DHALF)
      TMP=TH*TH
!
      SER=SER0
      Y=X
!
      DO J=1,NMAX
        Y=Y+DONE
        SER=SER+COEF(J)/Y
      ENDDO
!
      GAMA=TMP*STP*SER/X
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
! SHOULD NOT OCCUR AS ALL USES OF GAMA CHECK FOR VALID RANGE BEFOREHAND
!
  100 STOP '***ERROR IN FUNCTION GAMA...'
!
!-----------------------------------------------------------------------
!
      END FUNCTION GAMA
!
!                             *******************
!
      FUNCTION GAMLN(X)
!
!-----------------------------------------------------------------------
!
!  FN.GAMLN EVALUATES THE LOG OF THE ABS(GAMMA) OF ARGUMENT X>-4 USING A
!  6-POINT LANCZOS' FORMULA. THUS, GIVEN THE SUBTRACTION OF THE
!  FIRST 6 POLES, IT CAN BE USED FOR X>-5 EXCLUDING -4,-3,-2,-1,0.
!  BUT IT IS BEST RESTRICTED TO >-4. <-6 WILL LIKELY GIVE NaNs.
!
!  IT IS CALLED BY:
!    FN.WHITEX
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (NMAX=6)
!
      DIMENSION COEF(NMAX)
!
      DATA COEF,STP,SER0 /76.18009172947146D0,  -86.50532032941677D0,   &
     &                    24.01409824083091D0,   -1.231739572450155D0,  &
     &                     0.1208650973866179D-2,-0.5395239384953D-5,   &
     &                     2.5066282746310005D0,  1.000000000190015D0/
!
      XMIN=TINY(XMIN)
      IF(X.LE.XMIN)THEN
        IX=NINT(X)
        XX=ABS(X-IX)
        IF(XX.LT.XMIN)THEN
          WRITE(MW6,*)'***ERROR IN FN.GAMLN: ARGUMENT NEGATIVE INTEGER='&
     &                ,X
          WRITE(MW0,*)'***ERROR IN FN.GAMLN: ARGUMENT NEGATIVE INTEGER'
          GO TO 100
        ENDIF
        IF(X.LT.-DFOUR)THEN
          WRITE(MW6,*)'***ERROR IN FN.GAMLN: ARGUMENT NEGATIVE .LT.-4 ='&
     &                ,X
          WRITE(MW0,*)'***ERROR IN FN.GAMLN: ARGUMENT NEGATIVE .LT.-4'
          GO TO 100
        ENDIF
      ENDIF
!
      G=NMAX-1
      TE=X+DHALF
      TMP=G+TE
      TMP=TE*LOG(TMP)-TMP
!
      SER=SER0
      Y=X
!
      DO J=1,NMAX
        Y=Y+DONE
        SER=SER+COEF(J)/Y
      ENDDO
!
      Y=ABS(STP*SER/X)
      GAMLN=TMP+LOG(Y)
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
! SHOULD NOT OCCUR AS ALL USES OF GAMLN CHECK FOR VALID RANGE BEFOREHAND
!
  100 STOP '***ERROR IN FUNCTION GAMLN...'
!
!-----------------------------------------------------------------------
!
      END FUNCTION GAMLN
!
!                             *******************
!
      SUBROUTINE HDIAG(CEV,CUL,NMAX,NE,EU,DU,MAXNJ,DEV,WRK,NF,INFO)
!
!-----------------------------------------------------------------------
!
! SR.HDIAG DIAGONALIZES A REAL SYMMETRIC (HAMILTONIAN) MATRIX
!    THERE ARE SEVERAL ROUTINES CODED-FOR.
!
!    ON INPUT:
!
!        CEV   .EQ. 'V' OR 'N' SPECIFIES WHETHER E-VECTORS ARE REQUIRED,
!              OR NOT. IT IS ONLY APPLICABLE FOR LAPACK DIAGONALIZERS.
!
!        CUL   .EQ. 'U' OR 'L' SPECIFIES WHETHER THE UPPER OR LOWER
!              TRIANGLE OF DU IS REFERNCED. NON-LAPACK WILL SYMMETRIZE
!              AS NECESSARY.
!
!     DU(:,:)  CONTAINS THE CUL TRIANGLE MATRIX OF ORDER NMAX
!              AND ROW DIMENSION MAXNJ.
!
!         NE   SPECIFIES THE NUMBER OF E-VALUES AND E-VECTORS REQUIRED.
!              A VALID RANGE IS  1 .LE. NE .LE. NMAX
!              AND REQUIRES DSYEVX TO BE ACTIVATED (SEE DSYEVR NOTE)
!         EU   SPECIFIES THE RANGE OF E-VALUES AND E-VECTORS REQUIRED
!              A VALID RANGE IS -INFTY .LT. EU .LT. ZERO.
!        ***   IF A VALID RANGE IS NOT SPECIFIED THEN *ALL* NMAX
!              ARE CALCULATED, USING DSYEVD (IF ACTIVE) OR SR.DIAG.
!              (THE RANGE [1,NMAX] ALSO USES DSYEVD/SR.DIAG.)
!
!        INFO  SHOULD BE SET ZERO ON THE FIRST CALL TO SR.HDIAG.
!              IF A LAPACK ROUTINE FAILS IT IS RESET NON-ZERO AND
!              A SUBSEQUENT CALL TO SR.HDIAG WILL USE SR.DIAG INSTEAD,
!              UNLESS THE USER CODE RESETS IT ZERO AGAIN...
!              THE USER NEEDS TO RE-LOAD DU FOR USE BY SR.DIAG.
!              INFO IS THEN RE-SET ZERO ON OUTPUT SO THAT THE LAPACK
!              ROUTINE IS USED AGAIN FOR THE NEXT DIAGONALIZATION.
!
!       IDIAG  .GT. 0  OVERRIDES EVERYTHING AND USES THE HISTORIC
!              (VERY) SLOW SR.JACORD.
!
!    ON OUTPUT:
!
!     DU(:,:)  CONTAINS THE E-VECTORS
!     DEV(:)   CONTAINS THE E-VALUES.
!              THEY ARE ORDERED BY DOMINANT E-VECTOR COMPONENT.
!              IF A RANGE WAS SPECIFIED, THOSE ENTRIES NOT DETERMINED
!              ARE ZEROED-OUT.
!          NE  IF EU SPECIFIED A RANGE OF ENERGIES THEN NE NOW CONTAINS
!              THE NUMBER OF E-STATES FOUND.
!
!        INFO  SEE INPUT.
!
!         WRK IS A WORK VECTOR OF LENGTH AT LEAST NMAX.
!
!   NOTE: WHILE IN PRINCIPLE DSYEVR IS A REPLACEMENT FOR DSYEVD AND
!         DSYEVX, BEING AS FAST AS DSYEVD AND ALLOWING A RANGE OF
!         E-STATES AS DSYEVX, IT IS NOT PORTABLE. IT REQUIRES IEEE
!         COMPLIANCE WRT NANS AND INFINITES (I.E. NO F.P. TRAPPING)
!         AND VENDOR LIBRARIES TEND TO FORCE SUCH MEANING
!         IT MAKES A SLOW DSYEVX-LIKE OPERATION INSTEAD.
!         HWOEVER, IT ONLY USES N*N WORKSPACE, AS OPPOSED TO 2*N*N
!         AND THAT CAN BE CRITICAL FOR LARGE MATRICES (N.GT.32766)
!         WHICH REQUIRE A DIRECT INTERFACE WITH 64-BIT INTEGER ROUTINES
!
!  IT IS CALLED BY:
!    SR.DIAGFS
!    SR.DIAGON
!
!  IT CALLS:
!    SR.DIAG
!    SR.JACORD
!    SR.DSYEVD                                                   !LAPACK
!    SR.DSYEVR                                                   !LAPACK
!    SR.DSYEVX                                                   !LAPACK
!
!-----------------------------------------------------------------------
!
      USE COMMON_MISC,   ONLY: IDIAG,LDIAG
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (EPSR=D1M12)                                     !LAPACK
      PARAMETER (EPSX=D1M12)                                     !LAPACK
!                                                                !LAPACK
      CHARACTER(LEN=1) CRNG                                      !LAPACK
      CHARACTER(LEN=6) DDIAG                                     !LAPACK
      CHARACTER(LEN=1) CEV,CUL
!
      ALLOCATABLE :: DSV(:,:),IWRK1(:),IWRK2(:)
      ALLOCATABLE :: WORK(:),IWORK(:),ISUPP(:)                   !LAPACK
!
      DIMENSION DU(MAXNJ,*),DEV(*),WRK(*)
!
!
      DATA IWARN/0/
!
!-----------------------------------------------------------------------
!
      IF(NMAX.EQ.1)THEN                                    !QUICK RETURN
        IF(EU.GE.DZERO.OR.DU(1,1).LT.EU)THEN
          DEV(1)=DU(1,1)
          DU(1,1)=DONE
        ELSE
          DEV(1)=DZERO
          DU(1,1)=DZERO
        ENDIF
        RETURN
      ENDIF
!
      IL=1                                             !FIXED, CURRENTLY
      IU=NE
!
      VL=-D1P30      !FIXED, CURRENTLY                           !LAPACK
      VU=EU          !TAKES PRECEDENCE IF .LT.0                  !LAPACK
!
      IF(EU.GE.DZERO)THEN
        BALL=IL.EQ.1.AND.IU.EQ.NMAX.OR.IL.LT.1..OR.IU.GT.NMAX.OR.       &
     &       IL.GT.IU
      ELSE
        BALL=.FALSE.
      ENDIF
!
      LDABS=ABS(LDIAG)                                           !LAPACK
      IF(.NOT.BALL.AND.LDABS.EQ.1)LDABS=3     ! DSYEVD->DSYEVX   !LAPACK
!
!-----------------------------------------------------------------------
!
      IF(IDIAG.LE.0)THEN
!
        ALLOCATE(IWRK1(NMAX),IWRK2(NMAX),STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)' HDIAG: ALLOCATION FAILS FOR IWRK1,IWRK2'
          GO TO 100
        ENDIF
!
        IF(INFO.GT.0)GO TO 7200     !PREVIOUS LAPACK FAILURE     !LAPACK
!
        INFO=1                                            !FLAG FOR DIAG
!
!-----------------------------------------------------------------------
!
! ALL LAPACK                                                     !LAPACK
!                                                                !LAPACK
        IF(BALL)THEN                                             !LAPACK
          CRNG='A'                                               !LAPACK
          NEIGEN=NMAX                                            !LAPACK
        ELSE                                                     !LAPACK
          IF(EU.GE.DZERO)THEN                                    !LAPACK
            CRNG='I'                                             !LAPACK
            NEIGEN=IU-IL+1                                       !LAPACK
          ELSE                                                   !LAPACK
            CRNG='V'                                             !LAPACK
            NEIGEN=NMAX                                          !LAPACK
          ENDIF                                                  !LAPACK
        ENDIF                                                    !LAPACK
!                                                                !LAPACK
        INFOSVD=0                                                !LAPACK
!                                                                !LAPACK
        LIWORK=1                                                 !LAPACK
        LWORK=1                                                  !LAPACK
        LBLK=64                                                  !LAPACK
!                                                                !LAPACK
        IF(LDABS.EQ.0)THEN                                       !LAPACK
!                                                                !LAPACK
! FOR DSYEV                                                      !LAPACK
          DDIAG='DSYEV'                                          !LAPACK
! MIN                                                            !LAPACK
          LWORK=MAX(LWORK,3*NMAX-1)                              !LAPACK
! OPT                                                            !LAPACK
          LBK=ILAENV(IONE,'DSYTRD',CUL,NMAX,-IONE,-IONE,-IONE)   !LAPACK
          LBLK=MAX(LBLK,LBK)                                     !LAPACK
          LWORK=MAX(LWORK,(LBLK+2)*NMAX)                         !LAPACK
!                                                                !LAPACK
          ALLOCATE(WORK(LWORK)                                          &!LAPACK
     &            ,STAT=IERR)                                    !LAPACK
!                                                                !LAPACK
        ELSEIF(LDABS.EQ.1)THEN                                   !LAPACK
!                                                                !LAPACK
! FOR DSYEVD                                                     !LAPACK
          DDIAG='DSYEVD'                                         !LAPACK
!                                                                !LAPACK
          IF(NMAX.GT.32766)THEN      !SO 2*NMAX*NMAX.GT.IBUFF4   !LAPACK
            WRITE(MW6,*)                                                &!LAPACK
     &  '*** ORACLE/PGI DSYEVD LIKELY/WILL FAIL EVEN WITH I*8'   !LAPACK
            WRITE(MW0,*)                                                &!LAPACK
     &  '*** ORACLE/PGI DSYEVD LIKELY/WILL FAIL EVEN WITH I*8'   !LAPACK
          ENDIF                                                  !LAPACK
! MIN                                                            !LAPACK
          IF(CEV.EQ.'V'.OR.CEV.EQ.'v')THEN                       !LAPACK
            LIWORK=MAX(LIWORK,3+5*NMAX)                          !LAPACK
            LWORK=MAX(LWORK,1+6*NMAX+2*NMAX*NMAX)                !LAPACK
          ELSE                                                   !LAPACK
            LIWORK=MAX(LIWORK,IONE)                              !LAPACK
            LWORK=MAX(LWORK,1+2*NMAX)                            !LAPACK
          ENDIF                                                  !LAPACK
! OPT                                                            !LAPACK
          LBK=ILAENV(IONE,'DSYTRD',CUL,NMAX,-IONE,-IONE,-IONE)   !LAPACK
          LBLK=MAX(LBLK,LBK)                                     !LAPACK
! ACCORDING TO SR.DSYEVD                                         !LAPACK
          LWORK=MAX(LWORK,LBLK+2*NMAX)                           !LAPACK
! ACCORDING TO SR.DSYTRD                                         !LAPACK
          LWORK=MAX(LWORK,LBLK*NMAX)                             !LAPACK
! BUT CEV.NE.'V' SEEMS TO NEED LBLK*2*NMAX...                    !LAPACK
          LWORK=MAX(LWORK,LBLK*2*NMAX)                           !LAPACK
!                                                                !LAPACK
          IF(LWORK.LE.0)THEN   !CRUDE CATCH                      !LAPACK
            WRITE(MW6,*)                                                &!LAPACK
     &      '*** MINIMUM WORKSPACE EXCEEDS I*4 REPRESENTATION'   !LAPACK
            WRITE(MW0,*)                                                &!LAPACK
     &      '*** MINIMUM WORKSPACE EXCEEDS I*4 REPRESENTATION'   !LAPACK
            GO TO 7400                                           !LAPACK
          ENDIF                                                  !LAPACK
!                                                                !LAPACK
          ALLOCATE(WORK(LWORK),IWORK(LIWORK)                            &!LAPACK
     &            ,STAT=IERR)                                    !LAPACK
!                                                                !LAPACK
        ELSEIF(LDABS.EQ.2)THEN                                   !LAPACK
!                                                                !LAPACK
! FOR DSYEVR                                                     !LAPACK
          DDIAG='DSYEVR'                                         !LAPACK
! MIN                                                            !LAPACK
          LIWORK=MAX(LIWORK,10*NMAX)                             !LAPACK
          LWORK=MAX(LWORK,26*NMAX)                               !LAPACK
! OPT                                                            !LAPACK
          LBK1=ILAENV(IONE,'DSYTRD',CUL,NMAX,-IONE,-IONE,-IONE)  !LAPACK
          LBK2=ILAENV(IONE,'DORMTR',CUL,NMAX,-IONE,-IONE,-IONE)  !LAPACK
          LBLK=MAX(LBLK,LBK1,LBK2)                               !LAPACK
! ACCORDING TO SR.DSYEVR LWORK=-1 QUERY                          !LAPACK
!         LWORK=MAX(LWORK,(LBLK+1)*NMAX)                         !LAPACK
! ACCORDING TO DSYEVR COMMENTS .GE.LBLK+6                        !LAPACK
          LWORK=MAX(LWORK,(LBLK+6)*NMAX)                         !LAPACK
!                                                                !LAPACK
          ALLOCATE(WORK(LWORK),IWORK(LIWORK)                            &!LAPACK
     &            ,DSV(NMAX,NEIGEN),ISUPP(2*NEIGEN)                     &!LAPACK
     &            ,STAT=IERR)                                    !LAPACK
!                                                                !LAPACK
        ELSEIF(LDABS.EQ.3)THEN                                   !LAPACK
!                                                                !LAPACK
! FOR DSYEVX                                                     !LAPACK
          DDIAG='DSYEVX'                                         !LAPACK
! MIN                                                            !LAPACK
          LIWORK=MAX(LIWORK,5*NMAX)                              !LAPACK
          LWORK=MAX(LWORK,8*NMAX)                                !LAPACK
! OPT                                                            !LAPACK
          LBK1=ILAENV(IONE,'DSYTRD',CUL,NMAX,-IONE,-IONE,-IONE)  !LAPACK
          LBK2=ILAENV(IONE,'DORMTR',CUL,NMAX,-IONE,-IONE,-IONE)  !LAPACK
          LBLK=MAX(LBLK,LBK1,LBK2)                               !LAPACK
          LWORK=MAX(LWORK,(LBLK+3)*NMAX)                         !LAPACK
!                                                                !LAPACK
          ALLOCATE(WORK(LWORK),IWORK(LIWORK)                            &!LAPACK
     &            ,DSV(NMAX,NEIGEN),ISUPP(NEIGEN)                       &!LAPACK
     &            ,STAT=IERR)                                    !LAPACK
!                                                                !LAPACK
        ENDIF                                                    !LAPACK
!                                                                !LAPACK
        IF(IERR.NE.0)THEN                                        !LAPACK
          WRITE(MW0,*)                                                  &!LAPACK
     &  ' HDIAG: ALLOCATION FAILS FOR WORK ARRAYS'               !LAPACK
          GO TO 7500                                             !LAPACK
        ENDIF                                                    !LAPACK
!                                                                !LAPACK
!--------------------------------------------------------------  !LAPACK
!                                                                !LAPACK
        IF(BALL.AND.LDIAG.LT.-1)THEN                             !LAPACK
!                                                                !LAPACK
! DGESVD - EXAMINE PATHALOGICAL CASES                            !LAPACK
!                                                                !LAPACK
          IF(CUL.EQ.'U'.OR.CUL.EQ.'u')THEN                       !LAPACK
            DO JS=1,NMAX                                         !LAPACK
              DO IS=1,JS                                         !LAPACK
                DSV(IS,JS)=DU(IS,JS)                             !LAPACK
                DSV(JS,IS)=DU(IS,JS)                             !LAPACK
              ENDDO                                              !LAPACK
            ENDDO                                                !LAPACK
          ENDIF                                                  !LAPACK
!                                                                !LAPACK
          IF(CUL.EQ.'L'.OR.CUL.EQ.'l')THEN                       !LAPACK
            DO JS=1,NMAX                                         !LAPACK
              DO IS=JS,NMAX                                      !LAPACK
                DSV(IS,JS)=DU(IS,JS)                             !LAPACK
                DSV(JS,IS)=DU(IS,JS)                             !LAPACK
              ENDDO                                              !LAPACK
            ENDDO                                                !LAPACK
          ENDIF                                                  !LAPACK
!                                                                !LAPACK
          CALL DGESVD('N','N',NMAX,NMAX,DSV,MAXNJ,DEV,DSV,NMAX          &!LAPACK
     &                ,DSV,NMAX,WORK,LWORK,INFOSVD)              !LAPACK
!                                                                !LAPACK
          IF(DEV(NMAX).EQ.0)THEN                                 !LAPACK
            WRITE(MW6,*)' SR.HDIAG: SINGULAR MATRIX FOUND...'    !LAPACK
            IF(INFOSVD.EQ.0)INFOSVD=1                            !LAPACK
          ENDIF                                                  !LAPACK
!                                                                !LAPACK
          IF(INFOSVD.NE.0)GO TO 7100                             !LAPACK
!                                                                !LAPACK
! END DGESVD                                                     !LAPACK
!                                                                !LAPACK
        ENDIF                                                    !LAPACK
!                                                                !LAPACK
!--------------------------------------------------------------  !LAPACK
!                                                                !LAPACK
        IF(LDABS.LE.1)THEN                                       !LAPACK
!                                                                !LAPACK
          IF(LDABS.EQ.0)THEN                                     !LAPACK
!                                                                !LAPACK
! DSYEV - SIMPLE (HOUSEHOLDER+QR)                                !LAPACK
!                                                                !LAPACK
            CALL DSYEV(CEV,CUL,NMAX,DU,MAXNJ,DEV                        &!LAPACK
     &                 ,WORK,LWORK,INFO)                         !LAPACK
!                                                                !LAPACK
          ELSEIF(LDABS.EQ.1)THEN                                 !LAPACK
!                                                                !LAPACK
! DSYEVD - DIVIDE AND CONQUER (MEMORY HOG)                       !LAPACK
!                                                                !LAPACK
            CALL DSYEVD(CEV,CUL,NMAX,DU,MAXNJ,DEV                       &!LAPACK
     &                  ,WORK,LWORK,IWORK,LIWORK,INFO)           !LAPACK
!                                                                !LAPACK
          ENDIF                                                  !LAPACK
!                                                                !LAPACK
!--------------------------------------------------------------  !LAPACK
!                                                                !LAPACK
          IF(INFO.NE.0)GO TO 7100                                !LAPACK
!                                                                !LAPACK
          IF(CEV.EQ.'V'.OR.CEV.EQ.'v')THEN                       !LAPACK
!                                                                !LAPACK
! USE DIAG TO RE-ORDER E-VALUES BASED ON DOMINANT E-VECTOR CPTS  !LAPACK
!                                                                !LAPACK
            CALL DIAG(CEV,-NMAX,NMAX,IZERO,DU,DEV,WRK,IWRK1             &!LAPACK
     &               ,IWRK2,MAXNJ)                               !LAPACK
!                                                                !LAPACK
          ELSE                                                   !LAPACK
!                                                                !LAPACK
            DO IS=1,NMAX                                         !LAPACK
              DO JS=1,NMAX                                       !LAPACK
                DU(JS,IS)=DZERO                                  !LAPACK
              ENDDO                                              !LAPACK
            ENDDO                                                !LAPACK
!                                                                !LAPACK
          ENDIF                                                  !LAPACK
!                                                                !LAPACK
          GO TO 7100                                             !LAPACK
!                                                                !LAPACK
! END DSYEVD                                                     !LAPACK
!                                                                !LAPACK
!--------------------------------------------------------------  !LAPACK
!                                                                !LAPACK
        ELSEIF(LDABS.EQ.2)THEN                                   !LAPACK
!                                                                !LAPACK
! DSYEVR (REQUIRES MACHINES TO HANDLE F.P. NaNs AND INFINITES)   !LAPACK
!         ACCORDING TO IEEE STANDARD DEFAULT: DO *NOT* TRAP!)    !LAPACK
!                                                                !LAPACK
          IEEEOK=ILAENV(ITEN,'DSYEVR','N',IONE,ITWO,ITHREE              &!LAPACK
     &                 ,IFOUR)                                   !LAPACK
          IF(IEEEOK.NE.1)WRITE(MW0,*)                                   &!LAPACK
     &   'WARNING: DSTEBZ/DSTEIN USED, BETTER TO CALL DSYEVD!'   !LAPACK
!                                                                !LAPACK
          CALL DSYEVR(CEV,CRNG,CUL,NMAX,DU,MAXNJ,VL,VU,IL,IU            &!LAPACK
     &                ,EPSR,MSUB,DEV,DSV,NMAX,ISUPP,WORK,LWORK          &!LAPACK
     &                ,IWORK,LIWORK,INFO)                        !LAPACK
!                                                                !LAPACK
! END DSYEVR                                                     !LAPACK
!                                                                !LAPACK
!--------------------------------------------------------------  !LAPACK
!                                                                !LAPACK
        ELSEIF(LDABS.EQ.3)THEN                                   !LAPACK
!                                                                !LAPACK
! DSYEVX (SLOWER THAN DSYEVR, BUT ROBUST)                        !LAPACK
!                                                                !LAPACK
          CALL DSYEVX(CEV,CRNG,CUL,NMAX,DU,MAXNJ,VL,VU,IL,IU            &!LAPACK
     &                ,EPSX,MSUB,DEV,DSV,NMAX,WORK,LWORK                &!LAPACK
     &                ,IWORK,ISUPP,INFO)                         !LAPACK
!                                                                !LAPACK
! END DSYEVX                                                     !LAPACK
!                                                                !LAPACK
        ENDIF                                                    !LAPACK
!                                                                !LAPACK
!--------------------------------------------------------------  !LAPACK
!                                                                !LAPACK
        IF(.NOT.BALL)THEN                                        !LAPACK
!                                                                !LAPACK
          IF(CRNG.NE.'V'.AND.MSUB.NE.NEIGEN)THEN                 !LAPACK
            WRITE(MW6,*)' SR.HDIAG: ERROR IN LAPACK DSYEVX/R'           &!LAPACK
     &               , NOT,' ALL E-VALUES FOUND:',MSUB,NEIGEN    !LAPACK
            WRITE(MW0,*)' SR.HDIAG: FAILURE IN LAPACK DSYEVX/R'  !LAPACK
            IF(INFO.EQ.0)INFO=1                                  !LAPACK
          ENDIF                                                  !LAPACK
!                                                                !LAPACK
          NEIGEN=MSUB                                            !LAPACK
          NE=NEIGEN                                              !LAPACK
!                                                                !LAPACK
          IF(MSUB.EQ.0)THEN                                      !LAPACK
            DO IS=1,NMAX                                         !LAPACK
              DEV(IS)=DZERO                                      !LAPACK
              DO JS=1,NMAX                                       !LAPACK
                DU(JS,IS)=DZERO                                  !LAPACK
              ENDDO                                              !LAPACK
            ENDDO                                                !LAPACK
            GO TO 7100                                           !LAPACK
          ENDIF                                                  !LAPACK
!                                                                !LAPACK
        ENDIF                                                    !LAPACK
!                                                                !LAPACK
        IF(INFO.NE.0)GO TO 7100                                  !LAPACK
!                                                                !LAPACK
!--------------------------------------------------------------  !LAPACK
!                                                                !LAPACK
        IF(CEV.EQ.'V'.OR.CEV.EQ.'v')THEN                         !LAPACK
!                                                                !LAPACK
! USE DIAG TO RE-ORDER E-VALUES BASED ON DOMINANT E-VECTOR CPTS  !LAPACK
!                                                                !LAPACK
          DO IS=1,NEIGEN                                         !LAPACK
            DO JS=1,NMAX                                         !LAPACK
              DU(JS,IS)=DSV(JS,IS)                               !LAPACK
            ENDDO                                                !LAPACK
          ENDDO                                                  !LAPACK
!                                                                !LAPACK
          CALL DIAG(CEV,-NMAX,NEIGEN,IZERO,DU,DEV,WRK,IWRK1             &!LAPACK
     &             ,IWRK2,MAXNJ)                                 !LAPACK
!                                                                !LAPACK
        ELSE                                                     !LAPACK
!                                                                !LAPACK
          DO IS=1,NEIGEN                                         !LAPACK
            DO JS=1,NMAX                                         !LAPACK
              DU(JS,IS)=DZERO                                    !LAPACK
            ENDDO                                                !LAPACK
          ENDDO                                                  !LAPACK
!                                                                !LAPACK
        ENDIF                                                    !LAPACK
!                                                                !LAPACK
!--------------------------------------------------------------  !LAPACK
!                                                                !LAPACK
 7100   IF(WORK(1).GT.LWORK)THEN                                 !LAPACK
          LWRK=NINT(WORK(1),SP)                                  !LAPACK
          WRITE(MW6,*)'N=',NMAX,' LBLOCK=',LBLK,' LWORK=',LWORK  !LAPACK
!         WRITE(MW0,*)'N=',NMAX,' LBLOCK=',LBLK,' LWORK=',LWORK  !LAPACK
!                                                                !LAPACK
          WRITE(MW6,*)'***OPTIMAL USE OF ',DDIAG                        &!LAPACK
     &               ,' REQUIRES LWORK=',LWRK                    !LAPACK
!         WRITE(MW0,*)'***OPTIMAL USE OF ',DDIAG                 !LAPACK
!    &               ,' REQUIRES LWORK=',LWRK                    !LAPACK
!                                                                !LAPACK
          WRITE(MW6,*)' LWORK_REQUIRED/N=',LWRK/NMAX             !LAPACK
          WRITE(MW0,*)' LWORK_REQUIRED/N=',LWRK/NMAX             !LAPACK
        ENDIF                                                    !LAPACK
!                                                                !LAPACK
        DEALLOCATE(WORK,STAT=IERR)                               !LAPACK
!                                                                !LAPACK
        IF(IERR.NE.0)THEN                                        !LAPACK
          WRITE(MW0,*)                                                  &!LAPACK
     &   ' HDIAG: DE-ALLOCATION FAILS FOR WORK'                  !LAPACK
          GO TO 7500                                             !LAPACK
        ENDIF                                                    !LAPACK
!                                                                !LAPACK
        IF(ALLOCATED(IWORK))THEN                                 !LAPACK
!                                                                !LAPACK
          DEALLOCATE(IWORK,STAT=IERR)                            !LAPACK
!                                                                !LAPACK
          IF(IERR.NE.0)THEN                                      !LAPACK
            WRITE(MW0,*)                                                &!LAPACK
     &     ' HDIAG: DE-ALLOCATION FAILS FOR IWORK'               !LAPACK
            GO TO 7500                                           !LAPACK
          ENDIF                                                  !LAPACK
!                                                                !LAPACK
        ENDIF                                                    !LAPACK
!                                                                !LAPACK
        IF(ALLOCATED(DSV))THEN                                   !LAPACK
!                                                                !LAPACK
          DEALLOCATE(DSV,STAT=IERR)                              !LAPACK
!                                                                !LAPACK
          IF(IERR.NE.0)THEN                                      !LAPACK
            WRITE(MW0,*)                                                &!LAPACK
     &     ' HDIAG: DE-ALLOCATION FAILS FOR DSV'                 !LAPACK
            GO TO 7500                                           !LAPACK
          ENDIF                                                  !LAPACK
!                                                                !LAPACK
        ENDIF                                                    !LAPACK
!                                                                !LAPACK
!--------------------------------------------------------------  !LAPACK
!                                                                !LAPACK
        IF(INFOSVD.NE.0)THEN                                     !LAPACK
!                                                                !LAPACK
          WRITE(MW6,*)                                                  &!LAPACK
     &     ' SR.HDIAG: ERROR IN LAPACK DGESVD: INFO=',INFOSVD    !LAPACK
          WRITE(MW0,*)                                                  &!LAPACK
     &     ' SR.HDIAG: ERROR IN LAPACK DGESVD: INFO=',INFOSVD    !LAPACK
!                                                                !LAPACK
          IF(INFOSVD.GT.0)THEN                                   !LAPACK
            write(mw6,*)'Lowest SVDs:'                           !LAPACK
            do is=nmax,nmax-10,-1                                !LAPACK
              write(mw6,*)is,dev(is)                             !LAPACK
            enddo                                                !LAPACK
          ENDIF                                                  !LAPACK
!                                                                !LAPACK
          GO TO 7400                                             !LAPACK
!                                                                !LAPACK
        ENDIF                                                    !LAPACK
!                                                                !LAPACK
        IF(INFO.NE.0)THEN                                        !LAPACK
!                                                                !LAPACK
          IF(LDABS.EQ.0)THEN                                     !LAPACK
            WRITE(MW6,*)                                                &!LAPACK
     &     ' SR.HDIAG: ERROR IN LAPACK ',DDIAG,': INFO=',INFO    !LAPACK
            WRITE(MW0,*)                                                &!LAPACK
     &     ' SR.HDIAG: ERROR IN LAPACK ',DDIAG,': INFO=',INFO    !LAPACK
          ENDIF                                                  !LAPACK
!                                                                !LAPACK
          IF(INFO.GT.0)THEN                                      !LAPACK
!                                                                !LAPACK
            WRITE(MW0,*)DDIAG,': FAILED TO CONVERGE'             !LAPACK
            WRITE(MW6,*)DDIAG,': FAILED TO CONVERGE'             !LAPACK
!                                                                !LAPACK
            IF(LDABS.LE.1)THEN                                   !LAPACK
!                                                                !LAPACK
              I1=INFO/(NMAX+1)                                   !LAPACK
              I2=MOD(INFO,NMAX+1)                                !LAPACK
              WRITE(MW6,70000)I1,I2,NMAX                         !LAPACK
!                                                                !LAPACK
            ELSEIF(LDABS.EQ.2)THEN                               !LAPACK
!                                                                !LAPACK
              WRITE(MW6,*)' NO DETAILS...'                       !LAPACK
!                                                                !LAPACK
            ELSEIF(LDABS.EQ.3)THEN                               !LAPACK
!                                                                !LAPACK
              WRITE(MW6,70010)(ISUPP(I),I=1,INFO)                !LAPACK
!                                                                !LAPACK
            ENDIF                                                !LAPACK
!                                                                !LAPACK
!            do is=1,nmax                                        !LAPACK
!              write(mw6,70020)is,(du(js,is),js=1,nmax)          !LAPACK
!            enddo                                               !LAPACK
!                                                                !LAPACK
            RETURN               !RELOAD AND TRY DIAG            !LAPACK
!                                                                !LAPACK
          ELSE                          !BAILOUT                 !LAPACK
!                                                                !LAPACK
            WRITE(MW6,*)                                                &!LAPACK
     &     ' SR.HDIAG: FAILURE IN LAPACK ROUTINE ',DDIAG         !LAPACK
            WRITE(MW0,*)                                                &!LAPACK
     &     ' SR.HDIAG: FAILURE IN LAPACK ROUTINE ',DDIAG         !LAPACK
!                                                                !LAPACK
            GO TO 7400                                           !LAPACK
!                                                                !LAPACK
          ENDIF                                                  !LAPACK
!                                                                !LAPACK
        ENDIF                                                    !LAPACK
!                                                                !LAPACK
!--------------------------------------------------------------  !LAPACK
!                                                                !LAPACK
        IF(ALLOCATED(ISUPP))THEN                                 !LAPACK
!                                                                !LAPACK
          DEALLOCATE(ISUPP,STAT=IERR)                            !LAPACK
!                                                                !LAPACK
          IF(IERR.NE.0)THEN                                      !LAPACK
            WRITE(MW0,*)                                                &!LAPACK
     &     ' HDIAG: DE-ALLOCATION FAILS FOR ISUPP'               !LAPACK
            GO TO 7500                                           !LAPACK
          ENDIF                                                  !LAPACK
!                                                                !LAPACK
        ENDIF                                                    !LAPACK
!                                                                !LAPACK
! END LAPACK                                                     !LAPACK
!                                                                !LAPACK
 7200   CONTINUE                                                 !LAPACK
!
!-----------------------------------------------------------------------
!
! HOUSEHOLDER+QL DIAGONALIZATION (NON-LAPACK)
!
        IF(INFO.GT.0)THEN
!
          INFO=0                                     !RESET
!
          IF(.NOT.BALL.AND.IWARN.EQ.0)THEN
            WRITE(MW0,*)'*** ATTENTION: SR.HDIAG COMPUTES ALL E-STATES,'&
     &                  ,                                               &
     &          ' REQUIRE LAPACK VERSION TO RESTRICT - NO MORE WARNINGS'
            WRITE(MW6,*)'*** ATTENTION: SR.HDIAG COMPUTES ALL E-STATES,'&
     &                  ,                                               &
     &          ' REQUIRE LAPACK VERSION TO RESTRICT - NO MORE WARNINGS'
            IWARN=1
          ENDIF
!
          IF(CUL.EQ.'U'.OR.CUL.EQ.'u')THEN           !AS DIAG USES LOWER
            DO IS=2,NMAX
              DO JS=1,IS-1
                DU(IS,JS)=DU(JS,IS)
              ENDDO
            ENDDO
          ENDIF
!
          CALL DIAG(CEV,NMAX,NMAX,IZERO,DU,DEV,WRK,IWRK1,IWRK2,MAXNJ)
!
        ENDIF
!
        DEALLOCATE(IWRK1,IWRK2,STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)' HDIAG: DE-ALLOCATION FAILS FOR IWRK1,IWRK2'
          GO TO 100
        ENDIF
!
! DIAG FAILURE, SO RETURN & RELOAD AND USE JACORD
!
        IF(NMAX.EQ.0)RETURN
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! SLOW BUT ROBUST JACOBI METHOD
!
      IF(IDIAG.GT.0)THEN
!
        IF(CEV.EQ.'V'.OR.CEV.EQ.'v')THEN
!
          ALLOCATE(DSV(MAXNJ,MAXNJ),STAT=IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)' HDIAG: ALLOCATION FAILS FOR DSV'
            GO TO 100
          ENDIF
!
        ENDIF
!
        IF(CUL.EQ.'L'.OR.CUL.EQ.'l')THEN           !AS JACORD USES UPPER
          DO IS=2,NMAX
            DO JS=1,IS-1
              DU(JS,IS)=DU(IS,JS)
            ENDDO
          ENDDO
        ENDIF
!
        NMAX=-NMAX                             !DO NOT RE-ORDER E-VALUES
!
        CALL JACORD(CEV,NMAX,DU,DSV,MAXNJ)
!
        IF(CEV.EQ.'V'.OR.CEV.EQ.'v')THEN
!
          DO IS=1,NMAX
            DEV(IS)=DU(IS,IS)
            DO JS=1,NMAX
              DU(JS,IS)=DSV(JS,IS)
            ENDDO
          ENDDO
!
          DEALLOCATE(DSV,STAT=IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)' HDIAG: DE-ALLOCATION FAILS FOR DSV'
            GO TO 100
          ENDIF
!
        ELSE
!
          DO IS=1,NMAX
            DEV(IS)=DU(IS,IS)
            DO JS=1,NMAX
              DU(JS,IS)=DZERO
            ENDDO
          ENDDO
!
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
 7400 NF=-1                                                      !LAPACK
      RETURN                                                     !LAPACK
!                                                                !LAPACK
 7500 NF=0                                                       !LAPACK
      RETURN                                                     !LAPACK
!
!-----------------------------------------------------------------------
!
  100 NF=0
      RETURN
!
!-----------------------------------------------------------------------
!
70000 FORMAT                                                            &!LAPACK
     &(/'DSYEV/D: ALGORITHM FAILED TO COMPUTE AN EIGENVALUE '           &!LAPACK
     &,'WHILE WORKING ON THE SUBMATRIX LYING IN ROWS AND '              &!LAPACK
     &,'COLUMNS',I5,' THROUGH',I5,' FOR MATRIX OF RANK',I5/)     !LAPACK
!                                                                !LAPACK
70010 FORMAT                                                            &!LAPACK
     &(/'DSYEVX: ALGORITHM FAILED TO CONVERGE THE EIGENVECTORS'         &!LAPACK
     &/(10I8))                                                   !LAPACK
!70020 format(i5,1p,10d12.4/(5x,10d12.4))                        !LAPACK
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE HDIAG
!
!                             *******************
!
      SUBROUTINE HPSRTI(N,A,IP)
!
!-----------------------------------------------------------------------
!
! SR .HPSRTI CARRIES OUT AN IMPLICIT HEAPSORT  BY *MAGNITUDE*
!
! INPUT:  VECTOR A, LENGTH N.
! OUTPUT: DOWN-ORDERED POINTER IN IP, A IS UNCHANGED.
!        (UP-ORDERED CAN BE OBTAINED BY CHANGING .LT. TO .GT. AS BELOW).
!
!  IT IS CALLED BY:
!    SR.CARATE
!    SR.DIAG
!    SR.DIAGFS
!    SR.DIAGON
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION A(*),IP(*)
!
!-----------------------------------------------------------------------
!
      DO I=1,N
        IP(I)=I
      ENDDO
!
      IF(N.LT.2)GO TO 300
!
      L=N/2+1
      IT=N
!
  100 IF(L.GT.1)THEN
        L=L-1
        IPT=IP(L)
      ELSE
        IPT=IP(IT)
        IP(IT)=IP(1)
        IT=IT-1
        IF(IT.EQ.1)THEN
          IP(1)=IPT
          GO TO 300
        ENDIF
      ENDIF
      I=L
      J=L+L
!
  200 IF(J.LE.IT)THEN
        IF(J.LT.IT)THEN
          IF(abs(A(IP(J+1))).lt.abs(A(IP(J))))J=J+1  !.lt. down, .gt. up
        ENDIF
        IF(abs(A(IP(J))).lt.abs(A(IPT)))THEN         !.lt. down, .gt. up
          IP(I)=IP(J)
          I=J
          J=J+J
        ELSE
          J=IT+1
        ENDIF
        GO TO 200
      ENDIF
      IP(I)=IPT
      GO TO 100
!
!-----------------------------------------------------------------------
!
  300 RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE HPSRTI
!
!                             *******************
!
      SUBROUTINE INTRPG(ARG,VAL,X,N,Y)
!
!-----------------------------------------------------------------------
!
!  Uses Lagrange interpolation formula to obtain value of VAL(X).
!  ARG(I),VAL(I) ,I=1,N contain the data values.
!
!  No subroutines called.
!
!  PHN's GRASP0 routine
!
!  IT IS CALLED BY:
!    SR.FZALF
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION ARG(N),VAL(N)
!
!-----------------------------------------------------------------------
!
      Y=DZERO
      DO L=1,N
        PL=DONE
        DO J=1,N
          IF(L.NE.J)PL=(X-ARG(J))*PL/(ARG(L)-ARG(J))
        ENDDO
        Y=Y+PL*VAL(L)
      ENDDO
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE INTRPG
!
!                             *******************
!
      SUBROUTINE JACORD(CEV,N,A,V,MXMAT)
!
!-----------------------------------------------------------------------
!
!  SR.JACORD CALCULATES EIGENVALUES AND (OPTIONALLY) EIGENVECTORS OF A
!  REAL-SYMMETRIC MATRIX A USING THE METHOD OF JACOBI.
!  ONLY THE UPPER TRIANGLE OF A IS REFERENCED.
!
!  INPUT:
!
!  CEV.EQ. 'V' OR 'N' SPECIFIES WHETHER E-VECTORS ARE REQUIRED, OR NOT
!
!  N=ORDER OF THE MATRIX A TO BE DIAGONALISED.
!
!  MXMAT, IS THE ROW DIMENSION OF A IN THE CALLING ROUTINE.
!
!  OUTPUT:
!
!  THE ORIGINAL A IS DESTROYED. THE EIGENVALUES WILL BE ORDERED SO
!  A(K,K).LT.A(I,I) FOR K.LT.I BUT IF N.LT.0 NO REORDERING TAKES PLACE,
!  IN THAT CASE N=-N AT THE BEGINNING.
!
!  V(I,K),I=1,N EIGENVECTORS TO A(K,K)=EIGENVALUE, IF CEV.EQ.'V'.
!
!  JACORD AND ROTSYM ARE BASED ON ALGOL PROCEDURES WRITTEN BY
!  RUTISHAUSER AT THE ETH (ZURICH, SWITZERLAND). FOR AN IMPROVED
!  VERSION SEE  RUTISHAUSER,NUMER.MATH.9(1966)1-10.
!
!*****IF JACORD FAILS THEN IT IS PROBABLY RETURNING TOO SOON, REDUCE
!*****PARAMETER TOL BELOW, UNLESS NMAX SWEEPS OCCURRED - LOOK FOR
!*****WARNING WRITTEN BY FORMAT 10010 - THIS IS EXTREMELY UNLIKELY DUE
!*****TO THE QUADRATIC CONVERGENCE.
!
!  IT IS CALLED BY:
!    SR.HDIAG
!    SR.VCE
!
!  IT CALLS:
!    SR.ROTSYM
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (EPS=D1M11)
      PARAMETER (TOL=EPS*EPS)              ! ***  TOL  ***
      PARAMETER (STOL=D1M2*EPS)
      PARAMETER (XBIG=3.16E+19_WP)
      PARAMETER (NMAX=50)
!
      CHARACTER(LEN=1) CEV
!
      DIMENSION A(MXMAT,*),V(MXMAT,*)
!
!-----------------------------------------------------------------------
!
      BNOGT=N.LT.0
      IF(BNOGT)N=-N
!
      BEIVEC=CEV.EQ.'V'.OR.CEV.EQ.'v'
!
      IF(BEIVEC)THEN
        DO K=1,N
          DO L=1,N
            V(L,K)=DZERO
          ENDDO
          V(K,K)=DONE
        ENDDO
      ENDIF
!
      I=1
      IF(N.EQ.1)GO TO 100                   !EXIT FAST
!
!
!  NMAX IS THE NUMBER OF SWEEPS
!  IT IS VIRTUALLY INDEPENDENT OF THE ORDER N.
!
      DO I=1,NMAX
!
        SS=DZERO
!        DO K=1,N-1
!          DO L=K+1,N
        DO L=2,N
          DO K=1,L-1
            SS=A(K,L)*A(K,L)+SS
          ENDDO
        ENDDO
!
        IF(SS.LT.TOL)GO TO 100                   !EXIT
!
        TRESH=DZERO
        IF(I.LT.4)TRESH=DONE*SQRT(SS)/(DFIVE*N**2)
!
!        DO K=1,N-1
        DO L=2,N
!
!          DO L=K+1,N
          DO K=1,L-1
!
            AKK=A(K,K)
            ALL=A(L,L)
            AKL=A(K,L)
            T=ABS(AKL)/STOL
!
            IF(I.GT.4.AND.ABS(AKK).GE.T.AND.ABS(ALL).GE.T)A(K,L)=DZERO
!
            IF(ABS(A(K,L)).GT.TRESH)THEN
!
              THETA=(ALL-AKK)/(DTWO*AKL)
!
              IF(ABS(THETA).GT.XBIG)THEN
                T=DONE/(DTWO*THETA)
              ELSE
                T=ABS(THETA)+SQRT(THETA*THETA+DONE)
                IF(THETA.LE.DZERO)T=-T
                T=DONE/T
              ENDIF
!
              C=DONE/SQRT(T*T+DONE)
              S=T*C
!
              CALL ROTSYM(N,N,BEIVEC,C,S,K,L,A,V,MXMAT)
!
              A(K,L)=DZERO
!
            ENDIF
!
          ENDDO
!
        ENDDO
!
      ENDDO
!
      WRITE(MW6,10010)NMAX,SS
!
  100 CONTINUE                                    !CONVERGED
!
!      WRITE(MW6,101)N,I-1
!
      IF(BNOGT)GO TO 200
!
! RE-ORDER INTO ASCENDING E-VALUES (& VECTORS)
!
      DO I=1,N
        K=I
        P=A(I,I)
        DO J=I+1,N
          IF(A(J,J).LT.P)THEN
            K=J
            P=A(J,J)
          ENDIF
        ENDDO
        IF(K.NE.I)THEN
          A(K,K)=A(I,I)
          A(I,I)=P
          DO J=1,N
            P=V(J,I)
            V(J,I)=V(J,K)
            V(J,K)=P
          ENDDO
        ENDIF
      ENDDO
!
!-----------------------------------------------------------------------
!
  200 RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(' POSSIBLE INACCURACY IN JACORD, AFTER',I3,' SWEEPS',      &
     &       ' SUM OF OFF-DIAGONAL ELEMENTS IS:',1PD10.2)
!  101 FORMAT(' MATRIX ORDER N=',I5,' REQUIRED',I3,' SWEEPS')
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE JACORD
!
!                             *******************
!
      SUBROUTINE LAGINT(DE0,DDY,NPOUT1,NPOUT2)
!
!-----------------------------------------------------------------------
!
! SR.LAGINT DETERMINES INTERPOLATION COEFFICIENTS DDY(N=NP1,NP2) FOR
!           BOUND-CONTINUUM INTEGRALS AT ENERGY DE0.
!
!  USES NLAG-POINT LAGRANGE INTERPOLATION FORMULA
!  NLAG MUST BE AN EVEN NUMBER .GE. 4 . READ IN SRADCON.
!  DEFAULT:   NLAG=6.
!  IF MENG.EQ.1 THEN NO INTERPOLATION (& NLAG NOT IUSED)
!
!  IT IS CALLED BY:
!    SR.CARATE
!    SR.DIAGFS
!    SR.DIAGON
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE COMMON_NRBINT, ONLY: DRLI,DYY,IYY,NRLI,MENG,NREL,NLAG,NLAGP   &
     &                        ,BLAG,BBC2
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION DDY(MENG)
!
      DATA INIT/0/
      SAVE NLAG2,NP1,NP2,NPH,BBC1
!
!-----------------------------------------------------------------------
!
! INITIALIZE
!
      IF(INIT.EQ.0)THEN
        NLAG2=NLAG-2
        NP1=1
        NP2=MAX(IONE,NLAG)
        NPH=NP2/2
        BBC1=MENG.LE.NP2
        IF(BBC1)NP2=MENG
        DDY(1)=DONE                               !FOR .NOT.BLAG
        INIT=1
      ENDIF
!
      DE=ABS(DE0)
!
      IF(.NOT.BBC1)THEN
        DO L=1,MENG
          IF(DYY(L).GE.DE)THEN
            LP=L
            GO TO 50
          ENDIF
        ENDDO
        LP=MENG
!
   50   IF(.NOT.BBC2)THEN
          NP2=LP+NPH-1
          NP1=LP-NPH
          IF(NP1.LE.0)THEN
            NP2=NP2-NP1+1
            NP1=1
          ELSEIF(NP2.GT.MENG)THEN
            NP1=NP1-NP2+MENG
            NP2=MENG
          ENDIF
        ELSE
          NP2=LP
          NP1=LP-1
          DO M=1,NLAG2
            IF(NP2.EQ.MENG)THEN
              NP1=NP2-NLAG+1
              GO TO 60
            ELSEIF(NP1.LE.1)THEN
              NP2=NLAG
              NP1=1
              GO TO 60
            ELSE
              DD=DYY(NP2+1)-DE
              DSJ=DE-DYY(NP1-1)
              IF(DD.LE.DSJ)NP2=NP2+1
              IF(DD.GT.DSJ)NP1=NP1-1
            ENDIF
          ENDDO
   60     CONTINUE
        ENDIF
      ENDIF
!
      NPOUT1=NP1
      NPOUT2=NP2
!
      IF(DE0.LT.0)GO TO 100
!
! SET INTERPOLATION COEFFICIENTS
!
      DO L=NP1,NP2
        DD=DONE
        DO M=NP1,NP2
          IF(L.NE.M)THEN
            DD=DD*(DE-DYY(M))
            DD=DD/(DYY(L)-DYY(M))
          ENDIF
        ENDDO
        DDY(L)=DD
      ENDDO
!
!-----------------------------------------------------------------------
!
  100 RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE LAGINT
!
!                             *******************
!
      SUBROUTINE LDFGX(M,L,DP,DQ,MAXRS,BREL,BREL2)
!
!-----------------------------------------------------------------------
!
!  SR.LDFGX LOADS THE ORBITAL DP INTO DPNL(I,L) AND, IF BREL2,
!  DQ INTO DQNL(I,L) FOR ACCESS BY THE NFS- INTEGRAL ROUTINES.
!  IF BREL BUT .NOT.BREL2 THEN CREATES DQNL FROM DTOT=2(V-Z/X), WILL
!  NEED MODIFYING FOR DIFFERENT DPOT CONTENTS. FINALLY, SETS DEY.
!  COULD BE ADAPTED FOR OTHER USES.
!
!  IT IS CALLED BY:
!    SR.SLATRX
!
!  IT CALLS:
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_DBD2,   ONLY: QL,QN,DEY
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
!
      USE COMMON_NRBPOT, ONLY: DPOT,TOL,MEND
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBDW5, ONLY: DYY,MENG,NLAG
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION DP(*),DQ(*)
!
!-----------------------------------------------------------------------
!
      IF(BREL)THEN               !DUY SHOULD BE ZERO, BUT JUST INCASE...
        IN=ICOL(L,L,IZERO)
        DEY(L)=DYY(M)/DTWO+DUY(IN)
        IF(BREL2)THEN
          DO I=1,MAXRS
            DPNL(I,L)=DP(I)
            DQNL(I,L)=DQ(I)
          ENDDO
        ELSE
          DO I=1,MAXRS
            DPNL(I,L)=DP(I)
            DQNL(I,L)=DP(I)*(DPOT(I)+DYY(M))
          ENDDO
        ENDIF
      ELSE
        DO I=1,MAXRS
          DPNL(I,L)=DP(I)
        ENDDO
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE LDFGX
!
!                             *******************
!
      SUBROUTINE MESH(NZION,MION,TOLR,DHNS0,DX,IFLAGR)
!
!-----------------------------------------------------------------------
!
!  SR.MESH SETS-UP THE RADIAL MESH - IT IS A DOUBLING MESH.
!
! IFLAGR I/O CONTROLS OPERATION:
!      .GT. 0 FULLY DETERMINES THE MESH VIA /CMESH/ AND DX.
!      .EQ. 0 DOES NOT TOUCH DX, DETERMINES MAXRS FOR ITS ALLOCATION.
!      .LT. 0 DOES NOT CHANGE THE MESH, JUST RESETS IFLAGR TO LAST MAXRS
!      .GE. 0 IS UNCHANGED ON RETURN.
!
!  INPUT:
!      NZION - NUCLEAR CHARGE
!      MION  - TOTAL NUMBER OF ELECTRONS
!      TOLR  - THE VALUE A RADIAL FUNCTION MUST DECAY TO BEFORE TAKEN
!              AS ZERO; THE MOST DIFFUSE ORBITAL (DETERMINED HERE BY
!              THE COULOMB SR.WHITEX) SETS THE MESH EXTENT
!  OUTPUT:
!      DHNS0 - THE INITIAL STEP
!      DX(I),I=1,MAXRS - THE MESH
!      DHNS(I),MNH(I),I=1,MJH - THE STEP LENGTH & NO OF POINTS PER
!                               INTERVAL I IS OUTPUT IN /CMESH/
!
!  IT IS CALLED BY:
!    SR.MINIM
!    SR.RADIAL
!
!  IT CALLS:
!    SR.DIMUSE
!    FN.WHITEX
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CADJ,   ONLY: DAJNEW,DF0,IEQUAL,ICOUNT
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS,MNH0,MJH0,IXTRA0
      USE COMMON_CMESH,  ONLY: MHF,MRAD,MSTEP,IXTRA,xmax0=>xmax,MXTRA
      USE COMMON_CMESH,  ONLY: TINORB,RZERO,MXBOX
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,VSC,XC1,XC2,NPITER
      USE COMMON_NRBDR,  ONLY: IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR
      USE COMMON_NRBDR,  ONLY: LNEW,LCON,LSUM,LMAX,lcmin,BLOOP
      USE COMMON_NRBSTO, ONLY: ALF,TEL,MSHELL,MCFSTO,MC,MCFMX,MEXPOT    &
     &                        ,NOCC,NLSTOE,BFIX,BSTO,MXSHLL
      USE COMMON_NRBVAL, ONLY: FACT,IVAL,NNEW,NNOLD,BJUMP,BJUMP2,BRAD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (DCON0=1.625_WP)                    !FOR INITIAL STEP
      PARAMETER (DCON6=0.2387_WP)                   !=DTHREE/(DFOUR*XPI)
!
      PARAMETER (MAXA=99999999)                    !LIMIT OUT-OF-CONTROL
!
      DIMENSION DX(*)
!
!      DATA H0/-1/,NPOLD/0/                 !OLD COULD RE-USE OLD-L MESH
!
      SAVE H0,NPOLD                          !NOW L-LOOP RE-ALLOCATES DX
      save xmax,V0,mred,MAXRS0
!
!-----------------------------------------------------------------------
!
      IF(IFLAGR.LT.0)THEN                 !JUST RETURN LAST VALUE SET-UP
        IFLAGR=MAXRS0
        RETURN
      ENDIF
!
      BDR=IDR.NE.0
      if(bdr)then
        mred=1
      else
        mred=0
      endif
!
! Estimate how far out the radial mesh should extend.
! This is for efficiency as the maximum allowed by dimensions can be
! very large, unnecessarily so in many cases.
!
      IF(IFLAGR.eq.0.and.xmax0.lt.dzero)THEN            !.and..NOT.BJUMP
        nza=max(ione,nzion-mion+1)                   !mion since Rydberg
        bnorm=.false.                          !silence stupid compilers
!
        if(bdr)then
          lm=lnew*2
        else
          lm=0
        endif
        nm=1
        np=0
        do m=1,mxorb
          if(dey(m).ne.dzero)then
            if(bdr)then
              if(ival(m).ne.0)lm=min(lm,INT(ql(m),SP))
            else
              if(abs(qn(m)).lt.q80)then
                if(mort.eq.-4.and.dajnew(m).lt.dzero)then           !LPS
!                 lp=min(lp,ql(m))
                  np=max(np,mod(INT(qn(m),SP),i70))
                else
!                  lm=min(lm,ql(m))
                  nm=max(nm,mod(INT(qn(m),SP),i70))
                endif
              else
                mred=1
              endif
            endif
          endif
        enddo
        lm=lm/2
!
        xoutp=dzero
        if(bdr)then
          nout=nmax
          if(jnd.gt.0)nout=ndr(jnd)
          if(nsw.gt.0)nout=min(nout,nsw)
        else
          nout=nm
          if(np.gt.0)then
            xoutp=np
            xoutp=4*xoutp/nza
          endif
        endif
        ll=min(lm,nout-1)
        tl=ll
        tll=ll*(ll+1)
        xout=nout
        xout=xout*xout
        xout=2*xout/nza
!        write(mw0,*)nout,lm,nza,xout,xoutp
        if(xout.gt.xoutp)then
          xmax=xout
          dza=nza
          e=-2*dza/xout
        else
          xmax=xoutp
          dza=nza*np/2
          e=dza/np
          e=-e*e
        endif
!
        bshort=.false.
        xmax=d1pt4*xmax
   50   xmax=d1pt1*xmax
!        write(mw0,*)xmax,tl,tll,e,dza,bnorm
        diffw=dzero
        pmax=whitex(xmax,tl,tll,e,dza,bnorm,diffw)
! this should not happen
        if(diffw.lt.dzero)then        !overflow, xmax too small
          write(mw6,*)'sr.mesh: radial/whitex/norm - xmax too small'
          write(mw0,*)'sr.mesh: radial/whitex/norm - xmax too small'
          pmax=d1p10
          bshort=.true.
        endif
! this might happen for very large l, and i do mean very large...
        if(diffw.gt.dzero)then        !underflow, xmax too large
!          write(mw6,*)'sr.mesh: radial/whitex/norm - xmax too large'
!          write(mw0,*)'sr.mesh: radial/whitex/norm - xmax too large'
          if(.not.bshort)then   !wouldn't want to bounce between the two
            xmax=d0pt8*xmax
            go to 50
          endif
          pmax=dzero
        endif
! this should not happen, as n is integer here
        if(.not.bnorm)then
          pmax=dzero
          xmax=d1p10
          stop 'sr.mesh: radial/whitex/norm gamma failure'
        endif
!        write(mw0,*)xout,xmax,pmax,nout
        if(abs(pmax).gt.tolr/10)go to 50
        xmax=max(xmax,rzero)
!
!        if(mden.lt.-1)xmax=1.2*xmax        !self-consistent may expand
!         xmax=max(xmax,-xmax0)
!
        if(mden.gt.0)then
          if(gamq.gt.d1m2)then
            if(mod(mden,iten).eq.1)then
              t=debye
            else
              t=(dcon6/deni)**d1thrd !r0
            endif
          else
            t=dzero                         !use zero density...
            if(dene.gt.dzero)then
              write(mw6,*)                                              &
     &       'Plasma density too low, using zero-density radial mesh...'
              write(mw0,*)                                              &
     &       'Plasma density too low, using zero-density radial mesh...'
            endif
          endif
!          write(mw0,*)mden,gamq,nza,t
!          if(t.lt.100)then                 !don't go mad - use gamq now
          xmax=max(xmax,t)
          xmax0=xmax
!          endif
        else
          xmax0=-xmax
        endif
      elseif(xmax0.gt.dzero)then
        xmax=xmax0
      ENDIF
!
! SET INITIAL STEP:
!  EXPERIENCE HAS SHOWN THAT THIS LENGTH FOR THE FIRST
!  INTERVAL GIVES IN MOST CASES A REASONABLE INTERVAL SET-UP.
!
!  MSTEP IS SET IN SR.MINIM0 AND DEPENDS ON SCATTERING PROBLEM.
!  IXTRA ADDS EXTRA INTERVALS CLOSE TO THE ORIGIN WHEN KAPPA-AVERAGED
!  RELATIVISTIC ORBITAL ARE IN USE.
!
      IF(DHNS(1).LE.DZERO)THEN                               !FIRST PASS
!
        IXTRA=MIN(IXTRA,IXTRA0)         !LIMIT USER IXTRA, SET IN MINIM0
        MJH=MJH0+IXTRA                         !MAX POSS NO OF INTERVALS
!
        H0=-DONE
        NPOLD=0
!
        IF(DHNS(1).EQ.DZERO)THEN
          NZA=NZION-(MION-MRED)                    !IGNORES ANY RYD/CONT
          NZA=NZA+1
!
          DHNS(1)=(DCON0/NZION)**D1THRD/((2**(MSTEP+IXTRA))*NZA**D2THRD)
!
!        write(mw0,*)mstep,ixtra,mion,nza,dhns(1)
!
        ELSE                                        !ALREADY SET BY USER
          DHNS(1)=-DHNS(1)
        ENDIF
!
        V0=DTWO
        IF(ABS(MAUTO).GE.100)THEN
          V0=MAUTO
          V0=V0/D1P2
          IF(V0.LT.DZERO)V0=-V0
        ENDIF
!
      ENDIF
!
      DHNS0=DHNS(1)
      h=dhns0
!
! MAXRS=NUMBER OF POINTS FOR WHICH THE RADIAL FUNCTIONS WILL BE
!  CALCULATED; MJH INTERVALS WITH MNH(I),I=1,MJH STEPS
!***NEED TO RE-DO FOR EACH N (DR-LOOP) BECAUSE RADCON REDUCES MNH(MJH)
!  (AND SO, HISTORICALLY, MAXRS WAS NOT EXPLICITLY SAVED)
!
      MAXRS=0
      x=dzero
!      xmax=1.d10                                  !test
!
      DO IX=1,IXTRA
        MAXRS=MAXRS+MXTRA
        MNH(IX)=MXTRA
        x=x+mnh(ix)*h
        h=v0*h
      ENDDO
      MJH=IXTRA
!
      DO J=1,MJH0
        JX=J+IXTRA
        L=MAXRS
        M=MAXRS+MNH0(J)
        IF(J.EQ.MJH0.OR.M+9.GT.MAXA)M=MAXA
        MAXRS=MIN(M,MAXA)
        MNH(JX)=M-L
        IF(MNH(JX).GT.0)MJH=JX
        x=x+mnh(jx)*h
        if(x.gt.xmax)then
          if(j.lt.mjh0.and.xmax0.lt.dzero)go to 100      !simple bailout
          t=(x-xmax)/h
          nxtra=int(t,sp)
          nxtra=mnh(jx)-nxtra
          nxtra=max(nxtra,ININE)
          if(.not.bsto)nxtra=max(nxtra,2*mnh(jx-1))    !to initialize dx
          maxrs=l+nxtra
          if(maxrs.gt.maxa)then
            nxtra=nxtra-maxrs+maxa
            maxrs=maxa
          endif
          mnh(jx)=nxtra
!
!          write(mw0,*)m-l,nxtra,m,maxrs
!          istep=0
!          do i=1,mjh
!            istep=istep+mnh(i)
!          enddo
!          if(maxrs.ne.istep)write(mw0,*)maxrs,istep   !shouldn't be so!
!
        endif
        h=v0*h
      ENDDO
!
  100 continue
!
      IF(MJH.EQ.1)THEN            !TOO MANY STEP DOUBLES, OUT OF CONTROL
        WRITE(MW6,*)'***SR.MESH: INVALID MESH - OPTIMIZATION UNBOUNDED?'
        WRITE(MW0,*)'***SR.MESH: INVALID MESH - OPTIMIZATION UNBOUNDED?'
        GO TO 400
      ENDIF
!
      IF(IFLAGR.EQ.0)GO TO 300                        !FOR ALLOCATE ONLY
!
! NOW SET UP THE X ARRAY:
!  DX=STEP LENGTH IN THE FIRST INTERVAL (I=1)
!  THE STEP LENGTH DOUBLES FROM ONE INTERVAL TO THE NEXT.
!  IF !MAUTO! .LT.100, OTHERWISE STEP INCREASES BY FACTOR MAUTO/100
!
      H=DHNS0
      IF(NINT(H/H0,SP).NE.1.OR.MAXRS.gt.NPOLD)THEN
!
        ISTEP=0
        XB=DZERO
        DO J=1,MJH
          DHNS(J)=H
          II=MNH(J)
          DO I=1,II
            ISTEP=ISTEP+1
            XB=XB+H
            DX(ISTEP)=XB
          ENDDO
!        write(mw6,*)istep,h,xb
          H=V0*H
        ENDDO
        H0=DHNS0
        xmax0=sign(dx(istep),xmax0)
!
! THE FOLLOWING CHECK IS REDUNDANT HERE...
        IF(MAXRS.LE.0)MAXRS=ISTEP
        IF(ISTEP.NE.MAXRS)THEN
          WRITE(MW6,10010)
          WRITE(MW0,10010)
          GO TO 400
        ENDIF
!
        NPOLD=MAXRS                                !THIS IS NEEDED STILL
      ENDIF
!
! CHECK RZERO
!
      IF(RZERO.GT.DZERO.AND.MXBOX.EQ.0)THEN
        DO I=1,MAXRS
          IF(DX(I).GT.RZERO)THEN
            MXBOX=I-MOD(I+1,ITWO)                     !KEEP ODD
            GO TO 150
          ENDIF
        ENDDO
        MXBOX=MAXRS
!
  150   MAXRS=0
        I0=MJH
        DO I=1,I0
          MAXRS=MAXRS+MNH(I)
          MJH=I
          IF(MAXRS.EQ.MXBOX)GO TO 200
          IF(MAXRS.GT.MXBOX)THEN
            MAXRS=MAXRS-MNH(I)
            MNH(I)=MAX(MXBOX-MAXRS,ININE)
            MAXRS=MAXRS+MNH(I)
            GO TO 200
          ENDIF
        ENDDO
  200   MXBOX=MAXRS
      ENDIF
!
  300 MAXRS0=MAXRS
!
      CALL DIMUSE('MAXB1',MAXRS)
      IAXB1=MAXRS
      CALL DIMUSE('MAXB2',MAXRS)
      IAXB2=MAXRS
!
!-----------------------------------------------------------------------
!
      RETURN
!
  400 NF=-1
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT('SR.MESH: MAXRS INCOMPATIBLE WITH MNH,MJH')
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE MESH
!
!                             *******************
!
      SUBROUTINE MINIM
!
!-----------------------------------------------------------------------
!
!  SR.MINIM CONTROLS THE SECOND, ANALYTIC BRANCH VIZ. HAMILTONIAN SET-UP
!  DETERMINATION OF ENERGIES, RADIATIVE & AUTOIONIZATION RATES PLUS
!  PHOTOIONIZATION CROSS SECTIONS AND FINITE ENERGY BORN EXCITATION.
!
!  IT IS CALLED BY:
!    SR.TARGET
!
!  IT CALLS:
!    SR.CARATE
!    SR.CASC
!    SR.CAVE0
!    SR.CGNA
!    SR.CGNR (INTERFACE ONLY)
!    SR.DIAGFS
!    SR.DIAGON
!    SR.MESH
!    SR.MINIM0
!    SR.MINIM_ALLOC
!    SR.MINIM_DEALLOC
!    SR.NRB_TIME
!    SR.RADCN0
!    SR.RADIAL
!    SR.SOCC
!    SR.VA04A
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam                            !par
!
      USE COMMON_ALGEB,  ONLY: BFANO
      USE COMMON_ALGEB,  ONLY: BFOT
      USE COMMON_ALGEB,  ONLY: KUTDSK
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CACC,   ONLY: ACC
      USE COMMON_CADJ,   ONLY: DAJNEW,DF0,IEQUAL,ICOUNT,ICOUNT0
      USE COMMON_CADJ,   ONLY: DALAN,BALAN
      USE COMMON_CADJ,   ONLY: DEXTRE,DACCUR
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_CMESH,  ONLY: MHF,MRAD,MSTEP,IXTRA,xmax
      USE COMMON_CMESH,  ONLY: TINORB,RZERO,MXBOX
      USE COMMON_COEFF,  ONLY: DRKP,QRLP,IRLP,NRKP,NADP
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DMQSS3, ONLY: DSS,MSS,QSS,NADR                         &
     &                        ,NL000=>NL,NL=>NL000
      USE COMMON_DXRL,   ONLY: DRK,QRL,IRL,NRK,NAD
      USE COMMON_DXRL,   ONLY: IRK,IRK0,IOS,IOS0
      USE COMMON_INTS,   ONLY: DRL,DOSC,IGAUGE
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_GENINF, ONLY: SCALER
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR,NTJ,NFJ
      USE COMMON_MINIM,  ONLY: MPNCH,KUTCAS,BPRINT
      USE COMMON_MINIM,  ONLY: ECOR1,ECOR2,ECORR,ECORRJ,ESKPL,ESKPH     &
     &                        ,BECOR
      USE COMMON_MINIM,  ONLY: CMXLSA,CMXLSR,CMXICA,CMXICR,STOLB,XMIX   &
     &                        ,bnobv
      USE COMMON_MINIM,  ONLY: TOLTCC,KTCC,MTCC,NTCC,NNRGLS=>NENERG
      USE COMMON_MINIM,  ONLY: EIONPOT,EIMXLS,EIMXIC                    &
     &                        ,WLG1,WLG2,IWGHT,IWGHT0,IOPTIM            &
     &                        ,JUPMX,JUPMN,JLOWMX,JLOWMN                &
     &                        ,LUPMX,LUPMN,LLOWMX,LLOWMN                &
     &                        ,NMETAR,NMETARJ,NMETAP,NMETAPJ,NRSLMX
      USE COMMON_MISC,   ONLY: IDIAG
      USE COMMON_MISC,   ONLY: NF0,BNAME
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
      USE COMMON_QTG,    ONLY: NTT,NFI,NFK,NFQ,NTG
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG,MXPIN
      USE COMMON_REL,    ONLY: DMASS,DCD,D2LL
      USE COMMON_RELINT, ONLY: DRLP1,DNL
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
      USE COMMON_TFU,    ONLY: TFU
      USE COMMON_TRANLS, ONLY: NADRU,NAI,IEORD
      USE COMMON_WEIGHT, ONLY: WGHT,INDEXW
!
      use common_misc,   only: ione1,ione0
      use common_misc,   only: iw,iwp,btime,btimex
      use common_misc,   only: badas
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD
      USE COMMON_NRBAL0, ONLY: IRET0,LORIG,LMIN,MPRNT0,MOD0,MSTRT0,BPASS
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL1, ONLY: ISCALR
      USE COMMON_NRBAL2, ONLY: MDEL,MXORBR,MPOL00,MPOL0,MPOLE,MPOLX,CODE
      USE COMMON_NRBAL2, ONLY: MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBCAS, ONLY: BCASC,AP,MADD
      USE COMMON_NRBCAV, ONLY: ECAVX,ECAV,AJUSTX,ICAV0=>ICAV
      USE COMMON_NRBDEL, ONLY: ISHFTLS,ISHFTIC,NOBS,NOBSJ,MDELE,MULTS   &
     &                        ,DELELS,DELEIC,DELECF,EFLG0,EFLGJ0        &
     &                        ,TOLB,TOLE,BDELE
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,XBEE,VSC,XC1,XC2,NPITER
      USE COMMON_NRBDEN, ONLY: DENSI,DENS,TKAYS,NDEN
      USE COMMON_NRBDQE, ONLY: DQNL,MXQIN,BHFF
      USE COMMON_NRBDR,  ONLY: IDR
      USE COMMON_NRBDR,  ONLY: NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR,NBOUND
      USE COMMON_NRBDR,  ONLY: LNEW,LCON,LSUM,LMAX,lcmin,BLOOP          &
     &                        ,MAXNV
      USE COMMON_NRBDW,  ONLY: IDW,btop
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBEKP, ONLY: NED
      USE COMMON_NRBFSI, ONLY: BNRBFSI,DNLI,NLI
      USE COMMON_NRBGCF, ONLY: KGSL,KGCF,NKSL
      USE COMMON_NRBGRJ, ONLY: NSLJ,NGSLJ
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBINT, ONLY: DRLI,DYY,IYY,NRLI,MENG,NREL,NLAG,NLAGP   &
     &                        ,BLAG,BBC2
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,NASTJ
      USE COMMON_NRBLIM, ONLY: ECNTRB,ITANAL,BANAL
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,NAST
      USE COMMON_NRBMKP, ONLY: NMD1,NMD2
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBNF2, ONLY: DETA,DXSI,DZL,DXTWO
      USE COMMON_NRBNFI, ONLY: DZLI,DXTWOI,DETAI,FRI,GRI
      USE COMMON_NRBOLP, ONLY: OVLPGR,OVLPCF,IPAIR
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
      USE COMMON_NRBORN, ONLY: BL,OBO,TM2
      USE COMMON_NRBPOT, ONLY: DPOT,TOL,MEND
      USE COMMON_NRBPOT, ONLY: ZS0,ZS,JZNM
      USE COMMON_NRBPOT, ONLY: POT,JPOT1
      USE COMMON_NRBPOT, ONLY: POTHAM,MPSEUD
      USE COMMON_NRBPOT, ONLY: DERV,DERV1,DERV2
      USE COMMON_NRBPOT, ONLY: ZESP,IZESP,NWRM
      USE COMMON_NRBPOT, ONLY: ALFD,RCUT,ALAV,RCAV,IPOLFN
      USE COMMON_NRBQED, ONLY: VPINT,SLFINT,QED
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBREL, ONLY: RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0
      USE COMMON_NRBREL, ONLY: DNUK0,DNUK1,DNUK2,DNUK,IXNUK
      USE COMMON_NRBRN1, ONLY: SBL,DBL                                  &
     &                        ,MB3,MB4,INDX,INDL,INDK
      USE COMMON_NRBRN2, ONLY: BINDB,MENGB
      USE COMMON_NRBSHF, ONLY: DSHIFT,MSHIFT,KSHIFT,MKMAX,MXEP
      USE COMMON_NRBSTO, ONLY: ALF,TEL,MSHELL,MCFSTO,MC,MCFMX,MEXPOT    &
     &                        ,NOCC,NLSTOE,BFIX,BSTO,MXSHLL
      USE COMMON_NRBTS1, ONLY: DFOT,DFOTm,DFOSS,NFOSS,IGAG,IXD24
      USE COMMON_NRBVAL, ONLY: FACT,IVAL,NNEW,NNOLD,BJUMP,BJUMP2,BRAD
      use common_nrbtmp, only: rnorm
!par!                                                               !par
!par      use common_nrbpar, only: niam,liam,jiam,mapiam            !par&
!par     &                        ,lproc,nprocperl                  !par
!par      use common_nrbpar, only: num                              !par
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (DEL=D1M6)                             !SYNC WITH RADIAL
      PARAMETER (D5M6=5*D1M6)
!
      PARAMETER (DCON2=1.5789E+5_WP)            !DONE/T_BOLTZ
      PARAMETER (DCON3=5.29177E-9_WP)           !=A0_BOHR
      PARAMETER (DCON4=3.224_WP)                !(32*XPI/DTHREE)**D1THRD
      PARAMETER (DCON5=25.1327_WP)              !=8*XPI
      PARAMETER (DCON6=0.2387_WP)               !=DTHREE/(DFOUR*XPI)
!
! ASSIGN UNIT NUMBERS
!
      CHARACTER(LEN=4) MBLK
      CHARACTER(LEN=5) NAM0
      CHARACTER(LEN=10) NAM
!
      LOGICAL BEX                         !INQUIRE REQUIRES DEFAULT KIND
!
      dimension dum1(1)
!
      DATA ICON,IPRINT/2,1/,MBLK/'    '/,BWARN/.TRUE./
!
!-----------------------------------------------------------------------
!
      btimet=btime.and.ieq(0).lt.0          !.t.gives radial+radcon time
!
      NF00=NF
      IF(NF.EQ.0)THEN                       !CALL WAS ONLY TO DEALLOCATE
        NF=1
        GO TO 500                                                !RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!                INTERNAL CONTROLS FOR DR LOOP, NOT DIRECTLY SET BY USER
      BDR=IDR.NE.0                !FOR 'DR' LOOPING OVER DUMMY RYDBERG
      BJUMP=.FALSE.               !.T. FOR SUBSEQUENT N-LOOPS (SKIP)
      BJUMP2=.FALSE.              !.T. FOR UP/DOWNSCALING 1/N**3
      BRAD=.TRUE.                 !.T. RECALCULATE RADIATIVE DATA.
      NNEW=MAXNV
      LMX0=-999
!
!-----------------------------------------------------------------------
!
! READ USER INPUT AND PERFORM CHECKS ON INITIAL SET-UP
!
      CALL MINIM0(MPRINT,NLAM,NVAR,IMAXIT,TVARY,ICM,ICP)
!
      IF(NZION.EQ.0.OR.NF.LE.0)GO TO 500                         !RETURN
!
!-----------------------------------------------------------------------
!
      BORT=MORT.LT.0
      JPRINT=MOD(MPRINT,ITEN)
      NPRNT5=MOD(NPRINT,IFIVE)
      BCONT=MODE.EQ.2.OR.MODE.EQ.3
      BCASC=KUTCAS.GE.0.AND.NJO.GT.0.AND.NPRNT5.GT.-2.AND.              &
     &      .NOT.BCONT.AND..NOT.BDR
!
!-----------------------------------------------------------------------
!
! READ USER INPUT AND SET-UP ENERGY MESH BASED-ON THIS, OR BEST GUESS
!
      IF(BCONT)THEN
!
        CALL RADCN0(MDUM1,MDUM2,MDUM3,-DONE)
!
        IF(NF.LE.0)GO TO 500                                    !RETURN
!
        IF(BNAME)THEN
          REWIND(MR5)
        ELSEIF(BHFF)THEN
          WRITE(MW6,10170)
          WRITE(MW0,*)                                                  &
     &       '*** SR.MINIM: MUST USE NAMELIST FOR radwin PLUS CONTINUUM'
          GO TO 600                                              !RETURN
        ENDIF
!
      ELSE                   !HISTORIC, FOR SAFETY, SHOULD NOT BE NECESS
!
        ACE=D1P10
        MENG=1                                        !FOR ALLOCATED TBD
        NREL=1
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      NP0=0
      IF(IPOLFN.LT.0)NP0=-IPOLFN
      NPARM3=(NP0+1)*NPARAM
!
      DO I=1,NPARM3
        J=IEQUAL(I)
        IF(J.GT.0)THEN
!           IF(J.LE.NLAM)THEN                   !CONTROLLED BY IEQUAL
          IF(DEXTRE(J).LT.DZERO)DAJNEW(I)=-DONE      !JUST FLAG FOR MESH
!           ENDIF
        ENDIF
      ENDDO
!
!-----------------------------------------------------------------------
!
! SET-UP RADIAL MESH FOR ALLOCATION - SEE /CMESH/
!                                     CALLED AGAIN IN SR.RADIAL FOR DX
!
      NZA=MAX(IONE,NZION-MION+1)
      TOLR=DEL/NZA
      IF(ABS(MORT).EQ.5)TOLR=TINORB                    !RZERO
!
      IFLAGR=0                             !DETERMINE MAXRS FOR ALLOCATE
!
      CALL MESH(NZION,MION,TOLR,DHNS0,DUM1,IFLAGR)
!
      maxrs0=maxrs                          !hold for last gasp test
!
      MXPIN=MAXRS
      MXQIN=MAXRS
!
!-----------------------------------------------------------------------
!
! ALLOCATE MOST ARRAYS
!
      CALL MINIM_ALLOC
!
      IF(NF.EQ.0)GO TO 500
!
!-----------------------------------------------------------------------
!
! DETRMINE (RELAXED) CONFIGURATION AVERAGE ENERGY
!
      IF(ICAV0.NE.0)THEN
!
!        ECAVX(1)=DZERO
        ECAV(1)=DZERO                    !INITIALIZE FOR SCCA - SEE ICAV
!
        ICAV=ABS(ICAV0)                        !>0 RELAXED
!
        CALL CAVE0(ICAV)
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! SET-UP MINIMALIZATION OF INCLUD TERMS (IN NVAR VARIABLE PARAMETERS
! WITH NLAM SCALING PARAMETERS, DEXTRE=DAJNEW)
!
!-----------------------------------------------------------------------
!
!
      ICOUNT0=0
      IF(INCLUD.NE.0)THEN
!
        IF(NF.LE.0)GO TO 500                    !RETURN
!
        BPRINT=JPRINT.GE.5                      !FOR DETAILED PRINTOUT
!
        IF(JPRINT.EQ.-2.AND.NPRNT5.EQ.-2)THEN
          WRITE(MW6,*)'*** SR.MINIM: ERROR, G FUNCTIONAL SPECIFIED FOR',&
     &                ' MINIMIZATION BUT E1 RADIATION IS OFF!'
          WRITE(MW0,*)'*** G FUNCTIONAL REQUIRES E1 RADIATION!'
          GO TO 600
        ENDIF
!
        IF(JPRINT.EQ.-2.AND.NJO.GT.0)THEN
          WRITE(MW6,*)'*** SR.MINIM: ERROR, G FUNCTIONAL SPECIFIED FOR '&
     &                ,                                                 &
     &  'MINIMIZATION IN IC, BUT G IS ONLY AVAILABLE IN LS MINIMIZATION'
          WRITE(MW0,*)                                                  &
     &              '*** G FUNCTIONAL ONLY AVAILABLE IN LS MINIMIZATION'
          GO TO 600
        ENDIF
!
! SWITCH-OFF QUANTITIES NOT NEEDED DURING OPTIMIZATION, SWITCH-ON AFTER
!
        NPRNT5=NPRINT                                 !TEMP
        IF(JPRINT.NE.-2)THEN                          !SWITCH-OFF RAD
          NPRINT=-2
          IF(NPRNT5.NE.MOD(NPRNT5,IFIVE))NPRINT=-7    !REL WAVEFN
        ENDIF
        MRAD0=MRAD                                    !TEMP
        MRAD=0                                        !SWITCH-OFF RADOUT
        MENGB0=MENGB                                  !TEMP
        MENGB=-2                                      !SWITCH-OFF BORN
        MDEN0=MDEN
        IF(MDEN.LT.0)MDEN=-1
!                                               !DUMP ols/u,oic/u OUTPUT
        IF(BPRINT)THEN
          IF(IUNIT(MW7).GT.0)THEN                          !SHOULDN'T BE
            WRITE(MW6,*)'UNIT=MW7 ALREADY OPEN'
            WRITE(MW0,*)'UNIT=MW7 ALREADY OPEN'
            GO TO 600
          ENDIF
          IUNIT(MW7)=1
          OPEN(MW7,STATUS='SCRATCH',FORM='FORMATTED')      !DUMP
          IF(NJO.GT.0)THEN
            IF(IUNIT(MW8).GT.0)THEN                        !SHOULDN'T BE
              WRITE(MW6,*)'UNIT=MW8 ALREADY OPEN'
              WRITE(MW0,*)'UNIT=MW8 ALREADY OPEN'
              GO TO 600
            ENDIF
            IUNIT(MW8)=1
            OPEN(MW8,STATUS='SCRATCH',FORM='FORMATTED')    !DUMP
          ENDIF
        ELSE
          IF(IUNIT(MW27).GT.0)THEN                         !SHOULDN'T BE
            WRITE(MW6,*)'UNIT=MW27 ALREADY OPEN'
            WRITE(MW0,*)'UNIT=MW27 ALREADY OPEN'
            GO TO 600
          ENDIF
          IUNIT(MW27)=1
          OPEN(MW27,STATUS='SCRATCH',FORM='UNFORMATTED')   !DUMP
          IF(NJO.GT.0)THEN
            IF(IUNIT(MW28).GT.0)THEN                       !SHOULDN'T BE
              WRITE(MW6,*)'UNIT=MW28 ALREADY OPEN'
              WRITE(MW0,*)'UNIT=MW28 ALREADY OPEN'
              GO TO 600
            ENDIF
            IUNIT(MW28)=1
            OPEN(MW28,STATUS='SCRATCH',FORM='UNFORMATTED') !DUMP
          ENDIF
        ENDIF
!                                                    !DITTO TERMS/LEVELS
        IF(IUNIT(MRW14).GT.0)THEN                          !SHOULDN'T BE
          WRITE(MW6,*)'UNIT=MRW14 ALREADY OPEN'
          WRITE(MW0,*)'UNIT=MRW14 ALREADY OPEN'
          GO TO 600
        ENDIF
        IUNIT(MRW14)=1
        OPEN(MRW14,STATUS='SCRATCH',FORM='FORMATTED')      !DUMP
        IF(NJO.GT.0)THEN
          IF(IUNIT(MRW15).GT.0)THEN
            WRITE(MW0,*)'UNIT=MRW15 ALREADY OPEN'          !SHOULDN'T BE
            GO TO 600
          ENDIF
          IUNIT(MRW15)=1
          OPEN(MRW15,STATUS='SCRATCH',FORM='FORMATTED')    !DUMP
        ENDIF
!
! SET COUNTERS
!
        ICOUNT=-IMAXIT
        IF(IMAXIT.LE.0)IMAXIT=ABS(NVAR)
        IF(ICOUNT.LT.0)ICOUNT=4*ABS(NVAR)*IMAXIT+IMAXIT+2
        ICOUNT0=ICOUNT
!
! CALL THE MINIMIZATION ROUTINE, WHICH CALLS THE FUNCTIONAL SR CALCFX
! (THEY NO LONGER USE NLAM EXPLICITLY, UNLESS ZERO.)
!
        IF(NVAR.GT.0)THEN
!
! POWELL'S METHOD ("NAG")
!
          T=TVARY                                          !0.01
          DO N=0,NP0
            N0=N*NPARAM
            DO I=1,NPARAM
              I0=IEQUAL(N0+I)
              IF(I0.LE.NVAR)DACCUR(I0)=T !VARY SCALE BY UP TO T PER ITER
            ENDDO
            IF(N.EQ.1)T=T/DTEN
          ENDDO
!
          CALL VA04A(DEXTRE,DACCUR,NVAR,NLAM,DF,DTEN,IPRINT,ICON,IMAXIT)
!
          IF(NLAM.EQ.0)THEN                                 !OPT FAILURE
            WRITE(MW6,*)'*** SR.MINIM: VA04A MINIMIZATION FAILURE'
            WRITE(MW0,*)'*** SR.MINIM: VA04A MINIMIZATION FAILURE'
          ENDIF
!
        ELSE
!
! CONJUGATE GRADIENT
!
!   INTERFACE TO NAPACK ROUTINES (CAN BE SUPPLIED)
!
!          CALL CGNA(DEXTRE,NVAR,IMAXIT)
!
!   INTERFACE TO NUMERICAL RECIPES ROUTINES
!   (*NOT* SUPPLIED AS LICENSE REQUIRED - LINK TO YOUR OWN LIBRARY)
!
          CALL CGNR(DEXTRE,NVAR,IMAXIT)           !USE REAL *8 NUM. REC.
!
          IF(IMAXIT.LT.0)THEN                               !OPT FAILURE
            WRITE(MW6,*)'*** SR.MINIM: CGNR MINIMIZATION FAILURE'
            WRITE(MW0,*)'*** SR.MINIM: CGNR MINIMIZATION FAILURE'
          ENDIF
!
        ENDIF
!
        IF(NF.LE.0)GO TO 500                              !FATAL FAILURE
!
! NO DETAILED PRINTOUT DURING ITERATION, THEREFORE NOW PRINTOUT THE
! MINIMIZING SCALE FACTORS, HAVING ROUNDED THEM TO 5 DECIMALS
! NOTE: DEXTRE(I.GT.NLAM)=1 DURING OPT, UNLESS "FIXED", SO DO NOT USE
! DEXTRE(I)=DEXTRE(NLAM) FOR I.GT.NLAM HERE.
!
!        WRITE(MW6,898)(DEXTRE(I),I=1,NVAR)
!
        DO I=1,NPARM3
          MM=INT(100000*(DEXTRE(I)+D5M6),SP)
          DEXTRE(I)=D1M5*MM
        ENDDO
        DO N=0,NP0
          N0=N*NPARAM
          I0=0
          DO I=1,NPARAM
            J=IEQUAL(N0+I)
            IF(J.LE.NVAR)THEN
              I0=I0+1
              DACCUR(I0)=DEXTRE(J)
            ENDIF
          ENDDO
          IF(N.EQ.0)WRITE(MW6,10090)(DACCUR(I),I=1,I0)
          IF(I0*N.GT.0)WRITE(MW6,10080)N,(DACCUR(I)-DONE,I=1,I0)
                                                              !DACCUR(I)
        ENDDO
!
! force re-compute to get non-opt energies
!
        if(irlx.ne.2.and.mort.eq.-3)dadjus=dzero
!
! TIDY-UP
!
        NPRINT=NPRNT5                                        !RE-INSTATE
        MRAD=MRAD0
        MENGB=MENGB0
        MDEN=MDEN0
!
        IF(IUNIT(MW7).GT.0)THEN                       !CLOSE-OFF SCRATCH
          CLOSE(MW7)
          IUNIT(MW7)=0
        ENDIF
        IF(IUNIT(MW8).GT.0)THEN
          CLOSE(MW8)
          IUNIT(MW8)=0
        ENDIF
        IF(IUNIT(MRW14).GT.0)THEN
          CLOSE(MRW14)
          IUNIT(MRW14)=0
        ENDIF
        IF(IUNIT(MRW15).GT.0)THEN
          CLOSE(MRW15)
          IUNIT(MRW15)=0
        ENDIF
!
        IF(IUNIT(MW27).GT.0)THEN                      !CLOSE-OFF SCRATCH
          CLOSE(MW27)
          IUNIT(MW27)=0
        ENDIF
        IF(IUNIT(MW28).GT.0)THEN
          CLOSE(MW28)
          IUNIT(MW28)=0
        ENDIF
!
       ICOUNT0=1
!
      ENDIF
!
      ICOUNT=0
!
      IF(INCLUD.LT.0)THEN
        INCLUD=-1000000+INCLUD
      ELSE
        INCLUD=1000000+INCLUD
      ENDIF
!
! END MINIMIZATION -----------------------------------------------------
!
!
! MPRINT=AB GIVES LS.JPRINT=B AND IC.JPRINT=A  AND BOTH HAVE
! THE SAME SIGN, THAT OF MPRINT.
! NOT TO BE CONFUSED WITH ALGEBRAIC MPRINT (OR NPRINT)
!
      BPRINT=.TRUE.
      LSPRNT=JPRINT
      ICPRNT=MPRINT/10
!
      NPRNT5=MOD(NPRINT,IFIVE)
      BCPRNT=(MOD(MPNCH,ITWO).NE.0)                        !TCC's WANTED
!
!      btfu=.true.
      BTFU=NJO.GT.0.AND.(ISHFTLS.NE.0.OR.BCPRNT)    !hold LS for TEC/TCC
      IF(BTFU)KUTDSK=ABS(KUTDSK)             !TFU MUST BE IN MEMORY THEN
!
      IF(MODE.GT.0)THEN                 !OPEN CA/LS FILES
!
        JPRINT=LSPRNT
        BPRNT0=JPRINT.NE.-3
!
        NAM0=''
!par!                                                               !par
!par        if(idw.eq.0)then                                        !par
!par          j1=liam/10                                            !par
!par          j2=liam-(10*(liam/10))                                !par
!par          if(nprocperl.eq.1)then      !don't extend if 1        !par
!par            nam0=num(j1)//num(j2)                               !par
!par          else                                                  !par
!par            i1=jiam/10                                          !par
!par            i2=jiam-(10*(jiam/10))                              !par
!par            nam0=num(j1)//num(j2)//'.'//num(i1)//num(i2)        !par
!par          endif                                                 !par
!par        endif                                                   !par
!par!                                                               !par
        IF(MODE.EQ.1.AND..NOT.BDR)THEN            !CASE BOUND-BOUND LOOP
          IF(IUNIT(MRW14).EQ.0)THEN
            IUNIT(MRW14)=1
            IF(NSL0.GT.0)THEN
              NAM='TERMS'
            ELSE
              NAM='CAVES'
            ENDIF
            OPEN(MRW14,FILE=NAM,STATUS='REPLACE')             !TERM LIST
          ENDIF
          IF(ITANAL.NE.0)THEN              !NO NEW BANAL, ONLY ALGEBRAIC
            IF(IUNIT(MRW31).EQ.0)THEN
              IUNIT(MRW31)=1
              OPEN(MRW31,FILE='ITANAL',STATUS='REPLACE')    !SMALL TERMS
            ELSE
              IF(IUNIT(MRW31).GT.0)CLOSE(MRW31)
              IUNIT(MRW31)=1
              OPEN(MRW31,FILE='ITANAL',STATUS='OLD',POSITION='APPEND')
            ENDIF
          ENDIF
        ENDIF
        IF(BPRNT0)THEN
          IF(IUNIT(MW7).EQ.0)THEN
            IUNIT(MW7)=1
            IF(NSL0.GT.0)THEN
              NAM='ols'//NAM0
            ELSE
              NAM='oca'//NAM0
            ENDIF
            OPEN(MW7,FILE=NAM,STATUS='REPLACE')        !RATES & ENERGIES
          ENDIF
        ENDIF
        IF(.NOT.BPRNT0)THEN
          IF(IUNIT(MW27).EQ.0)THEN
            IUNIT(MW27)=1
            IF(NSL0.GT.0)THEN
              NAM='olsu'//NAM0
            ELSE
              NAM='ocau'//NAM0
            ENDIF
            OPEN(MW27,FILE=NAM,FORM='UNFORMATTED',STATUS='REPLACE')
                                                       !RATES & ENERGIES
          ENDIF
        ENDIF
!
        IF(BFOT)THEN
          IF(BPRNT0)THEN
            IF(IUNIT(MW17).EQ.0)THEN
              IUNIT(MW17)=1
              IF(NSL0.GT.0)THEN
                NAM='opls'//NAM0
              ELSE
                NAM='opca'//NAM0
              ENDIF
              OPEN(MW17,FILE=NAM,STATUS='REPLACE')      !PHOTOIONIZATION
            ENDIF
          ENDIF
          IF(.NOT.BPRNT0)THEN
            IF(IUNIT(MW29).EQ.0)THEN
              IUNIT(MW29)=1
              IF(NSL0.GT.0)THEN
                NAM='oplsu'//NAM0
              ELSE
                NAM='opcau'//NAM0
              ENDIF
              OPEN(MW29,FILE=NAM,FORM='UNFORMATTED',STATUS='REPLACE')
                                                        !PHOTOIONIZATION
            ENDIF
          ENDIF
        ENDIF
!
        IF(ABS(MENGB).EQ.1)THEN
          IF(IUNIT(MRW23).LT.0)THEN
            WRITE(MW6,*)"TRYING TO RE-OPEN FILE='OMGINFLS'..."
            WRITE(MW0,*)'TRYING TO RE-OPEN UNIT=23'
            GO TO 600
          ELSEIF(IUNIT(MRW23).EQ.0)THEN
            IF(NSL0.GT.0)THEN
              NAM='LS'
            ELSE
              NAM='CA'
            ENDIF
!par            if(iam.eq.0)then                                    !par
            IUNIT(MRW23)=2-ABS(IDR)           !only close .gt.1, for par
            OPEN(MRW23,FILE='OMGINF'//NAM,STATUS='REPLACE')  !INF E BORN
!par            else                                                !par
!par              IUNIT(MRW23)=1                                    !par
!par              OPEN(MRW23,STATUS='SCRATCH')                      !par
!par            endif                                               !par
          ENDIF
        ENDIF
!
        if(.not.badas)then
          INQUIRE(FILE='../adas803.pl',EXIST=BEX)
          badas=BEX
        endif
        IF(ABS(MENGB).EQ.1.or.badas)THEN
          IF(IUNIT(MW21).LT.0)THEN
            WRITE(MW6,*)"TRYING TO RE-OPEN FILE='adasex.in.form'..."
            WRITE(MW0,*)'TRYING TO RE-OPEN UNIT=21'
            GO TO 600
          ELSEIF(IUNIT(MW21).eq.0.and.idw.eq.0)THEN
            IUNIT(MW21)=2-ABS(IDR)
            OPEN(MW21,FILE='adasex.in.form',STATUS='REPLACE')     !4ADAS
          ENDIF
        ENDIF
!
        IF(MENGB.GE.-1)THEN
          IF(IUNIT(MRW25).LT.0)THEN
            WRITE(MW6,*)"TRYING TO RE-OPEN FILE='adf04ls'..."
            WRITE(MW0,*)'TRYING TO RE-OPEN UNIT=25'
            GO TO 600
          ELSEIF(IUNIT(MRW25).EQ.0)THEN
            IF(NSL0.GT.0)THEN
              NAM='ls'
            ELSE
              NAM='ca'
            ENDIF
            IUNIT(MRW25)=2-ABS(IDR)
!par            if(iam.eq.0)then    !only used by proc 0            !par
            OPEN(MRW25,FILE='adf04'//NAM,STATUS='REPLACE') !PWB/DW
!par            else                                                !par
!par              OPEN(MRW25,STATUS='SCRATCH')             !PWB/DW  !par
!par            endif                                               !par
          ENDIF
        ENDIF
!
      ENDIF                             !END OF CA/LS FILE OPENING
!
      IF(NJO.GT.0)THEN                  !OPTIONAL FINE-STRUCTURE SET-UP
!
        IF(MODE.GT.0)THEN               !OPEN IC FILES
!
          JPRINT=ICPRNT
          BPRNT0=JPRINT.NE.-3
!
          NAM0=''
!par!                                                               !par
!par        if(idw.eq.0)then                                        !par
!par          j1=liam/10                                            !par
!par          j2=liam-(10*(liam/10))                                !par
!par          if(nprocperl.eq.1)then      !don't extend if 1        !par
!par            nam0=num(j1)//num(j2)                               !par
!par          else                                                  !par
!par            i1=jiam/10                                          !par
!par            i2=jiam-(10*(jiam/10))                              !par
!par            nam0=num(j1)//num(j2)//'.'//num(i1)//num(i2)        !par
!par          endif                                                 !par
!par        endif                                                   !par
!par!                                                               !par
!                                           CASE B-B LOOP
          IF(MODE.EQ.1.AND.IUNIT(MRW15).EQ.0.AND..NOT.BDR)THEN
            IUNIT(MRW15)=1
            OPEN(MRW15,FILE='LEVELS',STATUS='REPLACE')     !LEVEL LIST
          ENDIF
          IF(BPRNT0)THEN
            IF(IUNIT(MW8).EQ.0)THEN
              IUNIT(MW8)=1
              NAM='oic'//NAM0
              OPEN(MW8,FILE=NAM,STATUS='REPLACE')      !RATES & ENERGIES
            ENDIF
!            WRITE(MW8,891)NNEW,LNEW,(I,I=1,20)
          ENDIF
          IF(.NOT.BPRNT0)THEN
            IF(IUNIT(MW28).EQ.0)THEN
              IUNIT(MW28)=1
              NAM='oicu'//NAM0
              OPEN(MW28,FILE=NAM,FORM='UNFORMATTED',STATUS='REPLACE')
                                                       !RATES & ENERGIES
            ENDIF
!            WRITE(MW28)int(NNEW),int(LNEW)
          ENDIF
!
          IF(BFOT)THEN
            IF(BPRNT0)THEN
              IF(IUNIT(MW18).EQ.0)THEN
                IUNIT(MW18)=1
                NAM='opic'//NAM0
                OPEN(MW18,FILE=NAM,STATUS='REPLACE')    !PHOTOIONIZATION
              ENDIF
!              WRITE(MW18,891)NNEW,LNEW
            ENDIF
            IF(.NOT.BPRNT0)THEN
              IF(IUNIT(MW30).EQ.0)THEN
                IUNIT(MW30)=1
                NAM='opicu'//NAM0
                OPEN(MW30,FILE=NAM,FORM='UNFORMATTED',STATUS='REPLACE')
                                                        !PHOTOIONIZATION
              ENDIF
!              WRITE(MW30)int(NNEW),int(LNEW)
            ENDIF
          ENDIF
!
          IF(ABS(MENGB).EQ.1)THEN
            IF(IUNIT(MRW24).LT.0)THEN
              WRITE(MW6,*)"TRYING TO RE-OPEN FILE='OMGINFIC'..."
              WRITE(MW0,*)'TRYING TO RE-OPEN UNIT=24'
              GO TO 600
            ELSEIF(IUNIT(MRW24).EQ.0)THEN
              IUNIT(MRW24)=1
!par              if(iam.eq.0)then                                  !par
              IUNIT(MRW24)=2-ABS(IDR)         !only close .gt.1, for par
              OPEN(MRW24,FILE='OMGINFIC',STATUS='REPLACE')   !INF E BORN
!par              else                                              !par
!par                IUNIT(MRW24)=1                                  !par
!par                OPEN(MRW24,STATUS='SCRATCH')                    !par
!par              endif                                             !par
            ENDIF
          ENDIF
!
          IF(ABS(MENGB).EQ.1.or.badas)THEN
            IF(IUNIT(MW22).LT.0)THEN
              WRITE(MW6,*)"TRYING TO RE-OPEN FILE='adasexj.in.form'..."
              WRITE(MW0,*)'TRYING TO RE-OPEN UNIT=22'
              GO TO 600
            ELSEIF(IUNIT(MW22).eq.0.and.idw.eq.0)THEN
              IUNIT(MW22)=2-ABS(IDR)
              OPEN(MW22,FILE='adasexj.in.form',STATUS='REPLACE')  !4ADAS
            ENDIF
          ENDIF
!
          IF(MENGB.GE.-1)THEN
            IF(IUNIT(MRW26).LT.0)THEN
              WRITE(MW6,*)"TRYING TO RE-OPEN FILE='adf04ic'..."
              WRITE(MW0,*)'TRYING TO RE-OPEN UNIT=26'
              GO TO 600
            ELSEIF(IUNIT(MRW26).EQ.0)THEN
              IUNIT(MRW26)=2-ABS(IDR)
!par              if(iam.eq.0)then    !only used by proc 0          !par
              OPEN(MRW26,FILE='adf04ic',STATUS='REPLACE')  !PWB/DW
!par              else                                              !par
!par                OPEN(MRW26,STATUS='SCRATCH')           !PWB/DW  !par
!par              endif                                             !par
            ENDIF
          ENDIF
!
        ENDIF                           !END OF IC FILE OPENING
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! PLASMA RE-ENTRY POINT
!
      ND0=1
  100 IF(MDEN.GT.0)THEN
!
        T=NZION-MION+1            !FOR INFO, EXACT SET IN RADIAL/RADCON
        DENE=DENS(ND0)*DCON3**3
        IF(DENSI(ND0).LE.DZERO)DENSI(ND0)=DENS(ND0)/T         !NOT USED
        DENI=DENSI(ND0)*DCON3**3
        R0=DZERO
        IF(DENI.NE.DZERO)R0=(DCON6/DENI)**D1THRD
        TKAY=TKAYS(ND0)
        IF(TKAY.LT.DZERO)TKAY=-TKAY/DCON2                     !K->RYD
!
        GAMQ=DZERO
        DEBYE=DZERO
        IF(DENE*TKAY.NE.DZERO)THEN
          DEBYE=SQRT(DCON5*DENE/TKAY)
          DEBYE=DONE/DEBYE
          IF(R0.NE.DZERO)THEN
            GAMQ=DCON4*T*T
            GAMQ=GAMQ*DENI**D1THRD/TKAY
          ENDIF
        ENDIF
!
        WRITE(MW6,10160)MDEN,DENSI(ND0),DENS(ND0),TKAY,GAMQ,DEBYE,R0
!
        IF(MOD(MDEN,ITEN).EQ.1)THEN                        !DEBYE-HUCKEL
          WRITE(MW6,10010)
          IF(NPITER.GT.0)WRITE(MW6,10020)           !1-BODY INC NON-PERT
          IF(NPITER.LT.0)WRITE(MW6,10030)               !1-BODY INC PERT
          IF(MDEN.EQ.11)WRITE(MW6,10040)                     !2-BODY INC
        ELSEIF(MDEN.EQ.2)THEN                                !ION-SPHERE
          IF(XBEE.EQ.DZERO)WRITE(MW6,10050)                     !UNIFORM
          IF(XBEE.NE.DZERO)WRITE(MW6,10060)XBEE             !NON-UNIFORM
        ELSEIF(MDEN.EQ.3)THEN                                 !KOHN-SHAM
          WRITE(MW6,10070)
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! SET-UP LOOP OVER RYDBERG ORBITAL(S), ASSIGN VALUES TO DUMMY
!
      IF(BDR)THEN
!
        LMX0=LMAX
        IF(KSHIFT.LE.0)THEN
          IJUMP2=-1
        ELSE            !CAN SKIP CONT E=0 GENERATION
          IJUMP2=0
        ENDIF
        IJUMP0=IJUMP2
        KRAD=-1
!par!                                                               !par
!par        if(mapiam.gt.0)then             !one n per proc         !par
!par          n=abs(niam)                                           !par
!par          if(n.le.lnew)go to 5500  !case > one l per RESTART    !par
!par          go to 5000                                            !par
!par        endif                                                   !par
!
        I0=0
!par        i0=i0+mod(iam,nprocperl)                                !par
        I1=I0+1
!
        IF(NMIN.GT.0.AND.NMIN+i0.LE.NMAX)THEN           !INITIAL N-VALUE
          ND=I0
!par          nd=nd-nprocperl+1                                     !par
          N=NMIN+I0
        ELSEIF(JND.LE.0)THEN         !FLAG FOR INFO & WRITE A TERMINATOR
          WRITE(MW6,10100)LNEW
          WRITE(MW0,*)'***CANNOT ASSIGN ANY N-VALUES TO RYDBERG L=',LNEW
          GO TO 400
        ELSE
          ND=I1
          if(nd.gt.jnd)go to 400              !satsfied by parallel only
          N=NDR(ND)
        ENDIF
        IF(BLOOP.AND.LNEW.GE.N)THEN   !NEED TO INCREMENT NMIN FOR THIS L
!par          if(nprocperl.gt.1.and.nd.le.0)stop 'nd .le. 0 ....'   !par
          N=LNEW+1
          IF(ND.GT.0)THEN                    !.OR.JND.GT.0.AND.N.GT.NMAX
            WRITE(MW6,*)'*** NEED NMAX OF AT LEAST:',N
            WRITE(MW0,*)'*** NEED NMAX OF AT LEAST:',N
            GO TO 600
          ELSEIF(N.GT.NMAX)THEN
            GO TO 400
          ENDIF
        ENDIF
!
        I1=1
!par        i1=i1+nprocperl-1                                       !par
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! RYDBERG-N RE-ENTRY POINT
!par!                                                               !par
!par 5000 continue                                                  !par
!
  200 IF(BDR)THEN
!
        IF(N+I1.GT.NMAX.AND.ND+I1.GT.JND)JND=-JND-1    !LAST, AS NO NEXT
!
        DO I=1,MXORB
          IF(IVAL(I).NE.0)THEN          !ASSIGN NL TO RYDBERG ORBITAL(S)
            if(bloop.and.lnew.ne.ql(i)/2)then
              if(mstrt0.ne.0)THEN
                write(mw6,10210)LMIN
                write(mw0,*)'(RESTART) Rydberg-l mis-alignment?'
              else
                write(mw6,*)'Rydberg-l mis-alignment...'
                write(mw0,*)'Rydberg-l mis-alignment...'
              endif
              go to 600
            endif
            QN(I)=INT(N,QP)
            IF(N.LT.NSW)THEN
              IF(BORT)THEN
                L=I
              ELSEIF(BLOOP)THEN
                L=LNEW+1
              ELSE
                L=0
              ENDIF
              IF(L.GT.0)DADJUS(L)=DZERO
            ELSEIF(KSHIFT.LE.0)THEN
              IF(IJUMP2.LT.0)SCREEN(I)=6999
              IF(IJUMP2.GE.0)QN(I)=-INT(N,QP)
            ENDIF
          ENDIF
        ENDDO
!
        NNOLD=NNEW
        NNEW=N
!old                                              IF(.NOT.BLOOP)LNEW=999
        WRITE(MW6,10110)NNEW,LNEW
!       call flush(mw6)             !useful for debug large UNFORM cases
!
! THIS REPEATS ALGEB0 INCASE USER RESTART SIDESTSEPS ORIGINAL CHECK
        IF(N.GT.NBOUND.AND.N.LT.NSW)THEN !CHECK TRUE BOUND NOT TOO LARGE
          IF(NSW.EQ.9999)THEN
            WRITE(MW6,*)'*** TRUE BOUND N TOO LARGE, SET RUN.NE." ":',N
            WRITE(MW0,*)'*** TRUE BOUND N TOO LARGE, SET RUN.NE." ":',N
          ELSEIF(NSW.GT.NBOUND)THEN
            WRITE(MW6,*)'*** TRUE BOUND N TOO LARGE, REDUCE NSW:',NSW
            WRITE(MW0,*)'*** TRUE BOUND N TOO LARGE, REDUCE NSW:',NSW
          ELSE
            WRITE(MW6,*)'*** TRUE BOUND N TOO LARGE, REDUCE:',N
            WRITE(MW0,*)'*** TRUE BOUND N TOO LARGE, REDUCE:',N
          ENDIF
          GO TO 600
        ENDIF
!
        IF(NMETAR.NE.0.AND.ECOR1.NE.DZERO.OR.NMETARJ.NE.0.AND.          &
     &     ECOR2.NE.DZERO)THEN                           !BUNDLED AUGERS
          IF(BWARN)THEN
            WRITE(MW6,10190)
            BWARN=.FALSE.
          ENDIF
          T=NZA
          T=T/NNEW
          T=-T*T
          IF(T.GT.2*ECOR1.OR.T.GT.2*ECOR2)THEN
            WRITE(MW6,10180)
            WRITE(MW0,*)                                                &
     & '*** ERROR: BUNDLED AUGERS HAVE MOVED ABOVE THEIR OWN CONTINUUM!'
            GO TO 600
          ENDIF
        ENDIF
!
        BRAD=N.LE.NRAD
        IF(.NOT.BRAD)KRAD=KRAD+1
        IF(KRAD.EQ.0)WRITE(MW6,10130)NRAD
!
        IF(N.GE.NSW)THEN
          IF(IJUMP2.EQ.IJUMP0)WRITE(MW6,10120)NSW
          IJUMP2=IJUMP2+1
          BJUMP2=IJUMP2.GT.0
!         BHFF=.TRUE.
          MAUTO=1
          IF(ICM.LT.0)MAUTO=0
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! *** COMPUTE NON-RELATIVISTIC CASE
!
!-----------------------------------------------------------------------
!
      JPRINT=LSPRNT
      BPRNT0=JPRINT.NE.-3
!
      IF(MODE.GT.0)THEN                 !WRITE HEADERS TO FILES
        IF(BPRNT0)WRITE(MW7,10140)NNEW,LNEW,(I,I=1,20)
        IF(.NOT.BPRNT0)WRITE(MW27)int(NNEW),int(LNEW)
        IF(BFOT)THEN
          IF(BPRNT0)WRITE(MW17,10140)NNEW,LNEW
          IF(.NOT.BPRNT0)WRITE(MW29)int(NNEW),int(LNEW)
        ENDIF
      ENDIF                             !END OF HEADERS
!
!-----------------------------------------------------------------------
!
! BEGIN CALCULATIONS: RADIAL
!
!-----------------------------------------------------------------------
!
      IF(.NOT.BJUMP2)THEN                   !UPDATE RADIAL FUNCTIONS
!
        IF(.NOT.BJUMP)THEN                  !ASSIGN SCALING FACTORS
          DO I=1,NPARM3
            J=IEQUAL(I)
            IF(J.GT.0)THEN
              DAJNEW(I)=DEXTRE(J)
              IF(BALAN)THEN                 !TRANSFER TO POT SUBSHELLS
                DALAN(I)=DEXTRE(J)
                DADJUS(I)=DZERO             !SO RE-COMPUTE ALL ORBITALS
                if(dalan(i).lt.dzero)then
                  write(mw6,10150)i,dalan(i)
                  write(mw0,                                            &
     & "('***SR.MINIM:STO SUBSHELL POTENTIAL LAMBDAS MUST BE POSITIVE')"&
     & )
                  go to 600
                endif
              ENDIF
            ENDIF
          ENDDO
        ENDIF
!
        IF(ISCALR.GT.0)SCALER=DAJNEW(ISCALR)
                                            !SLATER SCALING PARAMETER
!
        if(btimet)call nrb_time(timei)
!
        CALL RADIAL(DAJNEW)
!
        if(btimet)then
          call nrb_time(timef)
          times=timef-timei
!par          if(iam.ge.0)then                                      !par
!par            write(iwp,*)'proc',iam,' for minim:'                !par
!par            write(iwp,*)'    radial+radcon time=',nint(times)   !par&
!par     &                  ,'sec,     ',nint(times/60),'min'       !par
!par            call flush(iwp)                                     !par
!par          else                                                  !par
          write(iw,*)'radial+radcon time=',nint(times),'sec,     ',     &
     &               nint(times/60),'min'
!par          endif                                                 !par
        endif
!
        IF(NF.LE.0)GO TO 500                                     !RETURN
!
        IF(ICAV0.NE.0)THEN
          if(ecav(1).eq.dzero)then                  !UNIQUE, ind. of Ryd
            ICAV=-ABS(ICAV0)
!
            CALL CAVE0(ICAV)               !CONFIGURATION AVERAGE ENERGY
          endif
!
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! BEGIN CALCULATIONS: CONFIGURATION AVERAGE
!
!-----------------------------------------------------------------------
!
      IF(NSL0.LT.0)THEN
!
        if(btime)then
!par          if(iam.ge.0)then                                      !par
!par            write(iw,*)'Starting proc',iam,' for carate'        !par
!par          else                                                  !par
          write(iw,*)'Starting carate'
!par          endif                                                 !par
          if(bdr)write(iw,*)'n=',nnew,'  l=',lnew
          call nrb_time(timei)
        endif
!
        CALL CARATE(DECORE,DF)
!
        if(btime)then
          call nrb_time(timef)
          times=timef-timei
!
          if(bdr)write(iw,*)'n=',nnew,'  l=',lnew
!par          if(iam.ge.0)then                                      !par
!par            write(iw,*)'Ending proc',iam,' for carate:'         !par&
!par     &               ,' time=',nint(times),'sec,     '          !par&
!par     &               ,nint(times/60),'min'                      !par
!par            call flush(iw)                                      !par
!par          else                                                  !par
          write(iw,*)'Ending carate: time=',nint(times),'sec,     ',    &
     &               nint(times/60),'min'
!par          endif                                                 !par
        endif
!
        GO TO 300                                            ! ALL DONE!
      ENDIF
!
!-----------------------------------------------------------------------
!
! BEGIN CALCULATIONS: DIAGON
!
!-----------------------------------------------------------------------
!
      if(btime)then
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Starting proc',iam,' for diagon'          !par
!par        else                                                    !par
        write(iw,*)'Starting diagon'
!par        endif                                                   !par
        if(bdr)write(iw,*)'n=',nnew,'  l=',lnew
        call nrb_time(timei)
      endif
!
      CALL DIAGON(DECORE,DF)                 !DIAG H(LS) & COMPUTE RATES
!
      if(btime)then
        call nrb_time(timef)
        times=timef-timei
!
        if(bdr)write(iw,*)'n=',nnew,'  l=',lnew
!par        if(iam.ge.0)then                                        !par
!par          write(iw,*)'Ending proc',iam,' for diagon:'           !par&
!par     &               ,' time=',nint(times),'sec,     '          !par&
!par     &               ,nint(times/60),'min'                      !par
!par          call flush(iw)                                        !par
!par        else                                                    !par
        write(iw,*)'Ending diagon: time=',nint(times),'sec,     ',      &
     &             nint(times/60),'min'
!par        endif                                                   !par
      endif
!
      IF(NF.LE.0)GO TO 300                            !RETURN EVENTUALLY
!
      IF(.NOT.BTFU)THEN               !LS CI NOT NEEDED
! EX-COMMON/TRANS/
        DEALLOCATE(TFU,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR TFU'
          NF=0
          GO TO 300                                              !RETURN
        ENDIF
      ENDIF
!
      IF(.NOT.BTFU.AND.KTCC.EQ.0)THEN                   !NO TCCs OR TECs
! EX-COMMON/TRANLS/
        DEALLOCATE(NADRU,NAI,IEORD,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR NADRU,NAI,IEORD'
          NF=0
          GO TO 300                                              !RETURN
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
! *** COMPUTE FINESTRUCTURE
!
!-----------------------------------------------------------------------
!
      IF(NJO.GT.0)THEN
!
        JPRINT=ICPRNT
        BPRNT0=JPRINT.NE.-3
!
!-----------------------------------------------------------------------
!
        IF(MODE.GT.0)THEN               !WRITE HEADERS TO FILES
          IF(BPRNT0)WRITE(MW8,10140)NNEW,LNEW,(I,I=1,20)
          IF(.NOT.BPRNT0)WRITE(MW28)int(NNEW),int(LNEW)
          IF(BFOT)THEN
            IF(BPRNT0)WRITE(MW18,10140)NNEW,LNEW
            IF(.NOT.BPRNT0)WRITE(MW30)int(NNEW),int(LNEW)
          ENDIF
        ENDIF                           !END OF HEADERS
!
!-----------------------------------------------------------------------
!
! SET-UP FOR OPTIONAL CASCADE COEFFICIENTS
!
        IF(BCASC)THEN
!TEST          IF(MXNOR.GT.1)THEN                           !ALLOW LIMIT
!TEST            IXNOR=MXNOR
!TEST          ELSE
          IXNOR=MIN(NLEV,46340_SP)                    !CASE V.LARGE NLEV
          IXNOR=IXNOR*IXNOR/6
!TEST          ENDIF
          IXNOR=MAX(IXNOR,600_SP)
!
          ALLOCATE(AP(IXNOR),MADD(0:IXNOR),STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR AP,MADD'
            NF=0
            GO TO 300                                            !RETURN
          ENDIF
        ENDIF
!
!-----------------------------------------------------------------------
!
! BEGIN CALCULATIONS: SOCC & DIAGFS
!
!-----------------------------------------------------------------------
!
        IF(.NOT.BJUMP2)THEN                 !BLUME & WATSON CONTRIBUTION
!
!             if(btime)call nrb_time(timei)
!
          CALL SOCC
!
!             if(btime)then
!               call nrb_time(timef)
!               write(iw,*)'socc time=',nint(timef-timei),'sec'
!             endif
!
          IF(NF.LE.0)GO TO 300                        !RETURN EVENTUALLY
!
        ENDIF
!
        if(btime)then
!par          if(iam.ge.0)then                                      !par
!par            write(iw,*)'Starting proc',iam,' for diagfs'        !par
!par          else                                                  !par
          write(iw,*)'Starting diagfs'
!par          endif                                                 !par
          if(bdr)write(iw,*)'n=',nnew,'  l=',lnew
          call nrb_time(timei)
        endif
!
        CALL DIAGFS(DECORE,DFFS)             !DIAG H(IC) & COMPUTE RATES
!
        if(btime)then
          call nrb_time(timef)
          times=timef-timei
!
          if(bdr)write(iw,*)'n=',nnew,'  l=',lnew
!par          if(iam.ge.0)then                                      !par
!par            write(iw,*)'Ending proc',iam,' for diagfs:'         !par&
!par     &                 ,' time=',nint(times),'sec,     '        !par&
!par     &                 ,nint(times/60),'min'                    !par
!par            call flush(iw)                                      !par
!par          else                                                  !par
          write(iw,*)'Ending diagfs: time=',nint(times),'sec,     ',    &
     &               nint(times/60),'min'
!par          endif                                                 !par
        endif
!
      ENDIF                              !END OF OPTIONAL FINE-STRUCTURE
!
!-----------------------------------------------------------------------
!
  300 CONTINUE
!
! EX-COMMON/TRANS/
      IF(ALLOCATED(TFU))THEN
        DEALLOCATE(TFU,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR TFU'
          NF=MIN(NF,IZERO)
        ENDIF
      ENDIF
!
! EX-COMMON/TRANLS/
      IF(ALLOCATED(NADRU))THEN
        DEALLOCATE(NADRU,NAI,IEORD,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR NADRU,NAI,IEORD'
          NF=MIN(NF,IZERO)
        ENDIF
      ENDIF
!
      IF(NF.LE.0)GO TO 500                                       !RETURN
!
!-----------------------------------------------------------------------
!
! DETERMINE NEXT N-VALUE FOR RESONANCE (DR/RR/RE ETC) OPERATION
!
!-----------------------------------------------------------------------
!
      IF(BDR)THEN
!par        if(mapiam.gt.0)go to 5500 !no more, as one n per proc   !par
        ICM=0
        BHFF=.FALSE.
        IF(ICP.GT.0)MAUTO=1
        BJUMP=.TRUE.
        I1=1
!par        i1=i1+nprocperl-1                                       !par
        N=N+I1
        IF(N.LE.NMAX)GO TO 200
                              !.AND.ND.le.0     !LOOP BACK-UP WITH NEW N
        ND=ND+I1
        IF(ND.LE.JND)THEN
          N=NDR(ND)
          GO TO 200                             !LOOP BACK-UP WITH NEW N
        ENDIF
      ENDIF
!
! WRITE TERMINATORS
!par!                                                               !par
!par 5500 continue                                                  !par
!
  400 IF(MODE.GT.0.AND.LNEW.GE.LMX0)THEN
        IF(BPRNT0)WRITE(MW7,10200)MBLK
        IF(.NOT.BPRNT0)WRITE(MW27)int(IZERO),int(IZERO)
        IF(BFOT)THEN
          IF(BPRNT0)WRITE(MW17,10200)MBLK
          IF(.NOT.BPRNT0)WRITE(MW29)int(IZERO),int(IZERO)
        ENDIF
!
        IF(NJO.GT.0)THEN                         !RELATIVISTIC
          IF(BPRNT0)WRITE(MW8,10200)MBLK
          IF(.NOT.BPRNT0)WRITE(MW28)int(IZERO),int(IZERO)
          IF(BFOT)THEN
            IF(BPRNT0)WRITE(MW18,10200)MBLK
            IF(.NOT.BPRNT0)WRITE(MW30)int(IZERO),int(IZERO)
          ENDIF
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
! BEGIN CALCULATIONS: CASCADE COEFFICIENTS
!
!-----------------------------------------------------------------------
!
      IF(BCASC)THEN
!
        CALL CASC
!
        DEALLOCATE(AP,MADD,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE ALLOCATION FAILS FOR AP,MADD'
          IF(NF.GT.0)NF=0
        ENDIF
!
        IF(NF.LE.0)GO TO 500                                     !RETURN
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! NEW PLASMA POTENTIAL
!
      IF(NDEN.GT.0)THEN
        NDEN=NDEN-1
        ND0=ND0+1
        ZNP0=-999
        DO I=1,NPARM3
          DADJUS(I)=DZERO
        ENDDO
        IF(BCONT)THEN
          DO I=1,MXORB
            IF(QN(I).LT.0.AND.IVAL(I).EQ.0)SCREEN(I)=9999  !RE-INIT CONT
          ENDDO
!OLD          DO I=1,MENG
!OLD            DYY(I)=DYY(I)*DTWO              !****CONVERT BACK TO RYD
!OLD          ENDDO
        ENDIF
        GO TO 100        !LOOP BACK-UP WITH NEW TEMP AND DENSITY (INDEX)
      ELSE
        GO TO 500                                                !RETURN
      ENDIF
!
!
!-----------------------------------------------------------------------
!
! DE-ALLOCATE EVERYTHING
!
  500 CONTINUE
!
      CALL MINIM_DEALLOC
!
!-----------------------------------------------------------------------
!
!
      IF(NF.LE.0)THEN                              !MINIM BRANCH FAILURE
        NF0=NF
      ELSE
        NF=NF00
        NF0=MAX(NF0,NF)                        !MAX CATCH DIMENSION TEST
      ENDIF
!
! test for radial allocation out-of-bounds, better late than never...
!
      if(nzion.ne.0)then                       !get maxrs used by radial
        iflagr=-1
        idum=0
        call mesh(idum,idum,dum,dum,dum1,iflagr)
        if(iflagr.gt.maxrs0)then
          write(mw0,*)'alloc=',maxrs0,'   max used=',iflagr
          nf=-1
        endif
      endif
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
  600 IF(NF.GT.0)NF=-1
!
      GO TO 500                                                  !RETURN
10010 FORMAT(/5X,'DEBYE-HUCKEL PLASMA SCREENING POTENTIAL IN USE:')
10020 FORMAT(/5X,'ONE-BODY CONTRIBUTION IS INCLUDED NON-PERTURBATIVELY')
10030 FORMAT(/5X,'ONE-BODY CONTRIBUTION TREATED AS A PERTURBATION')
10040 FORMAT(/5X,'TWO-BODY CONTRIBUTION INCLUDED (PERTURBATIVE ONLY)')
10050 FORMAT(/5X,'UNIFORM ION-SPHERE PLASMA SCREENING POTENTIAL IN USE')
10060 FORMAT(/5X,'NON-UNIFORM ION-SPHERE PLASMA SCREENING POTENTIAL ',  &
     &       'IN USE WITH B-PARAMETER=',F6.2)
10070 FORMAT(/5X,'SELF-CONSISTENT KOHN-SHAM ION-SPHERE PLASMA ',        &
     &       'SCREENING POTENTIAL IN USE')
!
!-----------------------------------------------------------------------
!
10080 FORMAT(16X,I1,'-POLE PERTURBATION PARAMETERS:',8F10.5,            &
     &       /((48X,8F10.5)))
10090 FORMAT(//' MINIMIZATION RESULT OF VARIATIONAL PARAMETERS:',8F10.5,&
     &       /((47X,8F10.5)))
10100 FORMAT(' ***NOTE, SR.MINIM IS UNABLE TO ASSIGN ANY N-VALUES',     &
     &       ' FOR RYDBERG L=',I3,' LMAX TOO LARGE?')
10110 FORMAT(' N=',I4,5X,'L=',I3)
10120 FORMAT(25X,'NSW=',I3)
10130 FORMAT(35X,'NRAD=',I5)
10140 FORMAT(2X,'NV=',I5,2X,'LV=',I5,7X,'K',20I5)
10150 FORMAT(/'***SR.MINIM: STO SUBSHELL POTENTIAL LAMBDAS MUST BE',    &
     &       ' POSITIVE: SUBSHELL, LAMBDA=',I5,F10.4)
10160 FORMAT(/' MDEN=',I2,3X,'ION DENSITY=',1PE9.2,'CM-3',3X,           &
     &       'ELECTRON DENSITY=',1PE9.2,'CM-3',3X,'TEMPERATURE*K=',     &
     &       0PF7.2,'RYD',3X,'GAMMA=',0PF5.2,3X,'DEBYE=',F7.2,3X,'R0=', &
     &       F7.2/' **** ',5X,'*********** ',16X,'**************** ',   &
     &       16X,'************* ',13X,'***** ',8X,'***** ',10X,'**')
10170 FORMAT('SR.MINIM: MUST USE NAMELIST INPUT (SRADWIN,SRADCON) FOR ',&
     &       'CASE OF EXTERNAL ORBITALS WITH CONTINUUM ORBITALS')
10180 FORMAT(/'*** ERROR: BUNDLED AUGERS HAVE MOVED ABOVE THEIR OWN ',  &
     &      'CONTINUUM AND AS SUCH CANNOT BE LOWERED BY POST-PROCESSING'&
     &      /                                                           &
     &   '    EITHER RUN UNBUNDLED/NON-HYBRID (IF DISK SPACE ALLOWS) OR'&
     &   ,                                                              &
     &   ' "ADJUST" STRUCTURE TO REMOVE THE NEED TO LOWER THE CONTINUUM'&
     &   )
10190 FORMAT(/'*** WARNING: BUNDLED AUGERS AND RADIATIVE RATES',        &
     &       '    CANNOT BE ADJUSTED AT THE POST-PROCESSOR STAGE',      &
     &       '    TO TAKE ACCOUNT OF AS RAISING/LOWERING THE CONTINUUM'/&
     &       )
10200 FORMAT(A4)
10210 FORMAT(' Rydberg-l mis-alignment, likely the present LMIN=',i3,   &
     &       ' differs from that used to generate RESTART'/' Set LORIG',&
     &       ' equal to the RESTART LMIN, in NAMELIST DRR and re-run.')
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE MINIM
!
!                             *******************
!
      SUBROUTINE MINIM_ALLOC
!
!-----------------------------------------------------------------------
!
!  SR.MINIM_ALLOC ALLOCATES NEARLY ALL THE ARRAYS FOR USE BY SR.MINIM
!
!  IT IS CALLED BY:
!    SR.MINIM
!
!  IT CALLS:
!    SR.DIMUSE
!
!-----------------------------------------------------------------------
!
      USE COMMON_ALGEB,  ONLY: BFOT
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CACC,   ONLY: ACC
      USE COMMON_CADJ,   ONLY: DAJNEW,DF0,IEQUAL,ICOUNT
      USE COMMON_CADJ,   ONLY: DALAN,BALAN
      USE COMMON_CADJ,   ONLY: DEXTRE,DACCUR
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_COEFF,  ONLY: DRKP,QRLP,IRLP,NRKP,NADP
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DMQSS3, ONLY: DSS,MSS,QSS,NADR                         &
     &                        ,NL000=>NL,NL=>NL000
      USE COMMON_DXRL,   ONLY: DRK,QRL,IRL,NRK,NAD
      USE COMMON_INTS,   ONLY: DRL,DOSC,IXD09,IXD28,IXD29
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR,NTJ,NFJ
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
      USE COMMON_QTG,    ONLY: NFI,NFK,NFQ,NTG
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG,MXPIN
      USE COMMON_REL,    ONLY: DMASS,DCD,D2LL
      USE COMMON_RELINT, ONLY: DRLP1,DNL
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!      USE COMMON_TFU,    ONLY: TFU
!      USE COMMON_TRANLS, ONLY: NADRU,NAI,IEORD
      USE COMMON_WEIGHT, ONLY: WGHT,INDEXW
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL2, ONLY: MDEL,MXORBR,MPOL00,MPOL0,MPOLE,MPOLX,CODE
      USE COMMON_NRBAL4, ONLY: MBP1MX,MBP2MX,MEKVMX,KUTM1,MPOLM,QCUT
      USE COMMON_NRBCAS, ONLY: BCASC,AP,MADD
      USE COMMON_NRBCAV, ONLY: ECAVX,ECAV,AJUSTX,ICAV0=>ICAV
      USE COMMON_NRBDEL, ONLY: ISHFTLS,ISHFTIC,NOBS,NOBSJ,MDELE,MULTS   &
     &                        ,DELELS,DELEIC,DELECF,EFLG0,EFLGJ0        &
     &                        ,TOLB,TOLE,BDELE
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,VSC,XC1,XC2,NPITER
      USE COMMON_NRBDEN, ONLY: DENSI,DENS,TKAYS,NDEN
      USE COMMON_NRBDQE, ONLY: DQNL,MXQIN
      USE COMMON_NRBDR,  ONLY: IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR
      USE COMMON_NRBDR,  ONLY: LNEW,LCON,LSUM,LMAX,lcmin,BLOOP
!      USE COMMON_NRBDW,  ONLY: IDW,btop
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBEKP, ONLY: NED
      USE COMMON_NRBFSI, ONLY: BNRBFSI,DNLI,NLI
      USE COMMON_NRBGCF, ONLY: KGSL,KGCF,NKSL
      USE COMMON_NRBGRJ, ONLY: NSLJ,NGSLJ
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBINT, ONLY: DRLI,DYY,IYY,NRLI,MENG,NREL,NLAG,NLAGP   &
     &                        ,BLAG,BBC2
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,NASTJ
      USE COMMON_NRBLIM, ONLY: ECNTRB,ITANAL,BANAL
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,NAST
      USE COMMON_NRBMKP, ONLY: NMD1,NMD2
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBNF2, ONLY: DETA,DXSI,DZL,DXTWO
      USE COMMON_NRBNFI, ONLY: DZLI,DXTWOI,DETAI,FRI,GRI
      USE COMMON_NRBOLP, ONLY: OVLPGR,OVLPCF,IPAIR
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
      USE COMMON_NRBORN, ONLY: BL,OBO,TM2
      USE COMMON_NRBPOT, ONLY: DPOT,TOL,MEND
      USE COMMON_NRBPOT, ONLY: ZS0,ZS,JZNM
      USE COMMON_NRBPOT, ONLY: POT,JPOT1
      USE COMMON_NRBPOT, ONLY: POTHAM,MPSEUD
      USE COMMON_NRBPOT, ONLY: DERV,DERV1,DERV2
      USE COMMON_NRBPOT, ONLY: ZESP,IZESP,NWRM
      USE COMMON_NRBQED, ONLY: VPINT,SLFINT,QED
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBREL, ONLY: RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0
      USE COMMON_NRBREL, ONLY: DNUK0,DNUK1,DNUK2,DNUK,IXNUK
      USE COMMON_NRBRN1, ONLY: SBL,DBL                                  &
     &                        ,MB3,MB4,INDX,INDL,INDK
      USE COMMON_NRBRN2, ONLY: BINDB,MENGB
      USE COMMON_NRBSHF, ONLY: DSHIFT,MSHIFT,KSHIFT,MKMAX,MXEP
      USE COMMON_NRBSTO, ONLY: ALF,TEL,MSHELL,MCFSTO,MC,MCFMX,MEXPOT    &
     &                        ,NOCC,NLSTOE,BFIX,BSTO,MXSHLL
      USE COMMON_NRBTS1, ONLY: DFOT,DFOTm,DFOSS,NFOSS,IGAG,IXD24
      USE COMMON_NRBVAL, ONLY: FACT,IVAL,NNEW,NNOLD,BJUMP,BJUMP2,BRAD
      use common_nrbtmp, only: rnorm
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
! SET MAX ONE-BODY ORBITAL INTEGRALS
!
      IXD28=(MXORB*(MXORB+1))/2
      IXD29=IXD28+IXD28                                       !DOSC ONLY
!
! SET MAX BORN/RADIATION MULTIPOLE
!
      IXBLM=MAX(IONE,MPOLE/2)
      IXD09=IXBLM/2
      IF(BREL.and.irtard.gt.0)IXD09=IXD09+1                !+1 CASE BREL
!
!-----------------------------------------------------------------------
!
! SET SOME FLAGS
!
      BCONT=MODE.EQ.2.OR.MODE.EQ.3
      BDR=IDR.NE.0
      BORT=MORT.LT.0
      BPRNT0=JPRINT.NE.-3
!
!-----------------------------------------------------------------------
!
! RADIAL ORBITALS ETC. SET-UP
!
! EX-COMMON/RADF/
      ALLOCATE(DPNL(MAXRS,MXORB),DUY(IXD28),DX(MAXRS),DORIG(MXORB),     &
     &         STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR DPNL,DUY,DX,DORIG'
        NF=0
        GO TO 100
      ENDIF
!
! EX-COMMON/NRBDQE/
      ALLOCATE(DQNL(MAXRS,MXORB),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR DQNL'
        NF=0
        GO TO 100
      ENDIF
!
! EX-COMMON/NRBPOT/
      IF(BORT)THEN                         !>99.999% OF TIME WE ARE HERE
        IF(BCONT.OR.BDR)THEN
          IXPOT=2
        ELSE
          IXPOT=1
        ENDIF
      ELSE                     !SO JUST LIMIT ON PHYSICAL GROUNDS TO L=4
        IXPOT=5                     !AS LARGEST USER L CAN BE VERY LARGE
      ENDIF
!
      ALLOCATE(POT(MAXRS,IXPOT),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR POT'
        NF=0
        GO TO 100
      ENDIF
!
! EX-COMMON/COM1/
      MEND=0
      ALLOCATE(DPOT(MAXRS),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR DPOT'
        NF=0
        GO TO 100
      ENDIF
!
! EX-COMMON/NRBDEN/ (N.B. USED MORE GENERALLY)
      ALLOCATE(VSC(MAXRS),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR VSC'
        NF=0
        GO TO 100
      ENDIF
!
! EX-COMMON/NRBHAM/
      IF(MPSEUD.NE.0)THEN
        ALLOCATE(POTHAM(MAXRS),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR POTHAM'
          NF=0
          GO TO 100
        ENDIF
      ENDIF
!
! EX-COMMON/NRBFOT/
      IF(BFOT)THEN
        ALLOCATE(DERV(MAXRS),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR DERV'
          BFOT=.FALSE.
          NF=0
          GO TO 100
        ENDIF
      ENDIF
!
! EX-COMMON/NRBREL/
      IF(INUKE.GE.0)THEN
        ALLOCATE(DNUK0(IXNUK),DNUK1(IXNUK),DNUK2(IXNUK),DNUK(IXNUK),    &
     &           STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)                                                  &
     &              'MINIM: ALLOCATION FAILS FOR DNUK0,DNUK1,DNUK2,DNUK'
          NF=0
          GO TO 100
        ENDIF
      ENDIF
!
! EX-COMMON/NRBSPL/
      IF(BREL)THEN
        ALLOCATE(DERV1(MAXRS),DERV2(MAXRS),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR DERV1,DERV2'
          NF=0
          GO TO 100
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
! SLATER AND RK (1- & 2-BODY) INTGERAL SET-UP (ALWAYS)
!
! EX-COMMON/INTS/
      IF(.NOT.BPRNT0.AND..NOT.BFOT)IXD29=IXD28             !NO VELOCITY
      ALLOCATE(DRL(IRL),DOSC(IXD29,0:IXD09),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR DRL,DOSC'
        NF=0
        GO TO 100
      ENDIF
!
      DO I=0,IXD09
        DO J=1,IXD29
          DOSC(J,I)=DZERO
        ENDDO
      ENDDO
!
! EX-COMMON/CACC/
      IF(MPOLE.GT.0.AND.(BPRNT0.OR.BFOT))THEN
        ALLOCATE(ACC(IXD28),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR ACC'
          NF=0
          GO TO 100
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
! 1- BODY NON-FINE-STRUCTURE INTGERAL SET-UP (ALWAYS)
!
! EX-COMMON/REL/
      IF(.NOT.BREL)THEN
        ALLOCATE(DMASS(IXD28),DCD(IXD28),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR DMASS,DCD'
          NF=0
          GO TO 100
        ENDIF
      ENDIF
!
      IF(MBP1MX.GE.0)THEN
        ALLOCATE(D2LL(IXD28),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR D2LL'
          NF=0
          GO TO 100
        ENDIF
      ENDIF
!
! EX-COMMON/NRBQED/
!      if(qed.ne.QZERO)then  !may need to alloc/init for buggy compilers
      ALLOCATE(VPINT(MXORB),SLFINT(MXORB),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR VPINT,SLFINT'
        NF=0
        GO TO 100
      ENDIF
      VPINT=DZERO
      SLFINT=DZERO
!      endif
!
! EX-COMMON/NRBSHF/
      ALLOCATE(DSHIFT(MXORB),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR DSHIFT'
        NF=0
        GO TO 100
      ENDIF
!
!-----------------------------------------------------------------------
!
! OPTIONAL 1- AND 2-BODY FINE-STRUCTURE INTGERAL SET-UP
!
      IF(NJO.GT.0)THEN
!
! EX-COMMON/EX/
        ALLOCATE(DRLP1(IRLP),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR DRLP1'
          NF=0
          GO TO 100
        ENDIF
!
      ENDIF
!
      IAXMI=MAX(NL000,NL)
      IF(IAXMI.GT.0)THEN
!
! EX-COMMON/EX/
        ALLOCATE(DNL(IAXMI),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR DNL'
          NF=0
          GO TO 100
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! OPTIONAL BOUND-CONTINUUM 1-BODY INTGERAL SET-UP
!
!                *** N.B. IXD24 IS MAXIMAL ***
! AS IN THE BORN CASE, SHOULD MAKE A DUMMY RUN (THRU RK4PI) TO DETERMINE
! ACTUAL USAGE, WHICH WOULD MEAN ALLOCATING DFOSS THERE INSTEAD.
! ONE CAN ALSO SET-UP POINTERS TO THE NON-ZERO ELEMENTS, WHICH COULD BE
! GENERAL (E.G. AN ADJACENCY LIST) OR ATOMIC SPECIFIC (AS IN THE BORN
! CASE) THE LATTER BEING PREFERABLE SINCE IT SHOULD(!) USE LESS MEMORY.
! THIS MIGHT BENEFIT NFOSS ALLOCATION WHICH IS MAXIMAL ALSO (LIKE DOSC).
! ALL CAN RAPIDLY BECOME LARGE AND SPARSE FOR BASIS='RLX'.
!
!
      IF(BFOT)THEN
!
        IXD24=IXBLM*(MXORB-MB-LCON)*LCON                          !MXBLM
        LHM=MPOLE/4
        IF(BREL)LHM=LHM+1
         !.and.irtard.gt.0   !should be on, but unwise user can reset...
!
! EX-COMMON/NRBTS1/
        ALLOCATE(DFOT(MENG),DFOTm(MENG),DFOSS(IXD24,MENG,2),            &
     &           NFOSS(0:LHM,MXORB,MXORB),IGAG(0:MENG),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR DFOT,DFOSS,NFOSS'
          BFOT=.FALSE.
          NF=0
          GO TO 100
        ENDIF
!
        DO I=1,MXORB
          DO J=1,MXORB
            DO K=0,LHM
              NFOSS(K,J,I)=0        !PI INDEX
            ENDDO
          ENDDO
        ENDDO
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! OPTIONAL BOUND-CONTINUUM 2-BODY INTGERAL SET-UP
!
! EX-COMMON/NRBINT/
      ALLOCATE(IYY(MXORB))                           !USED GENERALLY NOW
!
      IF(BCONT)THEN
!
        IX=0
        DO I=1,IRL
          J=QRL(1,I)
          IF(QN(J).GE.90)IX=IX+1
        ENDDO
!
        IXFSL=MAX(IONE,IX)
        IF(IXFSL.GT.MXFSL)THEN
          IF(MXFSL.GT.0)WRITE(MW6,10020)IXFSL,MXFSL
        ENDIF
!
! EX-COMMON/NRBINT
        ALLOCATE(DRLI(MENG,IXFSL),NRLI(IRL),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR DRLI,NRLI'
          NF=0
          GO TO 100
        ENDIF
!
      ELSEIF(MODE.EQ.4)THEN
!
        ALLOCATE(NRLI(IRL),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR NRLI'
          NF=0
          GO TO 100
        ENDIF
!
      ENDIF
!
      IF(BCONT.OR.MODE.EQ.4)THEN
        DO I=1,IRL
          NRLI(I)=0
        ENDDO
      ENDIF
!
!-----------------------------------------------------------------------
!
! OPTIONAL BOUND-CONTINUUM 2-BODY FINE-STRUCTURE INTGERAL SET-UP
!
      BNRBFSI=NL000.GT.0.AND.BCONT                         !2FS B-C
      IF(BNRBFSI)THEN
!
        IX=0
        DO I=1,NL000
          DO K=1,3
            J=QSS(K,I)
            IF(QN(J).GE.90)THEN
              IX=IX+1
              GO TO 50
            ENDIF
          ENDDO
   50   ENDDO
!
        IXFSS=MAX(IONE,IX)
        IF(IXFSS.GT.MXFSS)THEN
          IF(MXFSS.GT.0)WRITE(MW6,10010)IXFSS,MXFSS
        ENDIF
!
! EX-COMMON/NRBFSI/
        ALLOCATE(DNLI(MENG,IXFSS),NLI(NL000),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR DNLI,NLI'
          NF=0
          GO TO 100
        ENDIF
!
        DO I=1,NL000
          NLI(I)=0
        ENDDO
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! OPTIONAL NON-FINE-STRUCTURE INTGERAL SET-UP
!
!      IRLO=1                                 !NO NEED TO ALLOC IF FALSE
      IF(KUTOO.NE.0)THEN
        IRLO=IRL                              !=MXRLO
!
! EX-COMMON/NRBNF2/
        ALLOCATE(DETA(IRLO),DZL(IRLO),DXTWO(IRLO),STAT=IERR1)
        IERR2=0
        IF(KUTOO.EQ.98)ALLOCATE(DXSI(IXD28),STAT=IERR2)
!
        IF(IERR1.NE.0.OR.IERR2.NE.0)THEN
          WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR DETA,DXSI,DZL,DXTWO'
          NF=0
          GO TO 100
        ENDIF
      ENDIF
!
! OPTIONAL BOUND-CONTINUUM 2-BODY NON-FINE-STRUCTURE INTGERAL SET-UP
!
!      IXFOO=1                                !NO NEED TO ALLOC IF FALSE
      IF(KUTOO.NE.0.AND.BCONT)THEN
        IXFOO=IXFSL                           !SAME AS LS
!
! EX-COMMON/NRBNFI/
        ALLOCATE(DZLI(MENG,IXFOO),DXTWOI(MENG,IXFOO),DETAI(MENG,IXFOO), &
     &           FRI(MAXRS),GRI(MAXRS),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR DZLI,DXTWOI,DETAI'
          NF=0
          GO TO 100
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
! OPTIONAL RELAXED ORBITAL OVERLAP SET-UP
!
      IF(IRLX.EQ.2)THEN
        IXD25=(MXORB*(MXORB-1))/2
        IXD26=(KMAX*(KMAX-1))/2
!
! EX-COMMON/NRBOLP/
        ALLOCATE(OVLPGR(IXD25),OVLPCF(IXD26),IPAIR(IXD26),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR OVLPGR,OVLPCF'
          NF=0
          GO TO 100
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
! OPTIONAL RELAXED CONFIGURATION AVERAGE ENERGY SET-UP
!
      IF(ICAV0.NE.0)THEN
!
! EX-COMMON/NRBCAV/
        ALLOCATE(ECAVX(KMAX),ECAV(KMAX),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR ECAVX,ECAV'
          NF=0
          GO TO 100
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      MAXRS=0              !WILL BE RE-SET IN RADIAL, BUT FLAG FOR MAXPS
!
!-----------------------------------------------------------------------
!
  100 RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT('SR.MINIM: ALLOCATION INCREASES NUMBER OF BOUND-CONTINUUM',&
     &       ' 2-BODY FINE-STRUCTURE INTEGRALS IXFSS =',I7,             &
     &       ' .GT. MXFSS=',I7/)
10020 FORMAT('SR.MINIM: ALLOCATION INCREASES NUMBER OF BOUND-CONTINUUM',&
     &       ' SLATER INTEGRALS IXFSL =',I7,' .GT. MXFSL=',I7/)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE MINIM_ALLOC
!
!                             *******************
!
      SUBROUTINE MINIM_DEALLOC
!
!-----------------------------------------------------------------------
!
!  SR.MINIM_DEALLOC DEALLOCATES ALL ARRAYS STILL OPEN AT THE COMPLETION
!  OF SR.MINIM
!
!  IT IS CALLED BY:
!    SR.MINIM
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CACC,   ONLY: ACC
      USE COMMON_CADJ,   ONLY: DAJNEW,DF0,IEQUAL,ICOUNT
      USE COMMON_CADJ,   ONLY: DALAN,BALAN
      USE COMMON_CADJ,   ONLY: DEXTRE,DACCUR
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_COEFF,  ONLY: DRKP,QRLP,IRLP,NRKP,NADP
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DMQSS3, ONLY: DSS,MSS,QSS,NADR
      USE COMMON_DXRL,   ONLY: DRK,QRL,IRL,NRK,NAD
      USE COMMON_INTS,   ONLY: DRL,DOSC
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR,NTJ,NFJ
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
      USE COMMON_QTG,    ONLY: NFI,NFK,NFQ,NTG
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG,MXPIN
      USE COMMON_REL,    ONLY: DMASS,DCD,D2LL
      USE COMMON_RELINT, ONLY: DRLP1,DNL
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
      USE COMMON_WEIGHT, ONLY: WGHT,INDEXW
!
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBCAS, ONLY: BCASC,AP,MADD
      USE COMMON_NRBCAV, ONLY: ECAVX,ECAV,AJUSTX,ICAV0=>ICAV
      USE COMMON_NRBDEL, ONLY: ISHFTLS,ISHFTIC,NOBS,NOBSJ,MDELE,MULTS   &
     &                        ,DELELS,DELEIC,DELECF,EFLG0,EFLGJ0        &
     &                        ,TOLB,TOLE,BDELE
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,VSC,XC1,XC2,NPITER
      USE COMMON_NRBDEN, ONLY: DENSI,DENS,TKAYS,NDEN
      USE COMMON_NRBDQE, ONLY: DQNL,MXQIN
      USE COMMON_NRBDR,  ONLY: IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR
!      USE COMMON_NRBDW,  ONLY: IDW,btop
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBEKP, ONLY: NED
      USE COMMON_NRBFSI, ONLY: BNRBFSI,DNLI,NLI
      USE COMMON_NRBGCF, ONLY: KGSL,KGCF,NKSL
      USE COMMON_NRBGRJ, ONLY: NSLJ,NGSLJ
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBINT, ONLY: DRLI,DYY,IYY,NRLI,MENG,NREL,NLAG,NLAGP   &
     &                        ,BLAG,BBC2
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,NASTJ
      USE COMMON_NRBLIM, ONLY: ECNTRB,ITANAL,BANAL
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,NAST
      USE COMMON_NRBMKP, ONLY: NMD1,NMD2
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBNF2, ONLY: DETA,DXSI,DZL,DXTWO
      USE COMMON_NRBNFI, ONLY: DZLI,DXTWOI,DETAI,FRI,GRI
      USE COMMON_NRBOLP, ONLY: OVLPGR,OVLPCF,IPAIR
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
      USE COMMON_NRBORN, ONLY: BL,OBO,TM2
      USE COMMON_NRBPOT, ONLY: DPOT,TOL,MEND
      USE COMMON_NRBPOT, ONLY: ZS0,ZS,JZNM
      USE COMMON_NRBPOT, ONLY: POT,JPOT1
      USE COMMON_NRBPOT, ONLY: POTHAM,MPSEUD
      USE COMMON_NRBPOT, ONLY: DERV,DERV1,DERV2
      USE COMMON_NRBPOT, ONLY: ZESP,IZESP,NWRM
      USE COMMON_NRBQED, ONLY: VPINT,SLFINT,QED
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBREL, ONLY: RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0
      USE COMMON_NRBREL, ONLY: DNUK0,DNUK1,DNUK2,DNUK,IXNUK
      USE COMMON_NRBRN1, ONLY: SBL,DBL                                  &
     &                        ,MB3,MB4,INDX,INDL,INDK
      USE COMMON_NRBRN2, ONLY: BINDB,MENGB
      USE COMMON_NRBSHF, ONLY: DSHIFT,MSHIFT,KSHIFT,MKMAX,MXEP
      USE COMMON_NRBSTO, ONLY: ALF,TEL,MSHELL,MCFSTO,MC,MCFMX,MEXPOT    &
     &                        ,NOCC,NLSTOE,BFIX,BSTO,MXSHLL
      USE COMMON_NRBTS1, ONLY: DFOT,DFOTm,DFOSS,NFOSS,IGAG,IXD24
      USE COMMON_NRBVAL, ONLY: FACT,IVAL,NNEW,NNOLD,BJUMP,BJUMP2,BRAD
      use common_nrbtmp, only: rnorm
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
! "LOCAL" DE-ALLOCATES
!
! EX-COMMON/CACC/
      IF(ALLOCATED(ACC))THEN
        DEALLOCATE(ACC,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR ACC'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/COM1/
      IF(ALLOCATED(DPOT))THEN
        DEALLOCATE(DPOT,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR DPOT'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/EX/
!
      IF(ALLOCATED(DNL))THEN
        DEALLOCATE(DNL,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR DNL'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(DRLP1))THEN
        DEALLOCATE(DRLP1,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR DRLP1'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/INTS/
      IF(ALLOCATED(DRL))THEN
        DEALLOCATE(DRL,DOSC,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR DRL,DOSC'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/RADF/
      IF(ALLOCATED(DPNL))THEN
        DEALLOCATE(DPNL,DUY,DX,DORIG,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR DPNL,DUY,DX,DORIG'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/REL/
      IF(ALLOCATED(DMASS))THEN
        DEALLOCATE(DMASS,DCD,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR DMASS,DCD'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(D2LL))THEN
        DEALLOCATE(D2LL,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR D2LL'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBCAV/
      IF(ALLOCATED(ECAVX))THEN
        DEALLOCATE(ECAVX,ECAV,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR ECAVX,ECAV'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBDEN/
      IF(ALLOCATED(VSC))THEN
        DEALLOCATE(VSC,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR VSC'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBPLS/
      IF(ALLOCATED(TKAYS))THEN
        DEALLOCATE(DENSI,DENS,TKAYS,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR DENSI,DENS,TKAYS'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBDQE/
      IF(ALLOCATED(DQNL))THEN
        DEALLOCATE(DQNL,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR DQNL'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBFOT/
      IF(ALLOCATED(DERV))THEN
        DEALLOCATE(DERV,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR DERV'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBFSI/
      IF(ALLOCATED(DNLI))THEN
        DEALLOCATE(DNLI,NLI,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR DNLI,NLI'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBHAM/
      IF(ALLOCATED(POTHAM))THEN
        DEALLOCATE(POTHAM,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR POTHAM'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBINT/
!
      IF(ALLOCATED(DRLI))THEN
        DEALLOCATE(DRLI,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR DRLI'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(NRLI))THEN
        DEALLOCATE(NRLI,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR NRLI'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(IYY))THEN
        DEALLOCATE(IYY,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR IYY'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(DYY))THEN
        DEALLOCATE(DYY,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR DYY'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(KUTOO.NE.0)THEN
!
! EX-COMMON/NRBNFI/
        IF(ALLOCATED(DZLI))THEN
          DEALLOCATE(DZLI,DXTWOI,DETAI,FRI,GRI,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)                                                &
     &                'MINIM: DE-ALLOCATION FAILS FOR DZLI,DXTWOI,DETAI'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/NRBNF2/
        IERR1=0
        IERR2=0
        IF(ALLOCATED(DETA))DEALLOCATE(DETA,DZL,DXTWO,STAT=IERR1)
        IF(ALLOCATED(DXSI))DEALLOCATE(DXSI,STAT=IERR2)
!
        IF(IERR1.NE.0.OR.IERR2.NE.0)THEN
          WRITE(MW0,*)                                                  &
     &              'MINIM: DE-ALLOCATION FAILS FOR DETA,DXSI,DZL,DXTWO'
          IF(NF.GT.0)NF=0
        ENDIF
!
      ENDIF
!
! EX-COMMON/NRBOLP/
      IF(ALLOCATED(OVLPGR))THEN
        DEALLOCATE(OVLPGR,OVLPCF,IPAIR,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR OVLPGR,OVLPCF'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBPOT/
      IF(ALLOCATED(POT))THEN
        DEALLOCATE(POT,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR POT'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBQED/
      IF(ALLOCATED(VPINT))THEN
        DEALLOCATE(VPINT,SLFINT,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR VPINT,SLFINT'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBREL/
      IF(ALLOCATED(DNUK0))THEN
        DEALLOCATE(DNUK0,DNUK1,DNUK2,DNUK,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)                                                  &
     &           'MINIM: DE-ALLOCATION FAILS FOR DNUK0,DNUK1,DNUK2,DNUK'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBSHF/
      IF(ALLOCATED(DSHIFT))THEN
        DEALLOCATE(DSHIFT,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR DSHIFT'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBSPL/
      IF(ALLOCATED(DERV1))THEN
        DEALLOCATE(DERV1,DERV2,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR DERV1,DERV2'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBTS1/
      IF(ALLOCATED(DFOT))THEN
        DEALLOCATE(DFOT,DFOTm,DFOSS,NFOSS,IGAG,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR DFOT,DFOSS,NFOSS'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
! "NON-LOCAL" DE-ALLOCATES
!
! EX-COMMON/CCLSH/
      IF(ALLOCATED(NNL))THEN
        DEALLOCATE(NNL,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR NNL'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/DBD2/..
      IF(ALLOCATED(QCP))THEN
        DEALLOCATE(QCP,QCG,QL,QN,STAT=IERR)  !,DEY
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR QCP,QCG,QL,QN'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(DEY))THEN
        DEALLOCATE(DEY,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR DEY'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/MQVC/
      IF(ALLOCATED(NEL))THEN
        DEALLOCATE(NEL,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR NEL'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBORB/
      IF(ALLOCATED(IEQ))THEN
        DEALLOCATE(IEQ,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'SR.MINIM: ALLOCATION FAILS FOR IEQ'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/CADJ/,/GENINF/ ETC.
      IF(ALLOCATED(DAJNEW))THEN
        DEALLOCATE(DADJUS,DAJNEW,IEQUAL,DEXTRE,DACCUR,JEND,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)                                                  &
     &               'MINIM: DE-ALLOCATION FAILS FOR DADJUS,DAJNEW ETC.'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(SCREEN))THEN                 !AS ALLOCATED SEPARATELY
        DEALLOCATE(SCREEN,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR SCREEN'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/CALAN/
      IF(ALLOCATED(DALAN))THEN
        DEALLOCATE(DALAN,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR DALAN'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/DXRL/
      IF(ALLOCATED(DRK))THEN
        DEALLOCATE(DRK,QRL,NRK,NAD,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR DRK,QRL,NRK,NAD'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/WEIGHT/
      IF(ALLOCATED(INDEXW))THEN
        DEALLOCATE(INDEXW,WGHT,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR INDEXW,WGHT'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBAL1/
      IF(ALLOCATED(MSTAT))THEN
        DEALLOCATE(MSTAT,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR MSTAT'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBDR/
      IF(ALLOCATED(NDR))THEN
        DEALLOCATE(NDR,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR NDR'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBORN/
      IF(ALLOCATED(BL))THEN
        DEALLOCATE(BL,OBO,TM2,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR BORN'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBRN1/
      IF(ALLOCATED(SBL))THEN
        DEALLOCATE(SBL,MB3,MB4,INDX,INDL,INDK,STAT=IERR)      !,DBL
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR BORN1'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBRN2/
      IF(ALLOCATED(BINDB))THEN
        DEALLOCATE(BINDB,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR BINDB'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBORB/
      IF(ALLOCATED(ICFGP))THEN
        DEALLOCATE(ICFGP,IGRCF,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'SR.MINIM: DE-ALLOCATION FAILS FOR ICFGP,IGRCF'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBSTO/
      IF(ALLOCATED(ALF))THEN
        DEALLOCATE(ALF,TEL,MC,MCFSTO,BFIX,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR STO'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBVAL/
      IF(ALLOCATED(IVAL))THEN
        DEALLOCATE(IVAL,FACT,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR IVAL,FACT'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! EX-COMMON/NRBZSP/
      IF(ALLOCATED(ZESP))THEN
        DEALLOCATE(ZESP,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR ZESP'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
! ex-common/nrbtmp/
      if(allocated(rnorm))then
        deallocate(rnorm,stat=ierr)
        if(ierr.ne.0)then
          write(mw0,*)'minim: de-allocation fails for rnorm'
          if(nf.gt.0)nf=0
        endif
      endif
!
      IF(BDELE)THEN                           !CURRENTLY, ALL OR NOTHING
!
! ex-common/nrbdel/
        if(allocated(delecf))then
          deallocate(delecf,stat=ierr)
          if(ierr.ne.0)then
            write(mw0,*)'minim: de-allocation fails for delecf'
            if(nf.gt.0)nf=0
          endif
        endif
!
! EX-COMMON/NRBDEL/
        IF(ALLOCATED(DELELS))THEN
          DEALLOCATE(DELELS,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR DELELS'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/NRBDEL/
        IF(ALLOCATED(DELEIC))THEN
          DEALLOCATE(DELEIC,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR DELEIC'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
      ENDIF
!
      IF(NSL0.GT.0)THEN                              !NOT CA
!
! EX-COMMON/QTG/
        IF(ALLOCATED(NFI))THEN
          DEALLOCATE(NFI,NFK,NFQ,NTG,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)                                                &
     &                 'MINIM: DE-ALLOCATION FAILS FOR  NFI,NFK,NFQ,NTG'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/TERMS/
        IF(ALLOCATED(NSL))THEN
          DEALLOCATE(NSL,QSI,QLI,QPI,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR NSL,QSI,QLI,QPI'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/NRBDWM/
        IF(ALLOCATED(NMETAG))THEN
          DEALLOCATE(NMETAG,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR NMETAG'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/NRBEKP/
        IF(ALLOCATED(NED))THEN
          DEALLOCATE(NED,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR NED'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/NRBGRP/
        IF(ALLOCATED(NGRPI))THEN
          DEALLOCATE(NGRPI,NADG,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR NGRPI,NADG'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/NRBLIM/
        IF(ALLOCATED(BANAL))THEN
          DEALLOCATE(BANAL,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR BANAL'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/NRBLS/
        IF(ALLOCATED(LSPI))THEN
          DEALLOCATE(LSPI,NLSPI,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR LSPI,NLSPI'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/NRBMKP/
        IF(ALLOCATED(NMD1))THEN
          DEALLOCATE(NMD1,NMD2,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR NMD1,NMD2'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/NRBNF1/
        IF(ALLOCATED(DEK))THEN
          DEALLOCATE(DEK,BFALL,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR  DEK, BFALL'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
      ENDIF
!
      IF(NJO.GT.0)THEN
!
! EX-COMMON/COEFF/
        IF(ALLOCATED(DRKP))THEN
          DEALLOCATE(DRKP,QRLP,NRKP,NADP,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)                                                &
     &             'MINIM: DE-ALLOCATION FAILS FOR  DRKP,QRLP,NRKP,NADP'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/DMQSS3/
        IF(ALLOCATED(DSS))THEN
          DEALLOCATE(DSS,MSS,QSS,NADR,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)                                                &
     &                'MINIM: DE-ALLOCATION FAILS FOR  DSS,MSS,QSS,NADR'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/JSPOR/
        IF(ALLOCATED(NRR))THEN
          DEALLOCATE(NRR,NT,JN,NGR,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)                                                &
     &                'MINIM: DE-ALLOCATION FAILS FOR NJO,NRR,NT,JN,NGR'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/QTG/
        IF(ALLOCATED(NTJ))THEN
          DEALLOCATE(NTJ,NFJ,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR NTJ,NFJ'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/NRBDWM/
        IF(ALLOCATED(NMETGJ))THEN
          DEALLOCATE(NMETGJ,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR NMETGJ'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/NRBGRJ/
        IF(ALLOCATED(NSLJ))THEN
          DEALLOCATE(NSLJ,NGSLJ,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR NSL0,NGSLJ'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
! EX-COMMON/NRBJ/
        IF(ALLOCATED(JPI))THEN
          DEALLOCATE(JPI,NJPI,STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'MINIM: DE-ALLOCATION FAILS FOR JPI,NJPI'
            IF(NF.GT.0)NF=0
          ENDIF
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE MINIM_DEALLOC
!
!                             *******************
!
      SUBROUTINE MINIM0(MPRNT0,NLAM0,NVAR0,IMXIT,TVARY0,ICM,ICP)
!
!-----------------------------------------------------------------------
!
!  SR.MINIM0 READS USER INPUT FOR THE ANAYLTIC BRANCH,
!  PERFORMS CHECKS ON IT AND INITIALIZES A RUN
!
!  IT IS CALLED BY:
!    SR.MINIM
!
!  IT CALLS:
!    SR.DIMUSE
!    SR.FACHXS
!    SR.RE_ALLOC2
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam                            !par
!
      USE COMMON_ALGEB,  ONLY: BFOT
      USE COMMON_ALGEB,  ONLY: KUTDSK
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CADJ,   ONLY: DAJNEW,DF0,IEQUAL,ICOUNT
      USE COMMON_CADJ,   ONLY: DALAN,BALAN
      USE COMMON_CADJ,   ONLY: DEXTRE,DACCUR
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS,MJH0
      USE COMMON_CMESH,  ONLY: MHF,MRAD,MSTEP,IXTRA,xmax
      USE COMMON_CMESH,  ONLY: IFLAGV
      USE COMMON_CMESH,  ONLY: TINORB,RZERO,MXBOX
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DMQSS3, ONLY: NL000=>NL,NL=>NL000
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_GENINF, ONLY: SCALER
      USE COMMON_INTS,   ONLY: IGAUGE
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR
      USE COMMON_MINIM,  ONLY: MPNCH,KUTCAS,BPRINT
      USE COMMON_MINIM,  ONLY: ECOR1,ECOR2,ECORR,ECORRJ,ESKPL,ESKPH     &
     &                        ,BECOR
      USE COMMON_MINIM,  ONLY: CMXLSA,CMXLSR,CMXICA,CMXICR,STOLB,XMIX   &
     &                        ,bnobv
      USE COMMON_MINIM,  ONLY: TOLTCC,KTCC,MTCC,NTCC,NENERG
      USE COMMON_MINIM,  ONLY: EIONPOT,EIMXLS,EIMXIC                    &
     &                        ,WLG1,WLG2,IWGHT,IWGHT0,IOPTIM            &
     &                        ,JUPMX,JUPMN,JLOWMX,JLOWMN                &
     &                        ,LUPMX,LUPMN,LLOWMX,LLOWMN                &
     &                        ,NMETAR,NMETARJ,NMETAP,NMETAPJ,NRSLMX
      USE COMMON_MISC,   ONLY: BEIVEC,IDIAG,LDIAG
      USE COMMON_MISC,   ONLY: NF0,BNAME
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
      USE COMMON_QTG,    ONLY: NTT,NFI,NFK,NFQ
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
      USE COMMON_WEIGHT, ONLY: WGHT,INDEXW
!
      use common_misc,   only: ione1,ione0
      use common_misc,   only: badas
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP0=>MGRP,JRAD,KORT
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL1, ONLY: ISCALR
      USE COMMON_NRBAL2, ONLY: MDEL,MXORBR,MPOL00,MPOL0,MPOLE,MPOLX,CODE
      USE COMMON_NRBAL2, ONLY: MAXLAM0,MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBAL3, ONLY: MCFSS,KCFSS,KUTSS,KUTSO,QQCUT
      USE COMMON_NRBCAV, ONLY: ECAVX,ECAV,AJUSTX,ICAV
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,XBEE,VSC,XC1,XC2,NPITER
      USE COMMON_NRBDEN, ONLY: DENSI,DENS,TKAYS,NDEN
      USE COMMON_NRBDEL, ONLY: ISHFTLS,ISHFTIC,NOBS,NOBSJ,MDELE,MULTS   &
     &                        ,DELELS,DELEIC,DELECF,EFLG0,EFLGJ0        &
     &                        ,TOLB,TOLE,BDELE
      USE COMMON_NRBDQE, ONLY: BHFF
      USE COMMON_NRBDR,  ONLY: IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR
      USE COMMON_NRBDR,  ONLY: LNEW,LCON,LSUM,LMAX,lcmin,BLOOP
      USE COMMON_NRBDW,  ONLY: IDW,btop
      USE COMMON_NRBDWP, ONLY: DLAMX,DLAMDX,DLAMQX,MCFSTOX,NOCCX
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,NASTJ                           &
     &                        ,MINJT,MAXJT,NEIGENJ
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,NAST                          &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBLIM, ONLY: ECNTRB,ITANAL,BANAL
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX                     &
     &                        ,MXBORB,MXVORB,MXFORB,NGRP
      USE COMMON_NRBPOT, ONLY: ZESP,IZESP,NWRM
      USE COMMON_NRBPOT, ONLY: POTHAM,MPSEUD
      USE COMMON_NRBPOT, ONLY: ALFD,RCUT,ALAV,RCAV,IPOLFN
      USE COMMON_NRBQED, ONLY: VPINT,SLFINT,QED
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBREL, ONLY: RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0
      USE COMMON_NRBSTO, ONLY: ALF,TEL,MSHELL,MCFSTO,MC,MCFMX,MEXPOT    &
     &                        ,NOCC,IOCC,NLSTOE,BFIX,BSTO,MXSHLL,NGAPSTO&
     &                        ,MEXPOT0,ISTATIC,faca,facsp,fac_csi,faclam&
     &                        ,ifacy
      USE COMMON_NRBTS1, ONLY: PMIN,IPIG
      USE COMMON_NRBVAL, ONLY: FACT,IVAL,NNEW,NNOLD,BJUMP,BJUMP2,BRAD
      use common_nrbtmp, only: rnorm
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (D1PT5M7=D1PT5*D1M7)
!
      PARAMETER (DCON0=1.625_WP)                !FOR INITIAL STEP
      PARAMETER (DELW=D1M5)                  !FOR ROUND-OFF IN OCCUP NOS
      PARAMETER (TOLW=D1M3)    !TOLERANCE FOR MATCHING OCCUPATION NOS WK
!
      PARAMETER (TINORB0=D1M3)                 !R-MATRIX RZERO CRITERION
!
      PARAMETER (DCON2=1.5789E+5_WP)            !DONE/T_BOLTZ
      PARAMETER (DCON3=5.29177E-9_WP)           !=A0_BOHR
      PARAMETER (DCON4=3.224_WP)                !(32*XPI/DTHREE)**D1THRD
      PARAMETER (DCON5=25.1327_WP)              !=8*XPI
      PARAMETER (DCON6=0.2387_WP)               !=DTHREE/(DFOUR*XPI)
!
      CHARACTER(LEN=1) PPP
      CHARACTER(LEN=2) PIS
      CHARACTER(LEN=3) RAD,RADOUT,POTOUT,POTL,ORTHOG,STONLZ,MIXBV
      CHARACTER(LEN=4) POTIN,FAC                     !,MYRGE
      CHARACTER(LEN=5) PPOT
      CHARACTER(LEN=6) DDIAG,PRINT,TCC
      real(wp) maxe                                  !for gfortran "bug"
!
      LOGICAL BEX                         !INQUIRE REQUIRES DEFAULT KIND
!
      ALLOCATABLE :: DBUF(:),IBUF(:)
      ALLOCATABLE :: DUM(:),IDUM(:)
!
      DIMENSION DUM2(2)
!
      NAMELIST/SMINIM/                                                  &
     & AJUSTX,ALAV,ALFD,ATM,badas,                                      &
     & BALAN,BEIVEC,                                                    &
     & CMXLSA,CMXLSR,CMXICA,CMXICR,                                     &
     & DDIAG,DEFLAM,DHNS0,DLAMX,DLAMDX,DLAMQX,                          &
     & ECNTRB,ECORR,ECORRJ,EIMXLS,EIMXIC,EIONPOT,ESKPL,ESKPH,           &
     & FAC,FAC_AHX,FAC_HXS,FAC_IHX,FAC_HX0,FAC_HX1,fac_csi,faca,facsp,  &
     & ibreit,IBWRM,ICAV,IDIAG,IFIX,IFLAGV,ifacy,                       &
     & IGAGR,IGAUGE,IMAXIT,INCLUD,INUKE,IOPTIM,IORT,IPOLFN,IREL,irtard, &
     & ISHFTLS,ISHFTIC,ISTATIC,ITANAL,ITOL,IWGHT,IXTRA,IZESP,           &
     & JPRINT,JRAD,JLOWMN,JLOWMX,JUPMN,JUPMX,                           &
     & KCUT,KORT,KTCC,KUTCA,KUTCAS,KUTDSK,KUTLS,                        &
     & LDIAG,LLOWMN,LLOWMX,LUPMN,LUPMX,                                 &
     & M,MAXE,MAXLAM,MCFMX,MCFSTOX,MDELE,MDEN,MEXPOT,MEXTRE,MGRP,MHF,   &
     & MIXBV,MPNCH,MPRINT,MPSEUD,MRAD,MRED,MSTEP,MULTS,                 &
     & NDEN,NGAPSTO,NEIGEN,NEIGENJ,NFIX,NLAM,NLAMD,NLAMQ,NMETAP,NMETAPJ,&
     & NMETAR,NMETARJ,NOCC,NOCCX,NPE,NPITER,NRSLMX,NVAR,NVARD,NVARQ,    &
     & NZION,                                                           &
     & ORTHOG,                                                          &
     & POTIN,POTL,POTOUT,PPOT,PRINT,                                    &
     & QED                                                   !ANSI LIMIT
      NAMELIST/SMINIM/                                                  &
     & RAD,RADOUT,RCAV,RCUT,RMIN1,RMIN2,RNUKE,RZERO,                    &
     & SCALER,SKIN,STOLB,STONLZ,                                        &
     & TCC,TINORB,TK0,TOLB,TOLE,TOLTCC,TVARY,                           &
     & WLG1,WLG2,                                                       &
     & XBEE,xmax,XMIX
!
!-----------------------------------------------------------------------
!
      IXSHLL=MAX(MXORB,MXSHLL)                 !ALLOW FOR BNLSUB=.T./.F.
      IXPOT=5                   !ZESP (NUCLEAR SCREENING)
!
! ALLOCATES FOR INITIALIZATION BY SR.MINIM0
!
! EX-COMMON/GENINIF/            JEND(:),DADJUS(:) ALLOC AFTER USER INPUT
      ALLOCATE(SCREEN(MXORB),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR SCREEN'
        NF=0
        GO TO 900
      ENDIF
!
! EX-COMMON/NRBSTO/
      ALLOCATE(ALF(MXORB),TEL(IXSHLL),MC(IXSHLL),MCFSTO(MXORB),         &
     &         BFIX(MXORB),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'MINIM0: ALLOCATION FAILS FOR STO'
        NF=0
        GO TO 900
      ENDIF
!
! EX-COMMON/NRBVAL/
      ALLOCATE(IVAL(MXORB),FACT(MXORB),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR IVAL,FACT'
        NF=0
        GO TO 900
      ENDIF
!
! EX-COMMON/NRBZSP/
      ALLOCATE(ZESP(IXPOT),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR ZESP'
        NF=0
        GO TO 900
      ENDIF
!
! ex-common/nrbtmp/
      allocate(rnorm(mxorb),stat=ierr)
      if(ierr.ne.0)then
        write(mw0,*)'minim0: allocation fails for rnorm'
        nf=0
        go to 900
      endif
!
!-----------------------------------------------------------------------
!
      KCUT0=KCUT                  !HOLD ALGEB KCUT
      PI=ACOS(-DONE)
!
      WRITE(MW6,10210)
!
! TERMS
      NTRMS=0
      DO N=1,NSL0
        NTRMS=NTRMS+NSL(N)
      ENDDO
      IF(NTRMS.NE.NTT)THEN
        WRITE(MW6,*)'NTRMS, NTT=',NTRMS,NTT
        STOP 'MINIM0: TERMS CHECKSUM 1 ERROR'
      ENDIF
      IF(NTRMS.NE.IAXTM)THEN
        WRITE(MW6,*)'NTRMS, IAXTM=',NTRMS,IAXTM
        STOP 'MINIM0: TERMS CHECKSUM 2 ERROR'
      ENDIF
!
! CA
      IF(NTRMS.EQ.0)NTRMS=KMAX
!
! LEVELS
      NLVLS=0
      DO N=1,NJO
        NLVLS=NLVLS+NT(N)
      ENDDO
      IF(NLVLS.NE.IAXLV)THEN
        WRITE(MW6,*)'NLVLS, IAXLV=',NLVLS,IAXLV
        STOP 'MINIM0: LEVELS CHECKSUM ERROR'
      ENDIF
!
! SOME INITIALIZATIONS.
!
      BDR=IDR.NE.0                !'DR' LOOPING OVER DUMMY RYDBERG
      MAUTO=0                     !CONTROLS ACCESS TO RADWIN/RADCON
      MXBOX=-1                    !BOX ORBITAL POINTS (INTERNAL)
      LDIAG=1                     !USES LAPACK DSYEVD
!
      MB0=MB
!p      IF(IEQ(0).LT.0)MXBORB=-IEQ(0)         !FOR NON-UNIQUE BASIS
      IF(IEQ(0).GT.0)THEN                   !UNPACK
        IF(IRLX.LT.0)MB0=0                  !IRLX.LT.0 MEANS IEQ(0).GT.0
!p        ID=IEQ(0)-MXORB
!p        NGRP=ID/100000
!p        ID=ID-100000*NGRP
!p        MXFORB=ID/10000
!p        ID=ID-10000*MXFORB
!p        MXVORB=ID/1000
!p        ID=ID-1000*MXVORB
!p        MXBORB=ID
!pc       write(mw0,*)'pack:',ngrp,mxborb,mxvorb,mxforb
      ENDIF
!
! SET-UP ORBITAL INFO, SCALING PARAMETERS ETC.
! TYPE OF ORBITAL I FLAGGED BY USER VIA QN(I), CONVERT TO INTERNAL
! SCREEN(I) FLAG.
!
      IV=0                        !INITIALIZE NO. OF RYDBERG ORBS
      NGROUP=0                    !HIGHEST NL-SUBSHELL INDEX OCCUPPIED
      NPARAM=0                    !HIGHEST L ORBITAL INDEX
      MION=NW+NF                  !TOTAL NUMBER OF ELECTRONS
      IPIG=1                      !IN CASE RADCON NOT CALLED
      NWRM=NW
      MAXN=0
      ICC=0
      IXTRA=-1
      iswch=0
      bnobv=.true.                !switch-off bound-Rydberg interaction
!
      IF(BDR)THEN
        IF(BLOOP)THEN
          LVP=LNEW
        ELSE
          LVP=0
        ENDIF
      ELSE
        LVP=-1
      ENDIF
!
      IF(IDW.NE.0)THEN
        MCFSTOX=0
        NOCCX=0
        DLAMX=DZERO               !DIRECT INPUT OF CONTINUUM LAMBDA
        DLAMDX=DONE
        DLAMQX=DONE
      ENDIF
!
      DO I=1,MXORB
        IVAL(I)=0                 !DUMMY RYDBERG ORBITAL FLAG
        FACT(I)=DONE
        MCFSTO(I)=0               !STO CF NOS.
        TEL(I)=DZERO              !POTL OCCUPATION NOS
!        DORIG(I)=DONE             !TEST
        rnorm(i)=done
!
        IF(DEY(I).NE.DZERO)THEN   !ORBITAL EXISTS IN A CONFIG
          NGROUP=I
          IF(QL(I).GT.NPARAM)NPARAM=QL(I)
!
          IF(QN(I).LT.70)THEN     !N=1-69, NORMAL INTERNAL BOUND ORBITAL
            NE=QN(I)
            MAXN=MAX(MAXN,NE)
            NE=(NE-1)*NE*(2*NE-1)
            NE=NE/3
            L=QL(I)/2
            LVP=MAX(LVP,L)
            NE=NE+QL(I)+1+L*QL(I)
            IF(NE.GE.MION)NE=MION-1
            SCREEN(I)=NE
          ELSEIF(QN(I).LT.80)THEN !N=70-79: RADWIN EXTERNAL ORBITAL
            SCREEN(I)=3999
          ELSEIF(QN(I).LT.90)THEN !N=80-89: DUMMY RYDBERG ORBITAL
            iswch=1
            IVAL(I)=1
            IV=IV+1
            SCREEN(I)=MION-1
          ELSE                    !N=90-99: CONTINUUM ORBITAL
            iswch=1
            ICC=ICC+1
!            IVAL(I)=0
!            IV=IV-1
            SCREEN(I)=9999
          ENDIF
        ELSE
          SCREEN(I)=DZERO
        ENDIF
      ENDDO
!
      NPARAM=NPARAM/2+1         !MAX NO L-DEPENDENT SCALING PARAMETERS
!
      IF(BDR)THEN
        NSW0=LVP*LVP
        NSW0=NSW0/4
        NSW0=NSW0+NS0
        IF(NSW0.GT.NSX)NSW0=NSX
        IF(NSW.LT.NSW0)NSW=NSW0
      ENDIF
!
      BSCALR=.FALSE.
      IF(ISCALR.GT.0)NGROUP=MAX(NGROUP,ISCALR)   !FOR OPT SLATER SCALING
!
!     ISCALR must be set in algeb to reserve an "orbital" location if
!     optimizing SCALER, should normally be target mxorb+1. To avoid
!     conflict with idw.ne.0 use of mxorb+1, optimization of slater
!     parameter is switched-off there. (shouldn't be optimizing target
!     in a dw run anyway.) any scaler input is then used "as-is", e.g.
!     as previously optimized in target structure run.
!
!
! NOW INITIALIZE NAMELIST VARIABLES
!
!
! THESE MAYBE RE-SET BY USER INPUT, BUT ARE NOT IN NAMELIST THEMSELVES
!
      NLSTOE=-18               !STO NL SCREEN BEYOND AR-LIKE -SEE STONLZ
      ITOL0=7          !DEFAULT ACC OF ORBITALS DEL(E)/E.LT.10**(-ITOL0)
      MORT=1                   !ORTHOG SWITCH, RESET BY USER IORT
!
! MOST FREQUENTLY USED INPUTS
!
      NZION=0                  !NUCLEAR CHARGE (<0 TF, >0 STO, 0 STOP)
      INCLUD=0                 !>0 LOWEST, <0 TERMS TO BE SPECIFIED
      NLAM=0                   !NO. SCALING PARAMETERS
      NVAR=0                   !NO. VARIATIONAL PARAMETERS
      MCFMX=0                  !NO. STO POTENTIAL CF'S
      PRINT='FORM'             !'UNFORM' UNFORMATTED OUTPUT (SHORT)
      MAXE=-1                  !MAX CONTINUUM ENERGY FOR PI (&DW)
!
! SOMETINES USEFUL
!
      JUPMX=NLVLS              !MAX UPPER LEVEL FOR RADIATIVE OUTPUT
      JUPMN=1+ione1             !MIN UPPER   "         "        "
      JLOWMX=JUPMX-ione1        !MAX LOWER   "         "        "
      JLOWMN=1                 !MIN LOWER   "         "        "
      LUPMX=max(NTRMS,KMAX)    !MAX UPPER TERM/CF FOR RADIATIVE OUTPUT
      LUPMN=1+ione1             !MIN UPPER   "            "        "
      LLOWMX=LUPMX-ione1        !MAX LOWER   "            "        "
      LLOWMN=1                 !MIN LOWER   "            "        "
      EIMXLS=0                 !MAX LS ION ENERGY FOR AUGER RESOLUTION
      EIMXIC=0                 !MAX IC  "    "          "       "
      NRSLMX=10000             !MAX RESOLVED LOWER N-VALUE IF ABOVE ON
      NMETAR=0                 !MAX NO TERMS FOR AUGER RESOLUTION
      NMETARJ=0                !MAX NO LEVELS FOR AUGER RESOLUTION
      NMETAP=0                 !MAX NO LOWER TERMS FOR PE/PI
      NMETAPJ=0                !MAX NO LOWER LEVELS FPR PE/PI
      ECORRJ=0                 !CORRELATION ABOVE ECORRJ (IC)
      ECORR=0                  !CORRELATION ABOVE ECORR (LS & IC)
      ESKPL=-1                 !CORRELATION BETWEEN ESKPL
      ESKPH=-2                 !AND ESKPH
      NEIGEN=0                 !LOWEST NO ENERGY TERMS PER LSP SYM
      NEIGENJ=0                !LOWEST NO ENERGY LEVELS PER JP SYM
      FAC='  '                 !FORMS FAC POTENTIAL IN SCCA
      NOCC=0                   !NO. OCCUPATION NOS FOR STO/SCCA/FAC
      QED=999                  !QED CORRECTIONS
      IREL=999                 !SMALL CPT FLAG & TYPE OF S-O SCREENING
!
! OCCASIONALLY NEEDED
!
      MPRINT=-11               !JPRINT PASSED "UP" BY HISTORIC MPRINT
      JPRINT=999               !ALTERNATE (FLAG)
      IGAUGE=0                 !AEK/SEK GAUGE =0 LENGTH, ELSE VEL.
      ICAV=0                   !.NE.0 APPLY CONFIG. AV. ENERGY CORREC
      AJUSTX=-DONE             !GLOBAL CONFIG. AV. EXCHANGE SCALING
      DEFLAM=DONE              !DEFAULT LAMBDA
      MSTEP=0                  !INITIAL STEP LENGTH PROP 1/2**MSTEP
      DHNS0=DZERO              !EXACT INITIAL STEP LENGTH
      MRED=0                   !+/- SUBTRACT/ADD ELECTRNS IN MODEL POT
      ORTHOG='  '              !CHANGE DEFAULT ORTHOG. 'YES'='  '
      IORT=-1                  !DITTO
      IF(IDW.EQ.0)THEN
        KORT=1                 !OVERRIDES IORT FOR RYDBERG/CONTINUUM
      ELSE
        KORT=-1                !DW INCLUDES EXCHANGE OVERLAP
      ENDIF
      RADOUT='  '              !OUTPUT RADIAL FILE E.G. FOR R-MATRIX
      NLAMD=0                  !DIPOLE TF PERTBN NLAM
      NLAMQ=0                  !QUAD TF PERTBN NLAM
      NVARD=0                  !DIPOLE TF PERTBN NVAR
      NVARQ=0                  !QUAD TF PERTBN NVAR
      IPOLFN=9999              !TYPE OF POLARIZATION POTENTIAL
      DO I=0,3                 !1-BODY POLARIZATION SPECIFICATION
        ALFD(I)=DZERO
        RCUT(I)=DZERO
      ENDDO
      ALAV=DZERO               !2-BODY POLARIZATION SPECIFICATION
      RCAV=DZERO               !           DITTO
      SCALER=DONE              !COWAN SLATER INTEGRAL SCALE FACTOR
      ISHFTLS=0                !TERM ENERGY CORRECTIONS
      ISHFTIC=0                !PLUS LEVEL ENERGY CORRECTIONS
      IOPTIM=0                 !NORMALLY USED/RESET BY ISHFTLS/IC
      RZERO=-DONE              !RADIUS OF BOX STATES
      INUKE=999                !FINITE NUCLEUS TYPE
      RNUK=-DONE               !FINITE NUCLEUS RADIUS
      RNUKE=RNUK               !ALTERNATE
      ATM=-DONE                !NUCLEAR MASS
      IZESP=0                  !ZETA S-O SCREENING PARAMETER
      IBWRM=0                  !MAX R-MATRIX CLOSED SHELL ORB. NO.
      MIXBV='NO'               !ALLOW N+1 AND RYDBERG TO MIX IN DR LOOP
      KUTLSA=KUTLS             !ALGEB VALUE (CURRENTLY NOT RESTARTed)
      KUTLS=KMAX               !FLAG FOR CONFIG MIXING
      KUTDSK=0                 !WRITE E-VECTORS TO DISK (.NE.0)
      MDEN=0                   !TYPE OF PLASMA POTENTIAL
      NDEN=0                   !NO. OF DENSITY/TEMP PAIRS
      PPOT='  '                !PLASMA OR SELF-CONSISTENT POTENTIAL
      NPITER=5                 !NO. PLASMA ITERATIONS
      XBEE=DZERO               !NON-UNIFORM ION-SPHERE PARAM (0=UNIFORM)
      BALAN=.false.            !NL-LAMBDAS SCALE THE STO SUBSHELLS IF T.
      NFIX=0                   !NO OF LAMBDAS TO BE FIXED IN MINIM
      IWGHT=1                  !TERM WEIGHTING FACTOR FOR ENERGY SUM
      DDIAG='      '           !NAME OF LAPACK DIAGONALIZATION ROUTINE
      IFIX=0                   !NO OF ORBS TO BE FIXED IN SCCA/FAC
!
! THE REST ARE HARDLY EVER USED OR NEEDED, EXCEPT FOR TESTING
!
      TK0=-DONE                !NON-UNIFORM NUCLEUS SCALING PARAMETER
      SKIN=DZERO               !NUCLEAR SKIN DEPTH
      IGAGR=0                  !NUMERICAL GAUGE FOR RELATIVISTIC ORBS
      irtard=999               !RETARDATION SWITCH FOR MULTIPOLE RADTN
      ibreit=0                 !GENERALIZED BREIT SWITCH
      MEXTRE=0                 !HISTORIC MIX OF NLAM AND NVAR
      M=0                      !HISTORIC MSTEP
      MEXPOT=-999              !LOCAL (STO) EXCHANGE POTENTIAL
      ISTATIC=4                !MEXPOT VALUES .GE. ISTATIC ARE STATIC
      STONLZ='   '             !YES/NO: STO NL-SUBSHELL SCREENING
      NGAPSTO=1                !IGNORE N-SHELLS.GT.N+NGAPSTO
      IF(NW.GT.12)NGAPSTO=2    !IGNORE N-SHELLS.GT.N+NGAPSTO
      KCUT=-9999               !OVERRIDE ALGEB KCUT...
      NPE=12                   !MIN NUMBER STEPS PER PI FOR CONTINUUM
      ITANAL=0                 !DETAIL CI FOR ITANAL TERMS
      ECNTRB=DZERO             !WHICH CONTRIB ECNTRB WAVE NOS TO TERM
      RAD='  '                 !RESTRICT RAD TO 'BB' OR 'BF', SAY
      JRAD=0                   !RAD CHAR CONVERTED TO NUMERICAL
      EIONPOT=DZERO            !IF NO CONTINUUM, SET ABSOLUTE I.P.
      TINORB=-DONE             !MAX ORBITAL AMPLITUDE AT BOX
      xmax=-done               !MAX RADIAL MESH
      XMIX=D1M4                !FOR DWXLS/BP
      WLG1=-DONE               !MIN E1 RATE RETAINED
      WLG2=-DONE               !MIN E2 RATE RETAINED
      RMIN1=WLG1               !ALTERNATE
      RMIN2=WLG2               !ALTERNATE
      ifacy=2023               !SPECIFY A FAC YEAR TO MATCH TO
      facsp=-done              !Z AT WHICH FIT MATCHES H-S, <0 MID-POINT
      fac_csi=0.55             !H-S SMOOTHING FOR Z_HS>=Z-N+1+fac_csi
      faca=-0.4235             !FAC HARTREE-SLATER LOCAL EXCHNGE=HXS*AHX
      FAC_AHX=-DONE            !<0 USES FAC DEFAULT TABLES
      FAC_HXS=DONE             !FAC DEFAULT
      FAC_IHX=-DONE            !FAC DEFAULT
      FAC_HX0=-DONE            !FAC DEFAULT
      FAC_HX1=-DONE            !FAC DEFAULT
      POTOUT='  '
      POTIN='  '               !READS-IN EXTERNAL EFFECTIVE CHARGE
      IFLAGV=0                 !SET IFLAGV=1 IF POTIN INPUT IS POTENTIAL
!
! CAN'T REMEMBER THE LAST TIME THESE WERE USED
!
      MAXLAM=MAXLAM0           !MAX 2-BODY MULTIPOLE (SEE KUTLS)
      MGRP=0
      MPNCH=0
      KUTCAS=-1                !CASCADE
      KUTCA=999                !HISTORIC, NOT CUP='CA', REMOVE TBD
      KTCC=0
      TCC='NO'
      TOLTCC=-DONE
      MDELE=0
      MULTS=0
      MHF=0
      MRAD=0
      POTL='  '
      MPSEUD=0
      IDIAG=0                  !IDIAG=1 FORCES OLD JACORD IF NECESS
      TOLE=DZERO
      TOLB=-DONE
      STOLB=-DONE
      ITOL=0           !DEFAULT ACC OF ORBITALS DEL(E)/E.LT.10**(-ITOL0)
      IMAXIT=0                 !NO OF ITERATIONS IN VA04A
      TVARY=D1M2               !MAX VARY OF SCALE PER ITERATION
!
! THESE ARE NO LONGER ACTIVE, UNLESS UNCOMMENTED IN DIAGON/DIAGFS
!
      CMXLSA=D1M5              !SMALLEST MIXING COEFFS RETAINED
      CMXLSR=D1M5              !FOR LS AND IC
      CMXICA=D1M5              !AND FOR AUGER
      CMXICR=-D1M5             !AND RADIATIVE RATES
!
!-----------------------------------------------------------------------
!
! NAMELISTED INPUT (PREFERRED)
!
!-----------------------------------------------------------------------
!
      IF(BNAME)THEN
!
        REWIND(MR5)                    !CASE USER NAMELISTS OUT OF ORDER
!
        READ(MR5,SMINIM,END=1000,ERR=1000)
                                          ! <------------------ NAMELIST
!
! CONVERT ANY LOWER CASE TO UPPER
!
        PRINT=STRUPCASE(PRINT)
        ORTHOG=STRUPCASE(ORTHOG)
        RADOUT=STRUPCASE(RADOUT)
        MIXBV=STRUPCASE(MIXBV)
        PPOT=STRUPCASE(PPOT)
        STONLZ=STRUPCASE(STONLZ)
        RAD=STRUPCASE(RAD)
        FAC=STRUPCASE(FAC)
        TCC=STRUPCASE(TCC)
        POTL=STRUPCASE(POTL)
        POTOUT=STRUPCASE(POTOUT)
        POTIN=STRUPCASE(POTIN)
        DDIAG=STRUPCASE(DDIAG)
!
        IF(JPRINT.NE.999)MPRINT=JPRINT
        IF(KUTCA.NE.999)KUTCAS=KUTCA
        IF(RNUK.LT.DZERO)RNUK=RNUKE
        IF(WLG1.LT.DZERO)WLG1=RMIN1
        IF(WLG2.LT.DZERO)WLG2=RMIN2
!
      ELSE
!
!-----------------------------------------------------------------------
!
! HISTORIC NON-NAMELIST FIXED FORMAT INPUT (NOT RECOMMENDED):
!     N.B. THE OLD ISOELECTRONIC LOOP HAS BEEN DISABLED.
!
!-----------------------------------------------------------------------
!
!
        READ(MR5,10190)NZION,INCLUD,MEXTRE,MGRP,MDEN,MPRINT,MEXPOT,     &
     &                 MPNCH,KUTCAS,MRED,IORT,MDELE,MULTS,M0,MHF,MCFMX
!
!
      ENDIF
!
! *********************************************
! *** TEMP UNTIL RLX STORAGE ISSUE FIXED    ***
      IF(IEQ(0).LT.0.AND.IRTARD.EQ.999)IRTARD=0          !SO DEFAULT OFF
! *********************************************
!
      IF(IRTARD.EQ.999)IRTARD=1                          !BACKWARDS COMP
!
      IF(MPRINT.EQ.0.AND.BDR)MPRINT=-33
      IF(MPRINT.EQ.0)MPRINT=-11
      IF(PRINT.EQ.'UNFORM')MPRINT=-33
      BPRNT0=MOD(MPRINT,ITEN).NE.-3
!
      NPRNT5=MOD(NPRINT,IFIVE)
      IF(NPRNT5.EQ.-2)KUTDSK=0           !NO RAD SO NO E-VECTORS ON DISK
      IF(IDW.NE.0)KUTDSK=0               !AS WE STORE ALL BEFORE WRITING
!
      M0=MAX(M,MSTEP)
!
      IF(NW+NF.EQ.1.AND.INCLUD.NE.0)THEN
        INCLUD=0
        WRITE(MW6,*)
        WRITE(MW6,*)'*** RE-SETTING INCLUD=0 AS ONLY NUCLEAR POTENTIAL'
        WRITE(MW0,*)'*** RE-SETTING INCLUD=0 AS ONLY NUCLEAR POTENTIAL'
      ENDIF
!                                                         !O.K. IF SCCA?
      IF(NZION.LT.0.AND.NOCC.EQ.0.AND.MCFMX.LE.0.AND.QN(MXORB).GE.Q80   &
     &  .AND.IEQ(0).EQ.0)THEN
        WRITE(MW6,10010)
        WRITE(MW0,*)                                                    &
     &    ' *** STRONG WARNING: AVERAGING-OVER CONFIGURATION OCCUPATION'&
     &    ,' NUMBERS FOR STOPOT'
        WRITE(MW0,*)                                                    &
     &'     (MCFMX.LE.0) IS *NOT* RECOMMENDED WHEN CONTINUUM IS PRESENT'&
     &,'- SET MCFMX *** '
      ENDIF
!
      IF(ICAV.NE.0)THEN
        IF(IEQ(0).NE.0)THEN
          ICAV=0
          WRITE(MW6,*)
          WRITE(MW6,*)'*** RE-SETTING ICAV=0 SINCE RELAXED ORBITAL',    &
     &                ' BASIS PREVIOUSLY SPECIFIED.'
        ENDIF
        IF(INCLUD.NE.0)THEN
          INCLUD=0
          WRITE(MW6,*)
          WRITE(MW6,*)'*** RE-SETTING INCLUD=0 SINCE ICAV.NE.0'
          WRITE(MW0,*)'*** RE-SETTING INCLUD=0 SINCE ICAV.NE.0'
        ENDIF
        IF(ICAV.GT.0)THEN                                  !BASIC SET-UP
          NZION=-ABS(NZION)                               !MUST HAVE STO
          IF(PPOT.EQ.'   ')PPOT='SCCA'                  !SELF-CONSISTENT
          IF(MCFMX.EQ.0)THEN                     !AV. OCC. NOS OVER SPEC
            MCFMX=MIN(KCUT,KCUT0,KMAX)
            IF(MCFMX.LE.0)MCFMX=-KMAX
          ENDIF
        ENDIF
!        AJUSTX=ABS(AJUSTX)
      ENDIF
      AJUSTX=ABS(AJUSTX)                         !INCASE OF ICAV=0 USAGE
!
      NRSLMX=MAX(NRSLMX,-KMAX)                       !.LT.0 BUNDLE BY CF
!
      IF(KCUT.GE.0.AND.KCUT.NE.KCUT0)THEN
        IF(KCUT.EQ.0)KCUT=9999
        WRITE(MW6,*)
        IF(KCUT*KCUT0.GT.KCUT0*KCUT0)THEN
          WRITE(MW6,*)"*** WARNING: CORRELATION FLAG HAS BEEN REMOVED ",&
     &                "FROM CF'S",KCUT0+1," THRU",KCUT,                 &
     &                ", RATES INCOMPLETE!"
          WRITE(MW0,*)"*** WARNING: ALGEB CORRELATION SETTING HAS BEEN",&
     &                " OVERRIDDEN!"
        ELSEIF(KCUT.LT.KMAX)THEN
          WRITE(MW6,*)"NOTE: CF'S FROM",KCUT+1,"UPWARDS HAVE BEEN ",    &
     &      "FLAGGED AS CORRELATION - MORE EFFICIENT TO DO SO IN ALGEB!"
        ENDIF
        WRITE(MW6,*)
      ELSE
        KCUT=KCUT0                              !RE-INSTATE ALGEB KCUT
      ENDIF
!
      IF(TOLTCC.LT.DZERO)TOLTCC=D1M5
      IF(TCC.EQ.'STGICF')KTCC=1
      IF(TCC.EQ.'JAJOM')KTCC=-1
      IF(KTCC.EQ.0.AND.TCC.NE.'NO'.AND.TCC.NE.'  ')THEN
        WRITE(MW6,*)"*** UNRECOGNIZED TCC OPTION, TCC='",TCC,"'"
        WRITE(MW0,*)"*** UNRECOGNIZED TCC OPTION, TCC='",TCC,"'"
      ENDIF
      IF(MPNCH.NE.0)THEN
        MPNCH0=1
        IF(MPNCH.LT.0)MPNCH0=-1
        M00=ABS(MOD(MPNCH,IFOUR))
        IF(KUTCAS.GE.0.AND.M00.EQ.1)MPNCH=MPNCH+2*MPNCH0
        IF(KUTCAS.LT.0.AND.M00.GT.1)KUTCAS=0
        IF(KTCC.NE.0.AND.MOD(M00,ITWO).EQ.0)MPNCH=MPNCH+MPNCH0
        IF(KTCC.EQ.0.AND.MOD(M00,ITWO).NE.0)KTCC=1
      ELSE
        IF(KUTCAS.GE.0)MPNCH=-2
        IF(KTCC.NE.0)MPNCH=MPNCH-1
      ENDIF
!
! ALIGN SR.ALGEB KUTLS(A) AND SR.MINIM KUTLS
      IF(KUTLS.LT.0)KUTLS=0
      KUTLS=MIN(KUTLS,KMAX)
      IF(KUTLS.NE.KUTLSA)THEN
        IF(KUTLS.LT.KUTLSA)THEN
          WRITE(MW0,*)                                                  &
     &        "*** SR.MINIM0: ATTENTION, CI-MIXING WITHIN A CONFIG ONLY"&
     &        ," FOR CF'S .GT. KUTLS=",KUTLS
          WRITE(MW6,*)                                                  &
     &        "*** SR.MINIM0: ATTENTION, CI-MIXING WITHIN A CONFIG ONLY"&
     &        ," FOR CF'S .GT. KUTLS=",KUTLS
          WRITE(MW0,*)                                                  &
     &               '*** NOTE: MORE EFFICIENT TO SET KUTLS IN SR.ALGEB'
          WRITE(MW6,*)                                                  &
     &               '*** NOTE: MORE EFFICIENT TO SET KUTLS IN SR.ALGEB'
        ELSE
          IF(KUTLS.LT.KMAX)THEN                                !USER SET
            WRITE(MW0,*)                                                &
     &   '*** CI-MIXING WAS SWITCHED-OFF IN SR.ALGEB, RE-SETTING KUTLS!'
            WRITE(MW6,*)                                                &
     &   '*** CI-MIXING WAS SWITCHED-OFF IN SR.ALGEB, RE-SETTING KUTLS!'
          ENDIF
          KUTLS=KUTLSA
        ENDIF
      ENDIF
!
      IF(MAXLAM.LT.0)THEN                 !HISTORIC USER FLAG NO CF-MIX
        MAXLAM=-MAXLAM
        IF(KUTLS.GT.1.AND.KUTLS.LT.KMAX)THEN
          WRITE(MW0,*)'NOTE: USER SETTING OF KUTLS OVERRIDES MAXLAM < 0'
          WRITE(MW6,*)'NOTE: USER SETTING OF KUTLS OVERRIDES MAXLAM < 0'
        ELSEIF(KUTLS.EQ.KMAX)THEN
          KUTLS=0
          WRITE(MW0,*)                                                  &
     &  '***ATTENTION, USE KUTLS TO SWITCH-OFF CI-MIXING (IN ALGEB) NOW'
          WRITE(MW6,*)                                                  &
     &  '***ATTENTION, USE KUTLS TO SWITCH-OFF CI-MIXING (IN ALGEB) NOW'
        ENDIF
      ENDIF
!
      TOLE=TOLE/DTWO                      !CONVERT TO A.U.
!
      IF(CMXICR.LT.DZERO)THEN
        IF(MPOLE.GE.4)THEN
          CMXICA=D1M8
          CMXICR=D1M8
        ELSE
          CMXICR=D1M5
        ENDIF
      ENDIF
!
      IF(STOLB.LT.DZERO)STOLB=D1M9       !BORN INTEGRAL TOLERANCE
!
      bnobv=MIXBV.NE.'YES'               !no n+1 Rydberg DR mixing
!
      IF(MPSEUD.GT.0)THEN
        MPSEUD=MB
      ELSEIF(MPSEUD.LT.0)THEN
        MPSEUD=-MB
        IF(IREL.EQ.999)IREL=-1
      ENDIF
!
      IF(IPOLFN.LT.0)THEN
        WRITE(MW0,*)'*** RESETTING IPOLFN=0 (.LT.0 INTERNALLY RESERVED)'
        WRITE(MW6,*)'*** RESETTING IPOLFN=0 (.LT.0 INTERNALLY RESERVED)'
        IPOLFN=0
      ENDIF
!
      IF(NLAMD.NE.0.or.nvard.gt.0)IPOLFN=-1
      IF(NLAMQ.NE.0.or.nvarq.gt.0)IPOLFN=-2
      IF(NZION.LT.0.AND.IPOLFN.LT.0)THEN
        WRITE(MW6,*)' *** SR.MINIM0: ERROR, CANNOT USE PERTURBED TF',   &
     &              ' WITH STO! SET NZION.GT.0, OR SWITCH-OFF PERTURBN.'
        WRITE(MW0,*)'CANNOT USE PERTURBED TF WITH STO!'
        GO TO 1100
      ENDIF
!
      IF(NVAR.LT.0)THEN
        ISVAR=-1
        NVAR=-NVAR
      ELSEIF(NVAR.GT.0)THEN
        ISVAR=1
      ELSE
        ISVAR=1
        IF(NVARD.LT.0.OR.NVARQ.LT.0)ISVAR=-1
      ENDIF
      IF(NVARD.LT.0)NVARD=-NVARD             !NVAR OVERRIDES
      IF(NVARQ.LT.0)NVARQ=-NVARQ             ! "      "
      IF(TVARY.LE.D1M5)TVARY=D1M2
!
! INITIALIZE FOR POLARIZATION
!
      IF(ALFD(0).NE.DZERO)THEN              !USER HAS STARTED AT 0
        DO I=3,1,-1
          ALFD(I)=ALFD(I-1)
          RCUT(I)=RCUT(I-1)
        ENDDO
      ENDIF
      IF(ALFD(1).EQ.DZERO)ALFD(1)=ALFD(2)
      IF(ALFD(2).EQ.DZERO)ALFD(2)=ALFD(1)
      IF(ALFD(3).EQ.DZERO)ALFD(3)=ALFD(2)
      IF(RCUT(1).EQ.DZERO)RCUT(1)=RCUT(2)
      IF(RCUT(2).EQ.DZERO)RCUT(2)=RCUT(1)
      IF(RCUT(3).EQ.DZERO)RCUT(3)=RCUT(2)
      IF(ALAV.EQ.DZERO)THEN
        DO I=1,3
          ALAV=ALAV+ALFD(I)
        ENDDO
        ALAV=D1THRD*ALAV
      ENDIF
      IF(RCAV.EQ.DZERO)THEN
        DO I=1,3
          RCAV=RCAV+RCUT(I)
        ENDDO
        RCAV=D1THRD*RCAV
      ENDIF
      IF(ALFD(1)*RCUT(1).NE.DZERO)THEN         !SWITCH-ON POLARIZATION
        IF(IPOLFN.LT.0)THEN
          WRITE(MW6,*)'***SR.MINIM0: CANNOT USE PERTURBED TF WITH',     &
     &                ' NORCROSS/BAYLISS POLARIZATION POTENTIAL'
          WRITE(MW0,*)'***CANNOT MIX NORCROSS/BAYLISS WITH PERTURBED TF'
          GO TO 1100
        ENDIF
        IF(IPOLFN.EQ.9999)IPOLFN=1                           !NORCROSS
        IPOLF1=MOD(IPOLFN,ITEN)
        IPOLF2=IPOLFN/10
        IF(IPOLF1.GT.2)IPOLF1=2                               !BAYLISS
        IF(BPRNT0)THEN
          IF(IPOLF1.EQ.1)WRITE(MW6,10330)(I-1,ALFD(I),RCUT(I),I=1,3)
          IF(IPOLF1.EQ.2)WRITE(MW6,10320)(I-1,ALFD(I),RCUT(I),I=1,3)
        ENDIF
        IF(IPOLF2.GT.0)THEN
          IF(IPOLF2.GT.2)IPOLF2=2
          IF(BPRNT0)THEN
            IF(IPOLF2.EQ.1)WRITE(MW6,10350)ALAV,RCAV
            IF(IPOLF2.EQ.2)WRITE(MW6,10340)ALAV,RCAV
          ENDIF
        ENDIF
        IPOLFN=10*IPOLF2+IPOLF1
      ELSE
        IF(IPOLFN.GT.0)IPOLFN=0
      ENDIF
      DO I=1,3
        ALFD(I)=ALFD(I)/DTWO
      ENDDO
!
! SET LOW-LEVEL VARIABLES BASED ON USER INPUT
!
      IF(DDIAG.EQ.'DSYEVD')THEN
        LDIAG=1                      !DEFAULT, BUT INCASE USER SETS BOTH
      ELSEIF(DDIAG.EQ.'DSYEVR')THEN
        LDIAG=2
      ELSEIF(DDIAG.EQ.'DSYEVX')THEN
        LDIAG=3
      ELSEIF(DDIAG.NE.'      ')THEN
        WRITE(MW0,*)'*** UNRECOGNIZED OPTION FOR DDIAG...'
        WRITE(MW6,10370)DDIAG
        GO TO 1100
      ENDIF
!
      IF(RADOUT.EQ.'YES'.OR.RADOUT.EQ.'NRB')THEN
        IF(RADOUT.EQ.'YES'.AND.BDR)THEN               !SET INTERNAL FLAG
          MRAD=0
          WRITE(MW6,*)'*** RE-SETTING RADOUT="NO" SINCE &DRR IN USE'
          WRITE(MW0,*)'*** RE-SETTING RADOUT="NO"'
        ELSE      !NO LONGER NEED TO SET UNIT NO, BUT NEED NON-ZERO FLAG
          MRAD=-13
        ENDIF
      ELSEIF(RADOUT.EQ.'NO')THEN
        MRAD=0
      ELSEIF(RADOUT.NE.'  ')THEN
        WRITE(MW0,*)'*** UNRECOGNIZED OPTION FOR RADOUT...'
        WRITE(MW6,10380)RADOUT
        GO TO 1100
      ENDIF
!
      IF(POTOUT.EQ.'YES')THEN           !NO LONGER GIVES RADIAL AS WELL
        IF(BDR)THEN
          MRAD=0                                !SET INTERNAL FLAG
          WRITE(MW6,*)'*** RE-SETTING POTOUT="NO" SINCE &DRR IN USE'
          WRITE(MW0,*)'*** RE-SETTING POTOUT="NO"'
        ELSE      !IBID, BUT NEED MOD(MRAD,100).EQ.ZERO TO FLAG
          IF(MRAD.GE.0)THEN         !AS CAN'T HAVE BOTH FOR NOW
            MRAD=-100
          ELSE           !EVENTUALLY -113 WILL GIVE BOTH (SEE SR.RADIAL)
!            MRAD=-113              !MRAD-100
            WRITE(MW6,*)                                                &
     &                '*** RE-SETTING POTOUT="NO" SINCE RADOUT.EQ."YES"'
            WRITE(MW0,*)                                                &
     &                '*** RE-SETTING POTOUT="NO" SINCE RADOUT.EQ."YES"'
          ENDIF
        ENDIF
      ELSEIF(POTOUT.EQ.'NO')THEN
        MRAD=MOD(MRAD,I100)
      ELSEIF(POTOUT.NE.'  ')THEN
        WRITE(MW0,*)'*** UNRECOGNIZED OPTION FOR POTOUT...'
        WRITE(MW6,10390)POTOUT
        GO TO 1100
      ENDIF
!
      IF(POTIN.EQ.'FAX')THEN          !EXPERT ALLOW SOME NON-FAC OPTIONS
        IFAC=1                                  !MAY EXTEND FUTURE USAGE
        POTIN='FAC'
        WRITE(MW6,*)                                                    &
     &'*** ATTENTION: NON-STANDARD FAC OPTIONS ALLOWED, SET POTIN="FAC"'
        WRITE(MW0,*)                                                    &
     &'*** ATTENTION: NON-STANDARD FAC OPTIONS ALLOWED, SET POTIN="FAC"'
      ELSE
        IFAC=0
      ENDIF
      IF(POTIN.EQ.'FAC')THEN
        MHF=2
        IF(IFAC.EQ.0)THEN                                  !STRICTLY FAC
          IF(.NOT.BREL)THEN
            WRITE(MW6,*)                                                &
     &'*** USE OF NON-RELATIVISTIC ORBITALS CONFLICTS WITH POTIN="FAC"!'
            WRITE(MW0,*)                                                &
     &'*** USE OF NON-RELATIVISTIC ORBITALS CONFLICTS WITH POTIN="FAC"!'
            GO TO 1100
          ENDIF
          IF(KUTOO.EQ.0.AND.NSL0.GT.0)THEN               !RE-ALIGNED OFF
            WRITE(MW6,*)'*** SALGEB KUTOO=1 MAY ALIGN CLOSER WITH FAC'
            WRITE(MW0,*)'*** SALGEB KUTOO=1 MAY ALIGN CLOSER WITH FAC'
          ENDIF
          INUKE=1                                           !NON-UNIFORM
          IREL=2                                            !SMALL CPT
          QED=-1                                            !ON CA/LS/IC
        ELSE
          IF(INUKE.EQ.999)INUKE=1        !ADD BACK-IN AS POTIN SUBTRACTS
        ENDIF
      ELSEIF(POTIN.EQ.'HFFC'.OR.POTIN.EQ.'AS')THEN
        MHF=1
      ELSEIF(POTIN.EQ.'HFNL')THEN
        MHF=3
      ELSEIF(POTIN.EQ.'NO')THEN
        MHF=0
      ELSEIF(POTIN.NE.'  ')THEN
        WRITE(MW0,*)'*** UNRECOGNIZED OPTION FOR POTIN...'
        WRITE(MW6,10360)POTIN
        GO TO 1100
      ENDIF
!
      MEXPOT0=MEXPOT                                  !FOR NON-ITERATIVE
!
      IF(POTL.EQ.'STO')NZION=-ABS(NZION)
      IF(POTL.EQ.'TF')NZION=ABS(NZION)
!
      IF(NLAM.LT.0)THEN                    !USE MEXTRA FOR HISTORIC CASE
        NLAM=-NLAM
        IF(ORTHOG.EQ.' ')ORTHOG='L'
      ENDIF
      IF(ORTHOG.EQ.'L')IORT=1
      IF(ORTHOG.EQ.'NO'.OR.(ORTHOG.EQ.'  '.AND.NZION.LT.0))IORT=-3
      IF(ORTHOG.EQ.'LPS')IORT=-4
      IF(IRLX.EQ.2)IORT=-3         !NON-UNIQUE BASIS='RLX2' IN SALGEB
      IF(ORTHOG.EQ.'BOX')IORT=-5
      IF(IORT.EQ.-5)THEN
        IF(RZERO.LE.DZERO)THEN
          WRITE(MW6,*)'*** ERROR: USER MUST INPUT RZERO.GT.0 FOR BOX'
          WRITE(MW0,*)'*** ERROR: USER MUST INPUT RZERO.GT.0 FOR BOX'
          GO TO 1100
        ENDIF
        MXBOX=0
        IF(TINORB.LT.DZERO)TINORB=TINORB0
      ENDIF
!
      IF(BPRNT0.AND.MXBOX.EQ.0)WRITE(MW6,10410)RZERO
!
      IF(STONLZ.EQ.'YES')NLSTOE=0
      IF(STONLZ.EQ.'NO')NLSTOE=999
!
! INITIALIZE FOR RELATIVISTIC ORBITALS
!
      IF(BREL)THEN
        IF(IORT.EQ.-4)THEN
          WRITE(MW6,*)'*** RELATIVISTIC LPS NOT CODED...'
          WRITE(MW0,*)'*** RELATIVISTIC LPS NOT CODED...'
          GO TO 1100
        ENDIF
        IF(IORT.EQ.-5)THEN
          WRITE(MW6,*)'*** RELATIVISTIC BOX STATES NOT CODED...'
          WRITE(MW0,*)'*** RELATIVISTIC STATES NOT CODED...'
          GO TO 1100
        ENDIF
        IF(ORTHOG.EQ.'  ')IORT=-3
      ENDIF
!
!-----------------------------------------------------------------------
!
! END OF PRIMARY USER INPUT. SUBSEQUENT READS DEPENDENT ON THIS.
!
!-----------------------------------------------------------------------
!
!
      IF(NZION.EQ.0)GO TO 900       !<---------------------- TRUE RETURN
!
!
      IF(ABS(NZION).GT.118)THEN
        WRITE(MW6,*)' HERE BE MONSTERS, Z>118 - EXITING...'
        WRITE(MW0,*)' HERE BE MONSTERS, Z>118 - EXITING...'
        GO TO 1100
      ENDIF
!
!-----------------------------------------------------------------------
!
! PERFORM VARIOUS CHECKS ON INPUT AND SET VARIOUS CONSEQUENTIAL SWITCHES
!
!-----------------------------------------------------------------------
!
! FLAG CORRELATION BY ENERGY, THEN NOT NICELY ORDERED AS ALGEBRAIC CORR.
!
      IF(ECORRJ.EQ.DZERO)ECORRJ=ECORR              !HISTORIC, ONLY ECORR
      BECOR=ESKPH.GT.ESKPL.AND.ESKPL.GE.DZERO.OR.ECORR.NE.DZERO.OR.     &
     &      ECORRJ.NE.DZERO
!
! RELATIVISTIC GAUGE: IGAGR.GT.0 CONVERT 1/R INTEGRALS TO R**2
!                          .LT.0 LEAVE ALONE.
!
      IF(IGAGR.EQ.0)THEN
        IF(BREL)THEN
          IGAGR=1
        ELSE
          IGAGR=-1
        ENDIF
      ENDIF
!
! RADIATIVE RATES: IGAUGE=0 FOR LENGTH GAUGE, ELSE VELOCITY.
!
! RESTRICT RADIATIVE DATA (DEFAULT ALL)
! BOUND MEANS NON-AUTOIONIZING, FREE MEANS AUTOIONIZING
! TREAT STATES WITHIN TOLE RYD OF IONIZATION LIMIT AS EITHER.
! SET EIONPOT IF CONTINUUM NOT PRESENT.
!
!   RAD='BB'  BOUND-BOUND
!   RAD='BF' OR 'FB' BOUND-FREE
!   RAD='FF'  FREE-FREE
!   RAD='BBF' OR 'FBB' BOUND-BOUND + BOUND-FREE
!   RAD='BFF' OR 'FFB' BOUND-FREE + FREE-FREE
!
      IF(RAD.EQ.'BB')JRAD=1
      IF(RAD.EQ.'BF'.OR.RAD.EQ.'FB')JRAD=2
      IF(RAD.EQ.'FF')JRAD=3
      IF(RAD.EQ.'BBF'.OR.RAD.EQ.'FBB')JRAD=4
      IF(RAD.EQ.'BFF'.OR.RAD.EQ.'FFB')JRAD=5
      IF(JRAD.LT.0.OR.JRAD.GT.5)JRAD=0
!
      EIONPOT=EIONPOT/DTWO                      !CONVERT TO A.U.
!
! MINIM0UM RADIATIVE RATES RETAINED: E1=(WLG1,RMIN1), E2=(WLG2,RMIN2)
!
! MINIM0UM MIXING COEFFICIENTS TREATED AS NON-ZERO (1.E-5 DEFAULT)
! FOR LS AND IC AUTOIONIZATION AND RADIATIVE RATES: CMXLS/IC/A/R
!
! IDIAG .LE. 0 USE HOUSEHOLDER DIAGONALIZATION IN DIAGON/DIAGFS.
!           -1 DOES NOT APPLY TESTS THAT DEPEND ON CF LABEL.
! IDIAG .GT. 0 USE JACOBI METHOD INSTEAD.
!
! MPSEUD .NE. 0 USE MODEL POTENTL FOR CORE DEFINED BY KCOR1,2 IN ALGEB1
!        .GT. 0 SPIN-ORBIT FROM BLUME & WATSON, SO CORE ORBITALS NEEDED.
!        .LT. 0     "           MODEL POTENTIAL DERIVATIVE, UNLESS
!                               IREL.LT.0 WHICH OVERRIDES.
!
! MAXLAM IS MAX LAMDA FOR WHICH SLATER AND TWO-BODY FINE-STRUCTURE
! INTEGRALS ARE EVALUATED (SHOULD BE SET IN ALGEB).
!
! MCFMX .GT. 0, FOR EACH ORBITAL 1,...MCFMX READ THE CONFIGURATION
!               NUMBER TO SUPPLY OCCUPATION NOS TO BE USED TO GENERATE
!               THE STO MODEL POT.
!       .EQ. 0  AVERAGE OVER ALL SPECTROSCOPIC CONFIGURATIONS WHICH
!               CONTAIN A GIVEN ORBITAL.
!       .LT. 0  AVERAGE OF THE FIRST -MCFMX SPECTROSCOPIC CONFIGS -
!               THIS WILL LEAD TO FRACTIONAL OCCUPATION NOS AND
!               INCORRECT ASYMPTOTIC CHARGE.
!      SEE ALSO NOCC TO SPECIFY ARBITARY OCCUPATION NOS.
!
! MDEN  .GT. 0 GENERATE PLASMA SCREENING POTENTIAL & READ DENSITY+TEMP
!  *** IT IS NOT RECOMMENED TO SET MDEN DIRECTLY NOW, RATHER USE PPOT.
!      ALSO, SOME OPTIONS ARE ONLY AVAILABLE VIA PPOT. ***
!
!       .EQ. 1  OR PPOT='DH1'  1-BODY DEBYE-HUCKEL MODEL POTENTIAL
!       .EQ. 11 OR PPOT='DH2' inc. 2-BODY DEBYE-HUCKEL MODEL POTENTIAL
!                  PPOT='DH' = 'DH2' NOW (USED TO BE ='DH1').
!                  PPOT='PXXX' TREATS THE 1-BODY AS A PERTURBATION,
!                  2-BODY IS ALWAYS A PERT. XXX=ANY OF ABOVE DH OPTIONS.
!
!       .EQ. 2  OR PPOT='IS' UNIFORM ION-SPHERE MODEL POTENTIAL,
! EXCEPT IF SET
! XBEE .NE. 0 THEN NON-UNIFORM ION-SPHERE OR FLAG SPECIFIC XBEE VIA
!           PPOT='ISMB' NON-UNIFORM MAXWELL-BOLTZMAN ION-SPHERE (XBEE=2)
!           PPOT='ISFD' NON-UNIFORM FERMI-DIRAC ION-SPHERE (XBEE=4)
!
!       .EQ. 3  OR PPOT='KS' FOR KOHN-SHAM ION-SPHERE
!
!       .LT. 0  NO PLASMA POTENTIAL, ITERATES SELF-CONSISTENT(NEEDS STO)
!
! PPOT  .EQ. 'SCCA' S.C. CONFIGURATION AVERAGE POT (NON-LOCAL EXCHANGE)
!       .EQ. 'SCLR'.OR.'SCLR1' LINDGREN & ROSEN ALPHA=4/9 RYD (LOCAL)
!       .EQ. 'SCLR2' LINDGREN & ROSEN ALPHA=2/3 RYD (LOCAL EXCHANGE)
!       .EQ. 'SCHX' COWAN HARTREE-EXCHANGE (LOCAL)
!       .EQ. 'SCHS' HARTREE-SLATER (LOCAL EXCHANGE RESERVED FOR NEW FAC)
!       .EQ. 'SCFM' OR 'SCLX' FURNESS & MCCARTHY LOCAL EXCHANGE
!
! NPITER.EQ. NO. OF PLASMA ITERATIONS CASE MDEN=3, CAN ALSO
!            OVERRIDE DEFAULT (10=-MDEN) ITERATIONS CASE MDEN.LT.0
!
      IF(FAC.EQ.'  ')FAC='NO'
      IF(FAC.NE.'NO'.AND.PPOT.EQ.'   ')PPOT='SCCA'
      IF(PPOT.EQ.'FAC'.OR.FAC.EQ.'FAC')THEN        !SIMPLE FAC USER FLAG
        FAC='YES'
        PPOT='SCCA'
      ENDIF
      IF(PPOT.EQ.'RATS'.OR.FAC.EQ.'RATS')THEN      !LOS ALAMOS USER FLAG
        fac_csi=0                             !turn-off Latter smoothing
        FAC_AHX=0.4235     !AHX=0.4235 A.U. CORRESPONDS TO ALPHA=2/3 RYD
        FAC='YES'
        PPOT='SCCA'
      ENDIF
!
      IF(MDEN.LE.0)THEN
        PPP=PPOT(1:1)
        IF(PPP.EQ.'P')THEN              !1-BODY PLASMA IS A PERTURBATION
          PPOT(1:3)=PPOT(2:4)
          PPOT(4:4)=' '
          NPITER=-ABS(NPITER)                         !FLAG FOR SR.VMPOT
        ENDIF
        PIS=PPOT(1:2)
        IF(PIS.EQ.'SC')THEN                  !NON-PLASMA SELF-CONSISTENT
          IF(MDEN.EQ.0)MDEN=-10
        ENDIF
        IF(PPOT.EQ.'SCCA')THEN                      !CONFIG. AVERAGE POT
          IF(MEXPOT.EQ.-999.AND.FAC.NE.'FAX')MEXPOT=0
        ELSEIF(PPOT.EQ.'SCLR'.OR.PPOT.EQ.'SCLR1')THEN !L&R ALPHA=4/9 RYD
          IF(MEXPOT.EQ.-999)MEXPOT=1
        ELSEIF(PPOT.EQ.'SCLR2')THEN      !LINDGREN & ROSEN ALPHA=2/3 RYD
          IF(MEXPOT.EQ.-999)MEXPOT=2
        ELSEIF(PPOT.EQ.'SCHX')THEN               !COWAN HARTREE-EXCHANGE
          IF(MEXPOT.EQ.-999)MEXPOT=3
        ELSEIF(PPOT.EQ.'SCHS')THEN                 !COWAN HARTREE-SLATER
          IF(MEXPOT.EQ.-999)MEXPOT=4
        ELSEIF(PPOT.EQ.'SCFM'.OR.PPOT.EQ.'SCLX')THEN !FURNESS & MCCARTHY
          IF(MEXPOT.EQ.-999)MEXPOT=5
        ELSEIF(PPOT.EQ.'DH1')THEN
          MDEN=1
        ELSEIF(PPOT.EQ.'DH'.OR.PPOT.EQ.'DH2')THEN           !NEW DEFAULT
          MDEN=11
        ELSEIF(PIS.EQ.'IS')THEN
          MDEN=2
          NPITER=ABS(NPITER)                            !NO PERT FOR I-S
          IF(XBEE.EQ.DZERO)THEN             !CHECK NON-UNIFORM PPOT FLAG
            IF(PPOT.EQ.'ISMB')XBEE=DTWO
            IF(PPOT.EQ.'ISFD')XBEE=DFOUR
          ENDIF
        ELSEIF(PPOT.EQ.'KS')THEN                       !.OR.PPOT.EQ.'SC'
          MDEN=3                         !ONLY FLAG KOHN-SHAM FOR PLASMA
        ELSEIF(PPOT.NE.'  ')THEN
          WRITE(MW6,*)'UNRECOGNIZED PPOT OPTION: "',PPOT,'"'
          WRITE(MW0,*)'UNRECOGNIZED PPOT OPTION: "',PPOT,'"'
          GO TO 1100
        ENDIF
      ELSEIF(PPOT.NE.'  ')THEN
        WRITE(MW6,*)'IGNORING PPOT INPUT: "',PPOT,'", AS MDEN=',MDEN
        WRITE(MW0,*)'IGNORING PPOT INPUT: "',PPOT,'", AS MDEN=',MDEN
      ENDIF
!
      IF(MDEN.GT.0.AND.NDEN.EQ.0)THEN
        WRITE(MW6,*)                                                    &
     &   '*** NO DENSITY/TEMPERATURE SET, IGNORING PLASMA POTENTIAL ***'
        WRITE(MW0,*)                                                    &
     &   '*** NO DENSITY/TEMPERATURE SET, IGNORING PLASMA POTENTIAL ***'
        MDEN=0
      ENDIF
!
      IF(MDEN.EQ.2)NSW=9999                       !NO E=0 FOR ION-SPHERE
!
! MCFMX IGNORED IF NOCC OCCUPATION NOS SPECIFIED
!
      IF(MCFMX.GT.0.AND.MOD(NOCC,I1000).GT.0)THEN
        WRITE(MW6,*)'*** MCFMX CF SPECIFICATION OVERRIDDEN BY NOCC'
        WRITE(MW0,*)'*** MCFMX CF SPECIFICATION OVERRIDDEN BY NOCC'
      ENDIF
!
      IF(MDEN.NE.0)THEN
!
        IF(MCFMX.GT.0)THEN
          IF(MOD(NOCC,I1000).LE.0)THEN                   !CANNOT USE FAC
            IF(FAC.EQ.'YES'.OR.FAC.EQ.'OLD'.OR.FAC.EQ.'NEW')THEN
              WRITE(MW6,*)'*** MCFMX.GT.0 CONFLICTS WITH FAC="YES"...'
              WRITE(MW0,*)'*** MCFMX.GT.0 CONFLICTS WITH FAC="YES"...'
              GO TO 1100
            ENDIF
            FAC='NO'
          ENDIF
        ENDIF
!
! FAC='  ' OR 'NO' STANDARD AS/SS NON-FAC OPERATION, DEFAULT.
!        IF(FAC.EQ.'  ')FAC='NO'
!
! OPTIONS BELOW MIRROR FAC USE OF UNIQUE POTENTIAL SOLVED IN SCCA MODE.
!
! FAC='OLD' USES ORIGINAL NON-LOCAL EXCHANGE POTENTIAL.
! FAC='NEW' USES "NEW" LOCAL HARTREE-SLATER EXCHANGE POTENTIAL.
! FAC='YES' IS EQUIVALENT TO 'NEW'.
!
        IF(FAC.EQ.'YES')FAC='NEW'
!        IF(FAC.EQ.'YES')FAC='OLD'
!
        IF(FAC.EQ.'FAX')THEN          !EXPERT ALLOW SOME NON-FAC OPTIONS
          IFAC=1                                !MAY EXTEND FUTURE USAGE
          FAC='YES'
          IF(MEXPOT.EQ.-999)MEXPOT=44
          WRITE(MW6,*)                                                  &
     & '*** ATTENTION: NON-STANDARD FAC OPTIONS ALLOWED, SET FAC="YES"!'
          WRITE(MW0,*)                                                  &
     & '*** ATTENTION: NON-STANDARD FAC OPTIONS ALLOWED, SET FAC="YES"!'
          WRITE(MW6,*)' '
          WRITE(MW0,*)' '
          IF(MEXPOT.EQ.0)THEN                  !WARN
            WRITE(MW6,*)                                                &
     &'***WARNING:OLD NON-LOCAL EXCHANGE POTENTIAL IN USE SET MEXPOT=4?'
            WRITE(MW0,*)                                                &
     &'***WARNING:OLD NON-LOCAL EXCHANGE POTENTIAL IN USE SET MEXPOT=4?'
          ENDIF
        ELSEIF(FAC.NE.'NO')THEN
          IFAC=0
          IF(FAC.EQ.'NEW')THEN                   !LOCAL HARTREE-SLATER X
            MEXPOT=44                    !FOR STO, 04 FOR ITERATION ONLY
            ISTATIC=4
            FAC='YES'
          ENDIF
          IF(FAC.EQ.'OLD')THEN
            MEXPOT=0                             !NON-LOCAL X
            ISTATIC=5
            FAC='YES'
            WRITE(MW6,*)                                                &
     & '*** ATTENTION: NON-LOCAL EXCHANGE IS NO LONGER THE FAC APPROACH'
            WRITE(MW0,*)                                                &
     & '*** ATTENTION: NON-LOCAL EXCHANGE IS NO LONGER THE FAC APPROACH'
          ENDIF
! DO NOT PUT FAC='YES' HERE ELSE ANY ODD FLAG WILL USE FAC!!
        ENDIF
!
        IF(FAC.EQ.'YES')THEN
          MB0=0                               !ITERATE CLOSED-SHELL ORBS
          IF(IFAC.EQ.0)THEN                                !STRICTLY FAC
            IF(NOCC.LE.0)THEN                     !REQUIRE USER TO THINK
              WRITE(MW6,*)'*** SR.MINIM0: USER MUST SPECIFY FAC ',      &
     &                  'MEAN CONFIG OCCUPATION NUMBERS VIA SMINIM NOCC'
              WRITE(MW0,*)'*** SR.MINIM0: USER MUST SPECIFY FAC ',      &
     &                  'MEAN CONFIG OCCUPATION NUMBERS VIA SMINIM NOCC'
              GO TO 1100
            ENDIF
            IF(.NOT.BREL)THEN
              WRITE(MW6,*)                                              &
     &  '*** USE OF NON-RELATIVISTIC ORBITALS CONFLICTS WITH FAC="YES"!'
              WRITE(MW0,*)                                              &
     &  '*** USE OF NON-RELATIVISTIC ORBITALS CONFLICTS WITH FAC="YES"!'
              GO TO 1100
            ENDIF
            IF(KUTOO.EQ.0.AND.NSL0.GT.0)THEN             !RE-ALIGNED OFF
              WRITE(MW6,*)'*** SALGEB KUTOO=1 MAY ALIGN CLOSER WITH FAC'
              WRITE(MW0,*)'*** SALGEB KUTOO=1 MAY ALIGN CLOSER WITH FAC'
            ENDIF
            INUKE=1                                         !NON-UNIFORM
            IREL=2                                          !SMALL CPT
            QED=-1                                          !ON CA/LS/IC
            NOCCX=0                                         !FOR IDW=1
          ELSE
            IF(NOCC.LT.0)NOCC=-NOCC                         !SO FLAG>0
            NOCC=NOCC+1000                                  !ALLOW FOR 0
          ENDIF
        ELSEIF(FAC.EQ.'NO')THEN
          IF(NOCC.GT.0)NOCC=-NOCC                           !SO FLAG<0
          NOCC=NOCC-1000                                    !ALLOW FOR 0
        ELSE
          WRITE(MW6,*)'UNRECOGNIZED FAC OPTION: "',FAC,'"'
          WRITE(MW0,*)'UNRECOGNIZED FAC OPTION: "',FAC,'"'
          GO TO 1100
        ENDIF
!
        IF(IEQ(0).NE.0.AND.NOCC.GT.0)THEN
          WRITE(MW6,*)'*** RELAXED ORBITALS CONFLICT WITH FAC="YES"...'
          WRITE(MW0,*)'*** RELAXED ORBITALS CONFLICT WITH FAC="YES"...'
          GO TO 1100
        ENDIF
!
! NEED NL-SUBSHELL RESOLUTION FOR SELF-CONSISTENT
!
        IF(MDEN.LT.0.AND.NLSTOE.NE.0)THEN
          IF(NLSTOE.GT.0)THEN
            WRITE(MW6,*)'***RESETS FOR NL-SUBSHELL POTENTIAL RESOLUTION'
            WRITE(MW0,*)'***RESETS FOR NL-SUBSHELL POTENTIAL RESOLUTION'
          ENDIF
          NLSTOE=0
        ENDIF
!
! IF  MDEN.EQ.0  THEN (ALL STATIC +/- LOCAL EXCHANGE)
!   MEXPOT .LE. 0 HARTREE STO POTENTIAL (I.E. NON-EXCHANGE)
!   MEXPOT .EQ. 1 HARTREE-EXCHANGE LINDGREN & ROSEN (ALPHA=4/9 RYD)
!   MEXPOT .EQ. 2 HARTREE-EXCHANGE LINDGREN & ROSEN (ALPHA=2/3 RYD)
!   MEXPOT .EQ. 3 HARTREE-EXCHANGE COWAN (K_X=2/3 RYD)
!   MEXPOT .EQ. 4 HARTREE-SLATER (RESERVED FOR "NEW" FAC)
!   MEXPOT .GE. 5 AS .EQ. 0
!
! IF MDEN.NE.0 THEN AS ABOVE FIRSTLY, AND THEN SUBSEQUENT ITERATIONS
!   MEXPOT .LT. 0 HARTREE MULTIPOLE POTENTIAL (I.E. NON-EXCHANGE)
!   MEXPOT .EQ. 0 PLUS *NON-LOCAL* EXCHANGE (CONFIGURATION-AVERAGE)
!   MEXPOT .EQ. 1 PLUS LOCAL EXCHANGE LINDGREN & ROSEN (ALPHA=4/9 RYD)
!   MEXPOT .EQ. 2 PLUS LOCAL EXCHANGE LINDGREN & ROSEN (ALPHA=2/3 RYD)
!   MEXPOT .EQ. 3 *** COWAN NOT-CODED ***
!   MEXPOT .EQ. 4 PLUS LOCAL EXCHANGE HARTREE-SLATER (RESERVED FOR FAC)
!   MEXPOT .EQ. 5 STATIC PLUS FURNESS & MCCARTHY LOCAL EXCHANGE.
!
! TO USE A DIFFERENT MEXPOT>0 FOR THE FIRST (STO) ITERATION, SPECIFY
!   MEXPOT .GE. 10 THEN THE FIRST DIGIT IS USED FOR THE FIRST ITERATION
!  (MEXPOT0) AND THE SECOND DIGIT IS THE MEXPOT FOR THE SUBSEQUENT ONES
!   E.G. MEXPOT=10 USES THE LINDREN & ROSEN ALPHA=4/9 RYD LOCAL STO
!        EXCHANGE AND THE NON-LOCAL EXCHANGE FOR SUBSEQUENT ITERATIONS.
!   MEXPOT .EQ. 00 IS THE DEFAULT
!   MEXPOT .EQ.  n IS EQUIVALENT TO 0n, I.E. NON-EXCHANGE STO STARTS.
!   MEXPOT .EQ. n0 (n>0) MIGHT BE APPROPRIATE IN SOME CASES,
!                  E.G. TO TEST SENSITIVITY TO THE STARTING POTENTIAL.
!               nn MIGHT BE PREFERABLE TO 0n, BUT NEEDS TO BE USER SET.
!               mn (m>0.ne.n>0 is possible but likely not of interest.)
!
        IF(MEXPOT.EQ.-999)THEN                 !UNSET BY USER (PLASMA)
          MEXPOT=1
          MEXPOT0=1
        ELSEIF(MEXPOT.GE.10)THEN               !NON-DEFAULT NX PAIR
          MEXPOT0=MEXPOT/10
          MEXPOT=MEXPOT-10*MEXPOT0
        ELSE                                   !DEFAULT NX PAIR
          IF(MDEN.EQ.0)THEN                    !NOT ITERATING, SO
            MEXPOT0=MEXPOT
          ELSE                                 !ITERATING, BUT IF .EQ.
            MEXPOT0=0                          !MEXPOT CANNOT SET IT 0
          ENDIF                                !SO NEED TO IT SWITCH-ON
        ENDIF                                  !MANUALLY, MAY DO SO 4FAC
        IF(MEXPOT.GT.5)THEN                    !OUT-OF-RANGE
          IF(MDEN.GT.0)THEN                    !PLASMA
            MEXPOT=1
            MEXPOT0=1
          ELSE                                 !NON-PLASMA
            MEXPOT=0
            MEXPOT0=0
          ENDIF
        ENDIF
!
        IF(MEXPOT.EQ.3)THEN                    !NOT SUPPORTED IN SR.VPNL
          WRITE(MW6,*)'*** SR.MINIM0: SELF-CONSISTENT SOLUTION ',       &
     &                'NOT SUPPORTED FOR COWAN POTENTIAL - ABORT'
          WRITE(MW0,*)'*** SR.MINIM0: SELF-CONSISTENT SOLUTION ',       &
     &                'NOT SUPPORTED FOR COWAN POTENTIAL - ABORT'
          GO TO 1100
        ENDIF
!
        IF(INCLUD.NE.0.AND.MEXPOT.LT.0)THEN    !SINCE WE SCALE EXCHANGE
          WRITE(MW6,*)'***SR.MINIM0: SETTING INCLUD=0 AS NON-EXCHANGE', &
     &                ' SELF-CONSISTENT SOLUTION FLAGGED'
          WRITE(MW0,*)'***SR.MINIM0: SETTING INCLUD=0, AS NX SC'
          INCLUD=0
        ENDIF
        IF(MDEN.LT.0.AND.NZION.GT.0)THEN
          WRITE(MW6,*)'*** SR.MINIM0: SELF-CONSISTENT SOLUTION ',       &
     &                'REQUIRES STO FLAG, SETTING NZION.LT.0'
          WRITE(MW0,*)'***SR.MINIM0: SETTING NZION.LT.0'
          NZION=-NZION
        ENDIF
!
      ELSE
!
        IF(FAC.EQ.'YES')THEN                   !NO SCCA SO NO FAC
          WRITE(MW6,*)'*** SR.MINIM0: FAC POTENTIAL REQUIRES ',         &
     &          'SELF-CONSISTENT SOLUTION (PPOT="SCCA") OR SET FAC="NO"'
          WRITE(MW0,*)'*** SR.MINIM0: FAC POTENTIAL REQUIRES ',         &
     &                'SELF-CONSISTENT SOLUTION (PPOT="SCCA") '
          WRITE(MW0,*)'               OR SET FAC="NO"'
          GO TO 1100
        ENDIF
!
        NOCC=-ABS(NOCC)
!
        IF(MEXPOT.GE.10)THEN
          MEXPOT0=MEXPOT/10
          MEXPOT=MEXPOT-10*MEXPOT0
          IF(MEXPOT0.NE.MEXPOT)THEN
            WRITE(MW6,*)'*** SR.MINIM0: CONFUSION OVER NON-ITERATIVE ', &
     &                  'MEXP0T=',MEXPOT+10*MEXPOT0
            WRITE(MW0,*)'*** SR.MINIM0: CONFUSION OVER NON-ITERATIVE ', &
     &                  'MEXP0T=',MEXPOT+10*MEXPOT0
            WRITE(MW6,*)'    SETTING MEXPOT=',MEXPOT0,' RE-SET ELSEWISE'
            WRITE(MW0,*)'    SETTING MEXPOT=',MEXPOT0,' RE-SET ELSEWISE'
          ENDIF
          MEXPOT=MEXPOT0                       !RE-SET
        ELSEIF(MEXPOT.EQ.-999.AND.IRLX.NE.0)THEN
          MEXPOT=0                             !RELAXED DEFAULT
          MEXPOT0=0                            !RELAXED DEFAULT
        ENDIF
!
      ENDIF
!
! MHF .NE. 0 OPERATION SEPARATED INTO
!            MRAD (OLD MHF.LT.0) AND MHF (AS MHF.GT.0)
!            SO THAT THEY CAN BE SET INDEPENDENTLY.
!
      IF(MHF.GT.3)MHF=2                        !FAC DEFAULT
!
! MHF .GT. 0 READ EXTERNAL POTENTIAL FROM FILE hffcin/potin
!             ***CHECK FORMATS IN SR.POTIN***
!     .EQ. 1 ORIGINAL HARTREE-FOCK FROZEN-CORE (UNIQUE, USED FOR ALL)
!     .EQ. 2 FAC (UNIQUE, USED FOR ALL INTERNAL ORBITALS)
!     .EQ. 3 NL-DEPENDENT, IF NL NOT FOUND, THEN REVERT TO INTERNAL
!
! MRAD .LT. 0 WRITE P & Q FUNCTIONS AND/OR MAYBE POTENTIAL TO rad/potout
!
!      IF(MRAD.LT.0)MRAD=100*(MRAD/100)-13     !NOW HARD-WIRED TO UNIT13
!
! SET BREIT SWITCHES, & DEFAULT NUCLEUS:
!
      IF(BREL)THEN
        IF(IREL.EQ.999)THEN
          IREL=1
          IF(BFOT.OR.FAC.EQ.'YES')IREL=2
        ENDIF
        IF(ABS(IREL).EQ.2.AND.MHF.LT.0)THEN
          WRITE(MW6,*)'*** ILLEGAL INPUT COMBINATION IREL, MHF:',IREL,  &
     &                MHF
          WRITE(MW0,*)'*** ILLEGAL INPUT COMBINATION IREL, MHF'
          GO TO 1100
        ENDIF
        IF(ABS(IREL).NE.2.AND.IORT.LT.0.AND.IORT.NE.-3)THEN
          WRITE(MW6,*)                                                  &
     &       '*** WARNING: KAPPA-AVERAGED RADIAL EQUATION IS NON-LINEAR'
          WRITE(MW6,*)'***SCHMIDT-ORTHOGONALIZATION IS NOT RECOMMENDED!'
          WRITE(MW0,*)                                                  &
     &       '*** WARNING: KAPPA-AVERAGED RADIAL EQUATION IS NON-LINEAR'
          WRITE(MW0,*)'***SCHMIDT-ORTHOGONALIZATION IS NOT RECOMMENDED!'
        ENDIF
        IF(ABS(IREL).NE.2)IREL=SIGN(IONE,IREL)
!
!        IBREIT=ABS(IBREIT)                     !.LT.0 TEST MOLLER
        IF(IBREIT.LT.0)THEN
          IFLAGB=0
          IF(KUTSS.NE.-1)THEN
            IFLAGB=1
            WRITE(MW6,*)'*** RE-SETTING KUTSS=-1 SINCE MOLLER IBREIT=', &
     &                  IBREIT
            WRITE(MW0,*)'*** RE-SETTING KUTSS=-1 SINCE MOLLER IBREIT'
            KUTSS=-1
          ENDIF
          IF(KUTOO.NE.0)THEN          !RECALL -1 -> 0 RE-ALIGNMENT
            IFLAGB=1
            WRITE(MW6,*)'*** RE-SETTING KUTOO=-1 SINCE MOLLER IBREIT=', &
     &                  IBREIT
            WRITE(MW0,*)'*** RE-SETTING KUTOO=-1 SINCE MOLLER IBREIT'
            KUTOO=0
          ENDIF
          IF(IFLAGB.NE.0)THEN
            WRITE(MW6,*)'*** BETTER SETTING KUTSS/OO=-1 BACK IN SALGEB'
            WRITE(MW0,*)'*** BETTER SETTING KUTSS/OO=-1 BACK IN SALGEB'
          ENDIF
        ENDIF
      ELSE
        IF(IREL.EQ.999)IREL=1
        IF(ABS(IREL).EQ.2)THEN
          WRITE(MW6,*)"*** ILLEGAL INPUT FOR CUP='LS/IC' : IREL=",IREL
          IREL=SIGN(IONE,IREL)
          WRITE(MW6,*)"*** WILL RE-SET IREL=",IREL
          WRITE(MW0,*)'*** ILLEGAL INPUT COMBINATION BREL AND IREL',    &
     &                ' - RE-SETTING'
        ENDIF
      ENDIF
!
! NUCLEAR POTENTIAL AND SCREENING
!
      IF(INUKE.EQ.999)THEN                     !UNSET
        INUKE=-1                               !POINT
        IF(BREL.AND.ABS(NZION).GT.30.OR.FAC.EQ.'YES')INUKE=1   !U6/FERMI
      ELSE                                     !USER SET
        IF(INUKE.GE.0)THEN                     !FINITE NUCLEUS
          IF(.NOT.BREL)THEN                !NO LONGER ALLOW WITH NR ORBS
            WRITE(MW6,*)                                                &
     &           '*** NOTE: USING A FINITE NUCLEUS WITH NON-REL ORBS...'
!     &               '*** RE-SETTING TO POINT NUCLEUS FOR NON-REL ORBS'
            WRITE(MW0,*)                                                &
     &           '*** NOTE: USING A FINITE NUCLEUS WITH NON-REL ORBS...'
!     &               '*** RE-SETTING TO POINT NUCLEUS FOR NON-REL ORBS'
!            INUKE=-1
          ENDIF
        ELSE                                   !POINT NUCLEUS
          IF(BPRNT0.AND.BREL.AND.ABS(NZION).GT.30)THEN       !WARN USER
            WRITE(MW6,*)                                                &
     &             '*** USE OF FINITE NUCLEUS RECOMMENDED WITH REL ORBS'
            WRITE(MW0,*)                                                &
     &             '*** USE OF FINITE NUCLEUS RECOMMENDED WITH REL ORBS'
          ENDIF
        ENDIF
      ENDIF
      IF(INUKE.LT.0)THEN   !POINT NUCLEUS
        INUK0=999999
      ELSE                 !FINITE
        INUK0=2
      ENDIF
!
      DO I=1,IXPOT                 !INITIAL ALL, MAY READ LESS
        ZESP(I)=DONE
      ENDDO
      IF(IZESP.GT.0)THEN           !SCREEN NUCLEAR, BLUME& WATSON OFF
        IZ=IZESP
        IREL=ABS(IREL)             !SINCE SCREENING NUCLEAR
      ELSE                         !SCREEN BLUME&WATSON SCREENED NUCLEAR
        IZ=-IZESP
      ENDIF
      IF(IZ.GT.IXPOT)THEN
        IZ=IXPOT
        IZESP=SIGN(IZ,IZESP)
        WRITE(MW6,*)'*** SR.MINIM0: L-DEP ZESP USE THE L=',IZ-1,        &
     &              ' VALUE FOR HIGHER-L'
        WRITE(MW0,*)'*** SR.MINIM0: REDUCING NO. OF EXPLICIT L-DEP ZESP'
      ENDIF
      IF(IZ.GT.0)CALL DIMUSE('MXPOT',IZ)
!
      IF(IBWRM.GT.0)THEN
        IF(IBWRM.GT.MB)THEN
          IF(NL000.GT.0)THEN
            WRITE(MW6,*)'*** ERROR, CANNOT RESET BLUME & WATSON, IBWRM='&
     &                  ,IBWRM,' WHEN TWO-BODY FINE-STRUCTURE PRESET'
            WRITE(MW0,*)'*** ERROR, CANNOT RESET BLUME & WATSON',       &
     &                  ' WHEN TWO-BODY FINE-STRUCTURE PRESET'
            GO TO 1100
          ENDIF
          WRITE(MW6,*)'*** WARNING *** WARNING *** WARNING *** WARNING:'
          WRITE(MW6,*)'*** YOU ARE FORCING BLUME & WATSON CLOSED SHELLS'&
     &                ,' TO IBWRM=',IBWRM,                              &
     &                ' BEYOND THOSE SPECIFIED BY KCOR2=',MB
          WRITE(MW0,*)'*** WARNING *** WARNING *** WARNING *** WARNING:'
          WRITE(MW0,*)'*** YOU ARE FORCING BLUME & WATSON CLOSED SHELLS'&
     &                ,' BEYOND THOSE SPECIFIED SR.ALGEB'
          DO I=MB+1,IBWRM
            NWRM=NWRM+2*(QL(I)+1)
          ENDDO
        ELSE
          WRITE(MW6,*)'NOTE: USER IBWRM=',IBWRM,' .LE. KCOR2=',MB,      &
     &                ' SO BLUME & WATSON UNCHANGED FROM AS DEFAULT'
        ENDIF
      ENDIF
!
! QED: VACUUM POLARIZATION AND SELF-ENERGY CORERCTIONS
!
      IF(QED.EQ.999)THEN                                !DEFAULTS
        IF(FAC.EQ.'YES')THEN                            !SO EXPERT
          IF(BREL)THEN
            QED=-1                                      !ON CA/LS/IC
          ELSE
            QED=1                                       !OFF CA/LS ON IC
          ENDIF
        ELSE                                            !OFF
          QED=0
        ENDIF
      ENDIF
!
! INPUT NUCLEAR CHARGE .LT. 0 IF REQUIRE SLATER-TYPE-ORBITAL POTENTIAL
! INPUT NUCLEAR CHARGE .GT. 0 IF REQUIRE THOMAS-FERMI S.M. POTENTIAL
!
      MSHELL=0
      BSTO=NZION.LT.0
      IF(BSTO)NZION=-NZION
!
! CHANGE NUMBER OF ELECTRONS
!
      MION=NW+NF-MRED
      IF(MRED.NE.0)WRITE(MW6,10240)MION,MRED
!
! SET NOMINAL ASYMPTOTIC CHARGE
!
      NZA=NZION-MION
!
! ADJUST TO TARGET (I.E. REMOVE ANY RYD/CONT)
!
      if(idw.eq.0)then
        DO I=1,MXORB
          IF(DEY(I).NE.DZERO.AND.QN(I).GE.80)THEN
            NZA=NZA+1                           !AS RYD/CONT INC IN MION
            iflagc=1
            GO TO 100
          ENDIF
        ENDDO
!      else                                     !mion does not inc. cont
      endif
      iflagc=0
!
  100 IF(NZA.LT.0)THEN
        WRITE(MW6,*)                                                    &
     &   '*** SR.MINIM0: CANNOT TREAT NEGATIVE IONS, INCREASE NZION TO:'&
     &   ,MION                                             !,nzion,nza
        WRITE(MW0,*)                                                    &
     &       '*** SR.MINIM0: CANNOT TREAT NEGATIVE IONS, INCREASE NZION'
        GO TO 1100
      ENDIF
!
! NUMERICAL DEGENERATE ENERGY TOLERANCE (SYNC'ED WITH POST-PROCESSORS)
!
      IF(TOLB.LT.DZERO)THEN
        IF(ICC.GT.0)THEN                         !FOR DRIFT
          DZ=NZA*NZA
          TOLB=MAX(D1PT5M7,D1M9*DZ*NZA)
        ELSE                                     !NO DRIFT
          TOLB=D1PT5M7
        ENDIF
      ENDIF
!
! MSTEP=M CHANGES INITIAL STEP LENGTH DHNS(1), SEE BELOW,
! MSTEP=10 DEFAULT, INCREASE MSTEP FOR SMALLER STEP
! IXTRA ADDS EXTRA INTERVALS AT ORIGIN, WITH CORRESPONDING SMALLER
! STEP LENGTH BUT DOES NOT CHANGE THE ASYMPTOTIC STEP
!
!      NZA=NZION-MION                                !HISTORIC
!      NZ1=NZA                                       !HISTORIC
      NZ1=NZION                                      !FOR IXTRA
!
      M=10
      IF(NZA.LT.5)M=11
      IF(MDEN.GT.0)M=M+1
      IF(NZA.GT.30)M=11
      IF(BDR)M=11
      IF(IXTRA.LE.0.AND.(BREL.OR.INUKE.GE.0))THEN
        IF(NZ1.GE.88)THEN
          MM=15
          IX=4
        ELSEIF(NZ1.GE.50)THEN
          MM=14
          IX=3
        ELSEIF(NZ1.GE.38)THEN
          MM=13
          IX=2
        ELSEIF(NZ1.GE.6)THEN
          MM=12
          IX=1
        ELSE
          MM=11
          IX=0
        ENDIF
        IF(NW+NF.EQ.1.AND.IX.LT.2)THEN    !H-LIKE SPECIAL CASE
          MM=13
          IX=2
        ENDIF
!                                         !FINITE NUCLEUS CANNOT SUPPORT
!        IF(ITOL.GT.ITOL0)IX=IX+IX        !THIS LEVEL OF ACCURACY
        IF(BREL)THEN
          IF(IXTRA.EQ.0)THEN    !ORIGINAL (CAN STILL SET MSTEP MANUALLY)
            M=MM
          ELSE
            IXTRA=IX
          ENDIF
        ELSE                              !NON-KAPPA BUT FINITE NUCLEUS!
          IF(IXTRA.LT.0)IXTRA=IX          !ELSE ORIGINAL
        ENDIF
      ENDIF
!
      IF(MA.EQ.0)THEN
        IF(NZION.GT.6.AND.NZA.LT.5)M=M+1
        IF(NZION.GT.9.AND.NZA.LT.2)M=M+1
        if(m.eq.10)m=m+iflagc
      ENDIF
!
      IF(IORT.LE.-4)M=14
!
! NOW SET TO ASYMPTOTIC CHARGE SEEN BY A (TRUE) TARGET ELECTRON
!
      NZA=NZA+1
!
      if(idw.ne.0.and.maxe.le.0)then
        te1=maxn
        te1=nza/te1
        te1=te1*te1
        maxe=nint(te1,sp)                          !for "legacy" integer
        if(maxn.gt.mb+1)then
          te2=mb+1
          te2=nza/te2
          te2=te2*te2
          maxe=nint(te2-te1,sp)
          maxe=max(maxe,done)                      !ione
        else
          maxe=nza
        endif
        maxe=5*maxe
        write(mw6,*)'*** SR.MINIM0 WARNING: IT IS STRONGLY RECOMMENDED',&
     &        ' THAT YOU SET THE MAXIMUM RYD SCATTERING ENERGY, MAXE...'
        write(mw6,*)'    I HAVE GUESSED MAXE=',MAXE
!par        if(iam.eq.0)then                                        !par
        write(mw0,*)'*** SR.MINIM0 WARNING: YOU',                       &
     &          ' HAVE NOT SET THE MAXIMUM RYD SCATTERING ENERGY, MAXE!'
        write(mw0,*)'    I HAVE GUESSED MAXE=',MAXE
!par        endif                                                   !par
      endif
!
      IF(MAXE.GT.0)THEN
        DHNSX=(DCON0/NZION)**D1THRD/(NZA**D2THRD)           !/(2**MSTEP)
        TE=MAXE
        TE=SQRT(TE)
        DHNSX=LOG(NPE*DHNSX*TE/PI)/LOG(DTWO)          !NPE=NO PTS PER PI
        MM=INT(DHNSX,SP)+MJH0
!        write(mw0,*)m,mm,dhns0/2**mm
        M=MAX(M,MM)
      ELSE
        IF(BFOT.AND.M.LT.15)M=15                      !ASSUME WORST CASE
      ENDIF
!
      IF(BREL.AND.IXTRA.GT.0)IXTRA=IXTRA-(M-11)
!
      IF(M0.GT.0)THEN
        IF(M0.LT.M)THEN
          WRITE(MW6,*)'*** WARNING IN SR.MINIM0: YOU ARE REDUCING ',    &
     &                'MSTEP BELOW THE RECOMMENDED VALUE OF',M
          WRITE(MW6,*)
          WRITE(MW0,*)                                                  &
     &               '*** WARNING: YOU ARE REDUCING MSTEP BELOW DEFAULT'
        ENDIF
        M=M0
      ENDIF
!
! SOME RADIAL INITIALIZATIONS
!
      MSTEP=M                              !INITIAL STEP PROP 1/2**MSTEP
      IF(ITOL.EQ.0)ITOL=ITOL0                           !TF POT ACCURACY
      MAXRS=0                                              !RADIAL INDEX
      IF(IXTRA.LT.0)IXTRA=0           !NO ADDITIONAL INTERVALS AT ORIGIN
      DHNS0=MAX(DZERO,DHNS0)                        !INITIAL STEP LENGTH
      DHNS(1)=-DHNS0                                !FLAG INITIAL SET-UP
!
!-----------------------------------------------------------------------
!
! MULTS=0 DOES NOTHING
! MULTS .LT. 0 APPLIES LS-COUPLING SELECTION RULES TO INTERMEDIATE
!              COUPLING RADIATIVE RATES IN SR.DIAGFS
! MULTS .GT. 0 AS .LT. 0 BUT ONLY EVALUATES INTERMEDIATE COUPLING
!              RADIATIVE RATES FOR TERMS WITH SPIN MULTIPLICITY MULTS
!
! |MDELE|=NUMBER OF TERM ENERGY CORRECTIONS TO BE READ BELOW (DO 92)
! IF .LT. 0  READS/WRITES TFU FROM/TO UNIT MR+1 (DISABLED).
! MDELE IS HISTORICAL, BUT CAN STILL BE USED TO READ TECS FROM
! UNIT6. IT HAS BEEN SUPERCEDED BY ISHFTLS AND ISHFTIC.
!
! ISHFTLS (ISHFTIC) .eq.0, no shifts (default).
! .EQ. 1
! READ TERM (LEVEL) NUMBERS AND ENERGY CORRECTIONS FROM FILE SHFTLS
! (SHFTIC) PRECEDED BY THE NUMBER OF STATE/ENERGY PAIRS TO BE READ AND
! THE ENERGY UNITS USED (AS IP OF H). CAN BE USED TOGETHER IN AN IC RUN,
! THEN LS ENERGY SHIFTS ARE APPLIED AS TERM ENERGY CORRECTIONS TO H(IC)
! BEFORE DIAGONALIZATION AND THE IC SHIFTS AS A FURTHER CORRECTION AFTER
! H(IC) DIAGONALIZATION TO ACHIEVE EXACT LEVEL POSITIONING. THE TERM
! (LEVEL) NUMBERS ARE THE ALGEBRAIC T (LV) NUMBERS, NOT THE ENERGY
! ORDERED.
!  .GT. 1
! THEN ASSUMES OBSERVED ENERGIES, RELATIVE TO THE GROUND (AVERAGED
! -OVER FINE-STRUCTURE FOR TERMS) NOT CORRECTIONS ARE INPUT AND THEN
! ISHFTLS OR ISHFTIC ITERATIONS OF H(IC) ARE CARRIED-OUT. ISHFTLS
! ITERATIONS ARE APPLIED AS TERM ENERGY CORRECTIONS (TEC) TO H(IC).
! THE FINAL TECS CAN THEN BE INPUT IN SHFTLS WITH ISHFTLS=1 AND THEN
! (OPTIONALLY) ISHFTIC ITERATIONS CAN BE APPLIED AS LEVEL ENERGY
! CORRECTIONS TO THE DIAGONAL OF H(IC) BEFORE DIAGONALIZATION. THE
! FINAL LECS CAN THEN BE INPUTIN SHFTIC WITH ISHFTIC=1 TO REGENERATE
! THE FINAL STRUCTURE WITHOUT ITERATION.
!  .LT. 0
! NO ITERATIONS (AS .EQ. 1) BUT ASSUMES INPUT OBSERVED ENERGIES
! (AS .GT. 1).
!
! SEE ALSO SR.RADCON FOR ABSOLUTE SHIFT OF CONTINUUM
!
      IF(ISHFTIC.NE.0.AND.NJO.LE.0)THEN
        WRITE(MW6,*)' N.B. RE-SETTING ISHFTIC=0 AS NOT AN IC RUN'
        WRITE(MW0,*)' N.B. RE-SETTING ISHFTIC=0 AS NOT AN IC RUN'
        ISHFTIC=0
      ENDIF
      IF(ISHFTLS.NE.0.AND.NSL0.LE.0)THEN
        WRITE(MW6,*)' N.B. RE-SETTING ISHFTLS=0 AS NOT AN LS RUN'
        WRITE(MW0,*)' N.B. RE-SETTING ISHFTLS=0 AS NOT AN LS RUN'
        ISHFTLS=0
      ENDIF
      BDELE=MDELE.NE.0.OR.ISHFTLS.NE.0.OR.ISHFTIC.NE.0
      IF(ISHFTLS.GT.1.AND.ISHFTIC.GT.1.AND.INCLUD.EQ.0)THEN
        WRITE(MW6,*)' *** SR.MINIM0 ERROR: CANNOT ITERATE ON TECS AND', &
     &              ' LECS AT THE SAME TIME! ',ISHFTLS,ISHFTIC
        WRITE(MW0,*)' *** SR.MINIM0 ERROR: CANNOT ITERATE ON TECS AND', &
     &              ' LECS AT THE SAME TIME!'
        GO TO 1100
      ENDIF
      IF(ISHFTLS.NE.0.AND.ISHFTIC.NE.0.AND.INCLUD.NE.0)THEN
        IF(NJO.GT.0)THEN
          WRITE(MW6,*)'***SR.MINIM0: IGNORING SHFTLS, USING SHFTIC FILE'
          WRITE(MW0,*)'***SR.MINIM0: IGNORING SHFTLS, USING SHFTIC FILE'
          ISHFTLS=0
        ENDIF
      ENDIF
      IF(MDELE.LT.0)MDELE=-MDELE
      IF(MDELE.GE.0)GO TO 200
      IF(MDELE.LT.0)GO TO 200
      WRITE(MW6,10260)
      MDELE=0
!
!-----------------------------------------------------------------------
!
! MGRP=!MGRP!  SPECIFIES NUMBER OF SIGMA/Q.D. PARAMETERS TO BE REA
! MGRP .GT. 0 SCREENING PARAMETERS
! MGRP .LT. 0 QUANTUM DEFECTS *100 , .LT. 999.0 ONLY.
! SCREEN MUST BE IN RANGE 999 TO 5998 FOR 'REPLACEMENT' IN SR.RADWIN
! AND .GE. 5999 FOR 'REPLACEMENT' IN SR.RADCON, .GE. 7999 EVALUATES
! CONTINUUM FUNCTION AT USER SUPPLIED ENERGY(S) SEE RADCON, OTHERWIS
! EVALUATES CONTINUUM FUNCTION AT THRESHOLD (K=0) FOR EXTRAPOLATION
! TO PRINCIPAL QUANTUM NUMBER SPECIFIED BY GIVEN ORBITAL NUMBER.
! .LT. -999 HAS SPECIAL MEANING, SEE SR.RADIAL.
!
  200 MGRP0=MGRP
      MGRP=ABS(MGRP)
!
! MORT CONTROLS THE TYPES OF BOUND ORBITALS TO BE GENERATED (INDEPENDENT
! IN PRINCIPAL OF WHETHER A THOMAS-FERMI OR STO POTENTIAL IS USED.)
! THIS INCLUDES WHETHER THEY REQUIRE SCALING PARAMETERS FOR EACH ORBITAL
! POTENTIAL (nl DEPENDENT) AND WHETHER THE ORBITALS ARE ORTHOGONALISED.
! MORT IS THE INTERNAL VARIABLE. IT CAN BE SET BY THE USER VIA THE
! NAMELIST VARIABLE IORT, THEN MORT=IORT AND IORT=ABS(MORT) INTERNALLY.
! NOTE, THE PREFERRED USER INPUT VARIABLE IS NOW ORTHOG,
! AS INDICATED BELOW.
!
! I/MORT   .GE. 0 USES L-DEPENDNENT SCALING PARAMETERS (OR ORTHOG='L')
!                 SO NO ORTHOGONALIZATION IS NEEDED (OR CARRIED-OUT...)
! I/MORT   .LT. 0 USES NL-DEPENDENT SCALING PARAMETERS (OR ORTHOG='NL')
!                 AND IN PRINCIPAL SCHMIDT ORTHOGONALIZES THE ORBITALS.
!                 BY DEFAULT, IT ONLY DOES SO FOR NON-RELATIVISTIC
!                 ORBITALS GENERATED WITH A THOMAS-FERMI POTENTIAL.
!                 THE TREATMENT OF RYDBERG/CONTINUUM ORBITALS MAY DIFFER
!                 FURTHER - SEE KORT BELOW.
! |I/MORT| .EQ. 2 USES MODIFIED HYDROGENIC ORBITALS WHEN CORRELATION
!                 SPECIFIED TO BE CONSISTENT WITH IMPACT, PURE
!                 HYDROGENIC OTHERWISE: ZEFF=-LAM*Z0 EXCEPT
!                 CURRENTLY, THERE IS NO ORTHOG FLAG FOR THIS OPTION.
!  I/MORT  .EQ.-4 ZEFF=-N*LAM/2 FOR PSEUDO-STATE BASIS. OR ORTHOG='LPS'.
!                 THEN LAM GENERALLY INDEPENDENT OF NL, BUT ORBITALS
!                 MUST BE (AND ARE) SCHMIDT ORTHOGONALIZED.
!  I/MORT  .EQ.-5 USES BOX STATES. OR ORTHOG='BOX'
!
! |I/MORT| .GT. 20 RESTARTS CALCULATION OF RADIATIVE RATES IN DIAGFS
!               (I.E. FOR IC AR ONLY) FROM ENERGY ORDER LEVEL !MORT!.
!               THIS IS AN ANACRONISTIC FEATURE.
!
      IF(IORT.NE.0)MORT=IORT            !TRANSFER TO INTERNAL
!
! KORT CONTROLS THE RYDBERG/CONTINUUM ORTHOGONALIZATION, AS FOLLOWS:
!
! KORT .EQ. 0  FOLLOWS THE HISTORIC OPERATION OF SCHMIDT
!              ORTHOGONALIZATION OF RYDBERG/CONTINUUM ORBITALS TO
!              THE CORE ORBITALS IF DEFAULT/USER OPERATION DOES SO FOR
!              THE CORE ORBITALS.
! KORT .LT. 0  DETERMINES THE EXCHANGE OVERLAP CONTRIBUTION TO THE
!              MONOPOLE SLATER INTEGRALS (FOR AUTOIONIZATION RATES.)
! KORT .GT. 0 DOES NOT APPLY ANY ORTHOGONALIZATON PROCEDURE.
!
! IN PARTICULAR, KORT.NE.0 OVERRIDES ANY IMPLICIT (DEFAULT) OR EXPLICIT
! (USER) ORTHOGOALIZATION FLAG BY THE ORTHOG/IORT/MORT VARIABLES
! (WHICH IN TURN CAN DEPEND ON THE TF, STO, KAPPA-AVERAGE USAGE),
! WHICH APPLY ONLY TO THE CORE ORBITALS THEN.
!
! MORT .GE. 0 DOES NOT APPLY ANY ORTHOGONALIZATION.
! MORT .LT. 0 SCHMIDT ORTHOGONALIZATION IS APPLIED (BUT SEE KORT).
! EXCEPTION I/MORT .EQ. -3, NO ORTHOGONALIZATION IMPOSED, LAM=nl STILL.
!
      IF(MORT.LT.0)THEN
        if(idw.eq.0)then
          NPARAM=NGROUP                 !HISTORIC, MAYBE .NE. MXORB
        else
          NPARAM=MXORB
        endif
      ENDIF
!
      NP0=0
      IF(IPOLFN.LT.0)NP0=-IPOLFN
      NPARM3=(NP0+1)*NPARAM
      NPARM2=2*NPARAM
!
      IXVAR=NPARM3
!
      CALL DIMUSE('MXVAR',IXVAR)
!
      IF(IXVAR.GT.MXVAR)THEN
        IF(MXVAR.GT.0)WRITE(MW6,10160)IXVAR,MXVAR
      ENDIF
!
! EX-COMMON/CADJ/,/GENINF/ ETC.
      ALLOCATE(DADJUS(IXVAR),DAJNEW(IXVAR),IEQUAL(IXVAR),JEND(NPARAM),  &
     &         DEXTRE(IXVAR),DACCUR(IXVAR),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'MINIM0: ALLOCATION FAILS FOR DADJUS,DAJNEW ETC.'
        NF=0
        GO TO 900
      ENDIF
!
! EX-COMMON/CALAN/
      IF(BALAN)THEN
        ALLOCATE(DALAN(IXVAR),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM0: ALLOCATION FAILS FOR DALAN'
          NF=0
          GO TO 900
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
! IWGHT CONTROLS THE WEIGHTING OF THE ENERGY FUNCTIONAL:
!       .EQ. 1  FOR AS UNIT WEIGHTED (ARITHMETIC) MEAN (DEFAULT)
!       .EQ. 2  FOR ORIGINAL (SS) STATISTICAL WEIGHTED MEAN.
!       .LT. 0  AND FORMS ARITHMETIC MEAN OF THE CONFIGURATION
!               WEIGHTED-MEANS.
!               (-11,-22 FLAGS WRITE TO TERMS/LEVELS - NOT RECOMMENDED)
!
      IWGHT0=IWGHT/10
      IF(IWGHT0.NE.0)IWGHT=IWGHT0
      IWGHT=MOD(IWGHT,ITHREE)
      IF(IWGHT.EQ.0)IWGHT=1
!
      DF0=DZERO                        !INITIALZE CORE FUNCTIONAL ENERGY
!
! OPTIONALLY READ USER WEIGHTS (WGHT) AND T-INDEXING (INDEXW).
! N.B. IF INDEXW.LT.0 THEN WGHT CONTAINS OBSERVED ENERGIES RELATIVE TO
! THE GROUND IN /CM - THIS IS HISTORIC SS OPTION.
!
!      IF(INCLUD.GE.-NTRMS)THEN        !OBSOLETE SKIP AS NO ISO RE-ENTRY
!
      IF(INCLUD.LT.0)THEN
!
        NEXTRE=-INCLUD
!
! EX-COMMON/WEIGHT/
        ALLOCATE(INDEXW(NEXTRE),WGHT(NEXTRE),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM0: ALLOCATION FAILS FOR INDEXW,WGHT'
          NF=0
          GO TO 900
        ENDIF
!
        READ(MR5,*)(INDEXW(I),WGHT(I),I=1,NEXTRE)
!
        IFLAGW=0
        DO I=1,NEXTRE
          IF(IFLAGW.EQ.0)IFLAGW=INDEXW(I)
          IF(INDEXW(I)*IFLAGW.LT.0)THEN
            WRITE(MW6,*)                                                &
     &     'MINIM0: ALL WEIGHTING INDEXES MUST BE POSITIVE OR NEGATIVE:'&
     &     ,I,INDEXW(I)
            WRITE(MW0,*)                                                &
     &      'MINIM0: ALL WEIGHTING INDEXES MUST BE POSITIVE OR NEGATIVE'
            GO TO 1100
          ELSEIF(INDEXW(I).EQ.0.AND.IFLAGW.GT.0)THEN
            WRITE(MW6,*)                                                &
     &                 'MINIM0: ALL WEIGHTING INDEXES MUST BE POSITIVE:'&
     &                 ,I,INDEXW(I)
            WRITE(MW0,*)'MINIM0: ALL WEIGHTING INDEXES MUST BE POSITIVE'
            GO TO 1100
          ENDIF
        ENDDO
!
        IF(IFLAGW.LE.0.AND.(ISHFTLS.NE.0.OR.ISHFTIC.NE.0))THEN
          WRITE(MW6,*)                                                  &
     & 'MINIM0: CANNOT MIX ISHFTLS/IC.NE.0 WITH A NEGATIVE WEIGHT INDEX'
          WRITE(MW0,*)                                                  &
     & 'MINIM0: CANNOT MIX ISHFTLS/IC.NE.0 WITH A NEGATIVE WEIGHT INDEX'
          GO TO 1100
        ENDIF
!
      ENDIF
!
!      ENDIF
!
! SWITCH-OFF MINIM0IZATION FOR RELATIVISTIC RADIAL FUNCTIONS
!
!      IF(BREL.AND.INCLUD.NE.0)THEN
!        WRITE(MW6,692)
!  692   FORMAT('***SR.MINIM0 RESETS INCLUD=0 BECAUSE RELATIVISTIC'
!     &,' ORBITALS ARE IN USE')
!        WRITE(MW0,*)' NO MINIM0IZATION BECAUSE RELATIVISTIC ORBITALS'
!     &,' ARE IN USE!'
!        INCLUD=0
!      ENDIF
!
!-----------------------------------------------------------------------
!
! NOW READ FURTHER INPUT, DEPENDING ON USER FLAGGING VIZ.
! SCALING, SCREENING, VARIATIONAL & RELATED  PARAMETERS,
! ENERGY CORRECTIONS, PLASMA TEMP/DENSITY ETC.
!
!-----------------------------------------------------------------------
!
! DEXTRE PROVIDES (INITIAL) DATA FOR DADJUS(I),I=1,NPARAM, THE S.M/STO
! POTENTIAL SCALING PARAMETERS (L- OR NL-DEPENDENT), SEE SR.CALCFX.
! DEXTRE(MIN(I,NEXTRE)) WILL BE ASSIGNED TO DADJUS(I) UNLESS
! REDIRECTED BY IEQUAL; DEXTRE RETAINS ANY PREVIOUS VALUES ELSE.
!
      DO I=1,IXVAR
        DADJUS(I)=DZERO
        DAJNEW(I)=DEFLAM    !DEFAULT SCALING PARAMETERS FOR EACH ORBITAL
        DEXTRE(I)=DEFLAM    !               DITTO
      ENDDO
!
      NVAR0=NVAR
      NVAR=NVAR0+NVARD+NVARQ
      NLAMDQ=ABS(NLAMD)+ABS(NLAMQ)
      NLAM=NLAM+NLAMDQ
!
      IF(NLAM.NE.0)MEXTRE=NLAM          !NLAM TAKES PRIORITY OVER MEXTRE
      NEXTRE=MOD(ABS(MEXTRE)-NLAMDQ,I10000)   !NO OF SCALING PARAMETERS
      IF(MEXTRE.EQ.0)NEXTRE=NPARAM             !DEFAULT IF NOT SPECIFIED
!
      IF(MEXTRE.LE.0)THEN
        IF(NVAR.GT.0)GO TO 300
        GO TO 400
      ENDIF
!
! NON-UNIQUE BASIS LAMBDAS DEFAULT TO UNITY, ** NOT ** PREVIOUS VALUE IF
! DEXTRE NOT SPECIFIED (UNLESS GLOBAL INPUT SPECIFIED - SEE IDUM0.LT.0)
! EXCEPTING RYD/CONT IF AT LEAST ONE RYD/CONT HAS BEEN DEFINED.
!
      ALLOCATE(DBUF(IXVAR),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'MINIM0: ALLOCATION FAILS FOR DBUF'
        NF=0
        GO TO 900
      ENDIF
!
! HOLD LAMBDAS IN DBUF THEN ASSIGN TO DEXTRE ONCE WE HAVE (ANY) ORBITALS
! TO BE VARIED (IEQUAL), HELD IN IBUF.
!
      IF(IEQ(0).NE.0)THEN                        !***NON-UNIQUE BASIS***
!
        IF(IPOLFN.LT.0)THEN
          WRITE(MW6,*)'*** SR.MINIM0: CANNOT USE PERTURBED TF POT WITH',&
     &                ' RELAXED ORBITAL BASIS'
          WRITE(MW0,*)'***CANNOT USE RELAXED ORBITALS WITH PERTURBED TF'
          GO TO 1100
        ENDIF
        IF(NVAR.EQ.0.AND.INCLUD.NE.0)THEN
          WRITE(MW6,*)'*** SR.MINIM0: INCLUD=',INCLUD,' BUT NVAR=0.',   &
     &            ' RE-SETTING INCLUD=0, ELSE SPECIFY NVAR TO OPTIMIZE.'
          WRITE(MW0,*)'***INCLUD NE.0 BUT NVAR=0 !'
          INCLUD=0
        ENDIF
!
        WRITE(MW6,*)                                                    &
     &        'NOTE: RELAXED LAMBDAS DEFAULT TO UNITY, *NOT* LAST READ.'
        WRITE(MW0,*)                                                    &
     &        'NOTE: RELAXED LAMBDAS DEFAULT TO UNITY, *NOT* LAST READ.'
!
        DO I=1,IXVAR
          DBUF(I)=DZERO
        ENDDO
!
        DO N=1,NEXTRE                          !NEXTRE SETS
!
          READ(MR5,*)K,IDUM0                   !CF/GRP AND NO. OF VALUES
!
          IF(IDUM0.EQ.0)GO TO 220
!
          IDMIN=ABS(IDUM0)
!
          ALLOCATE(DUM(IDMIN))
!
          IF(K.EQ.0)THEN                       !CORE/GLOBAL
!
            IF(IDUM0.GT.0)THEN
!
              IF(IRLX.GE.0)THEN                !COMMON CORE
!
                READ(MR5,*)(DUM(I),I=1,IDUM0)
!
                I1=MIN(IDUM0,MB)
                DO I=1,I1
                  DBUF(I)=DUM(I)
                ENDDO
!
              ELSE                             !SO IEQ(0).GT.0
!
                WRITE(MW6,*)'*** ERROR: GROUP=0 (COMMON CORE ORBITALS) '&
     &                      ,                                           &
     &                     'CONFLICTS WITH NON-UNIQUE FLAG (KCOR1.LT.0)'
                WRITE(MW0,*)'*** ERROR: GROUP=0 (COMMON CORE ORBITALS) '&
     &                      ,                                           &
     &                     'CONFLICTS WITH NON-UNIQUE FLAG (KCOR1.LT.0)'
                GO TO 1100
!
              ENDIF
!
            ELSE                               !GLOBAL
!
              READ(MR5,*)(DUM(I),I=1,-IDUM0)
!
              IF(IEQ(0).LT.0)THEN
                IB=KMAX*MXBORB+MB
              ELSE
                IB=NGRP*MXBORB+MB0
              ENDIF
!
              DO I=1,IB                        !ALL BOUND USE
                DBUF(I)=DUM(1)                 !POSITION ONE
              ENDDO
!
              IF(IDUM0.LT.-1)THEN              !ALL RYD/CONT
                DO I=IB+1,NPARAM               !USE
                  DBUF(I)=DUM(2)               !POSITION TWO
                ENDDO
              ENDIF
!
            ENDIF
!
          ELSE                                 !CF/GRP SPECIFIC
!
            READ(MR5,*)(DUM(I),I=1,IDMIN)
!
            IF(IEQ(0).GT.0.AND.K.GT.NGRP)GO TO 220               !IGNORE
            IF(IEQ(0).LT.0.AND.K.GT.KMAX)GO TO 220               !IGNORE
!
            IB=MIN(IDMIN,MXBORB)
            KK=MXBORB*(K-1)+MB0
            DO I=1,IB
              II=KK+I
              DBUF(II)=DUM(I)
            ENDDO
!
            IF(IDUM0.LT.0)THEN
              IDUM0=-IDUM0
              DO I=IB+1,MXBORB
                II=KK+I
                DBUF(II)=DUM(IDUM0)
              ENDDO
            ENDIF
!
            IF(IDUM0.GT.MXBORB)THEN
!
              IF(IEQ(0).LT.0)THEN
!
                IF(.NOT.BDR)THEN
                  II=KMAX*MXBORB+K+MB   !CONT
                ELSE
                  II=KMAX*MXBORB+K+MB   !VALENCE
                  IF(QN(QCG(NF,K)).GE.90)II=II+KMAX  !CONT
                ENDIF
                I0=MXBORB+1    !RYD/CONT LAMBDA IN FIRST POS AFTER BOUND
                DBUF(II)=DUM(I0)  !SINCE ONLY ONE PER CFG IN GENERAL...
!
              ELSE
!
                I0=MXBORB
                IF(MXVORB.GT.0)THEN
                  KK=I0*(NGRP-1)+MXVORB*(K-1)+MB0
                  I0=I0+MXVORB
                  i0=min(i0+kk,ixvar)-kk   !ixvar is truncated to exist
                  IB=MIN(IDUM0,I0)
                  DO I=MXBORB+1,IB
                    II=KK+I
                    DBUF(II)=DUM(I)
                  ENDDO
                  IF(IDUM0.LT.I0)THEN      !CASE MULTIPLE RYD, COPY LAST
                    DO I=IDUM0+1,I0
                      II=KK+I
                      DBUF(II)=DUM(IDUM0)
                    ENDDO
                  ENDIF
                ENDIF
!
                IF(MXFORB.GT.0)THEN
                  KK=I0*(NGRP-1)+MXFORB*(K-1)+MB0
                  I0=I0+MXFORB
                  i0=min(i0+kk,ixvar)-kk   !ixvar is truncated to exist
                  IB=MIN(IDUM0,I0)
                  DO I=MXBORB+MXVORB+1,IB
                    II=KK+I
                    DBUF(II)=DUM(I)
                  ENDDO
                  IF(IDUM0.LT.I0)THEN      !COPY LAST RYD/CONT
                    DO I=IDUM0+1,I0
                      II=KK+I
                      DBUF(II)=DUM(IDUM0)
                    ENDDO
                  ENDIF
                ENDIF
!
              ENDIF
!
            ENDIF
!
          ENDIF
!
  220     IF(ALLOCATED(DUM))DEALLOCATE(DUM)
!
        ENDDO
!
        NEXTRE=MXORB
        MEXTRE=MXORB
!
      ELSE                                           !***UNIQUE BASIS***
!
        IF(NEXTRE.GT.0)THEN
!
          ALLOCATE(DUM(NEXTRE))
!
          READ(MR5,*)(DUM(I),I=1,NEXTRE)
!
          IF(NEXTRE.GT.NPARAM+idw)THEN
            WRITE(MW6,*)'SR.MINIM0: THERE ARE MORE LAMBDAS THAN ',      &
     &                  'ORBITALS REDUCING FROM/TO:',NEXTRE,NPARAM+idw
!           WRITE(MW0,*)'SR.MINIM0:THERE ARE MORE LAMBDAS THAN ORBITALS'
            NEXTRE=NPARAM+idw
          ENDIF
!
          IF(NEXTRE.GT.NPARAM)THEN           !SO idw=1
            DLAMX=DUM(NEXTRE)                !TRANSFER DW LAMDA DIRECTLY
            NEXTRE=NPARAM
          ENDIF
!
          DO I=1,NEXTRE
            DBUF(I)=DUM(I)
          ENDDO
!
          DEALLOCATE(DUM)
!
        ENDIF
!
        IF(ISCALR.GT.0)THEN            !PROCESS SLATER SCALING PARAMETER
!
          IF(ISCALR.GT.IXVAR)THEN                !SHOULD NOT HAPPEN NOW?
            STOP '*** NEED AT LEAST IXVAR=ISCALR'
          ENDIF
!
          IF(ABS(SCALER-DONE).GT.D1M5)THEN       !SCALER-> DBUF
            IF(ISCALR.LE.NEXTRE)THEN             !FLAG
              IF(ABS(DBUF(ISCALR)-DONE).GT.D1M5)THEN
                WRITE(MW6,*)'*** SLATER SCALING SPECIFIED TWICE! USING '&
     &                      ,SCALER
                WRITE(MW0,*)'*** SLATER SCALING SPECIFIED TWICE!'
              ENDIF
            ENDIF
            DBUF(ISCALR)=SCALER
!          ELSEIF(ISCALR.LE.NEXTRE)THEN    !DBUF->SCALER, FOR NON-CALCFX
!            SCALER=DBUF(ISCALR)
          ENDIF
!
          IF(NEXTRE.LT.0)THEN
            WRITE(MW6,10310)NEXTRE,ISCALR
            WRITE(MW0,*)                                                &
     &                'SR.MINIM0: CANNOT USE NLAM.LT.0 WITH ISCALR.GT.0'
            GO TO 1100
          ENDIF
!
          DO I=NEXTRE+1,ISCALR-1
            DBUF(I)=DZERO
          ENDDO
          NEXTRE=MAX(NEXTRE,ISCALR)
!
        ENDIF
!
        IF(IPOLFN.LT.0)THEN
!
          IF(NLAMD.NE.0)THEN
!
            IF(NLAMD.LT.0)THEN
              WRITE(MW6,*)                                              &
     &         "INPUT DIPOLE PERTURBTN LAMBDA'S TAKEN RELATIVE TO UNITY"&
     &         ,"OUTPUT RELATIVE TO ZERO STILL"
              WRITE(MW0,*)                                              &
     &         "INPUT DIPOLE PERTURBTN LAMBDA'S TAKEN RELATIVE TO UNITY"
              NLAMD=-NLAMD
              TADD=DZERO                       !=0 FOR I/O RELATIVE TO 1
            ELSE
              TADD=DONE                        !=1 FOR I/O RELATIVE TO 0
            ENDIF
!
            ALLOCATE(DUM(NLAMD))
!
            READ(MR5,*)(DUM(I),I=1,NLAMD)
!
            IF(NLAMD.GT.NPARAM+idw)THEN
              IF(NF.GT.0)WRITE(MW6,10220)NLAMD,NPARAM+idw
              NLAMD=NPARAM+idw
            ENDIF
!
            IF(NLAMD.GT.NPARAM)THEN          !SO idw=1
              DLAMDX=DUM(NLAMD)+TADD         !TRANSFER DW LAMDA DIRECTLY
              NLAMD=NPARAM
            ENDIF
!
            DO I=1,NLAMD
              I1=NPARAM+I
              DBUF(I1)=DUM(I)+TADD
            ENDDO
!
            DEALLOCATE(DUM)
!
          ENDIF
!
          IF(NLAMQ.NE.0)THEN
!
            IF(NLAMQ.LT.0)THEN
              WRITE(MW6,*)                                              &
     &     "INPUT QUADRUPOLE PERTURBTN LAMBDA'S TAKEN RELATIVE TO UNITY"&
     &     ,"OUTPUT RELATIVE TO ZERO STILL"
              WRITE(MW0,*)                                              &
     &     "INPUT QUADRUPOLE PERTURBTN LAMBDA'S TAKEN RELATIVE TO UNITY"
              NLAMQ=-NLAMQ
              TADD=DZERO                       !=0 FOR I/O RELATIVE TO 1
            ELSE
              TADD=DONE                        !=1 FOR I/O RELATIVE TO 0
            ENDIF
!
            ALLOCATE(DUM(NLAMQ))
!
            READ(MR5,*)(DUM(I),I=1,NLAMQ)
!
            IF(NLAMQ.GT.NPARAM+idw)THEN
              IF(NF.GT.0)WRITE(MW6,10220)NLAMQ,NPARAM+idw
              NLAMQ=NPARAM+idw
            ENDIF
!
            IF(NLAMQ.GT.NPARAM)THEN          !SO idw=1
              DLAMQX=DUM(NLAMQ)+TADD         !TRANSFER DW LAMDA DIRECTLY
              NLAMQ=NPARAM
            ENDIF
!
            DO I=1,NLAMQ
              I2=NPARM2+I
              DBUF(I2)=DUM(I)+TADD
            ENDDO
!
            DEALLOCATE(DUM)
!
          ENDIF
!
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! READ ORBITALS TO BE VARIED DIRECTLY - SIMPLER THAN HISTORIC INPUT
! (AND RE-ENTRY POINT IF NO INITIAL LAMBDAS READ)
!
!-----------------------------------------------------------------------
!
  300 IF(NVAR.GT.0)THEN
!
        ALLOCATE(IBUF(IXVAR),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM: ALLOCATION FAILS FOR IBUF'
          NF=0
          GO TO 900
        ENDIF
!
        IFABS=0
        IF(IEQ(0).NE.0)THEN                      !***NON-UNIQUE BASIS***
!
          K0=-1
          II=0
          I0=II
          DO N=1,NVAR               !NVAR SETS
!
            READ(MR5,*)K,IDUM0      !CF/GRP AND NO. OF VALUES TO READ
!
            IF(IDUM0.LE.0)GO TO 310
!
            ALLOCATE(IDUM(IDUM0))
!
            IF(K.LE.K0)THEN
              WRITE(MW6,*)'***ERROR: INPUT NVAR SETS IN INCREASING ',   &
     &                    'CF/GRP ORDER, NOT:',K0,K
              WRITE(MW0,*)'***ERROR: INPUT NVAR SETS IN INCREASING ',   &
     &                    'CF/GRP ORDER'
              GO TO 1100
            ENDIF
!
            IF(K.EQ.0)THEN
!
              IF(IRLX.GE.0)THEN                   !COMMON CORE
!
                READ(MR5,*)(IDUM(I),I=1,IDUM0)
!
                I1=MIN(IDUM0,MB)
                DO I=1,I1
                  IBUF(I)=IDUM(I)
                ENDDO
!
              ELSE                                !SO IEQ(0).GT.0
!
                WRITE(MW6,*)'*** ERROR: GROUP=0 (COMMON CORE ORBITALS) '&
     &                      ,                                           &
     &                     'CONFLICTS WITH NON-UNIQUE FLAG (KCOR1.LT.0)'
                WRITE(MW0,*)'*** ERROR: GROUP=0 (COMMON CORE ORBITALS) '&
     &                      ,                                           &
     &                     'CONFLICTS WITH NON-UNIQUE FLAG (KCOR1.LT.0)'
                GO TO 1100
!
              ENDIF
!
              II=I1
              I0=II
!
            ELSE
!
              READ(MR5,*)(IDUM(I),I=1,IDUM0)
!
              IF(IDUM0.GT.NPARAM)THEN
                WRITE(MW6,*)'***SR.MINIM0: CANNOT INPUT MORE VALUES TO',&
     &                ' VARY THAN THERE ARE ORBITALS, REDUCING FROM/TO:'&
     &                ,IDUM0,NPARAM
                WRITE(MW0,*)'***SR.MINIM0: CANNOT INPUT MORE VALUES TO',&
     &                ' VARY THAN THERE ARE ORBITALS, REDUCING INPUT...'
                IDUM0=NPARAM+idw
              ENDIF
!
              IF(IEQ(0).GT.0)KTEST=NGRP
              IF(IEQ(0).LT.0)KTEST=KMAX
              IF(K.LE.KTEST)THEN
                KK=MXBORB*(K-1)+MB0               !ASSUME VAL ORB NO. IN
                DO I=1,IDUM0
                  IF(IDUM(I).GT.MXBORB)IFABS=1    !FLAG ABSOLUTE
                  II=II+1
                  IBUF(II)=KK+IDUM(I)
                ENDDO
!             ELSE                                !IGNORE
              ENDIF
!
            ENDIF
!
  310       IF(ALLOCATED(IDUM))DEALLOCATE(IDUM)
!
          ENDDO
!                                         THIS WON'T CATCH EVERYTHING...
          IF(IFABS.EQ.1)THEN                      !-MB IF ABS ORB NO. IN
            WRITE(MW0,*)' *** DEFAULT RELAXED ORBITAL INDEX IS RELATIVE'&
     &                  ,                                               &
     &                ' TO THE CLOSED-SHELL CORE, I.E. A VALENCE INDEX;'&
     &                ,' CONVERTING YOUR ABSOLUTE INDEX INPUT...'
            WRITE(MW0,*)' *** THIS WILL NOT ALWAYS BE CAUGHT!!!'
            DO I=I0+1,II
              IBUF(I)=IBUF(I)-MB
            ENDDO
          ENDIF
!
          NVAR=II
          NVAR0=NVAR
!
        ELSE                                         !***UNIQUE BASIS***
!
          IF(NVAR0.GT.0)THEN
!
            ALLOCATE(IDUM(NVAR0))
!
            READ(MR5,*)(IDUM(I),I=1,NVAR0)
!
            IF(NVAR0.GT.NPARAM)THEN
              WRITE(MW6,*)'***SR.MINIM0: CANNOT INPUT MORE VALUES TO ', &
     &                 'VARY THAN THERE ARE ORBITALS, REDUCING FROM/TO:'&
     &                 ,NVAR0,NPARAM
              WRITE(MW0,*)'***SR.MINIM0: CANNOT INPUT MORE VALUES TO ', &
     &                 'VARY THAN THERE ARE ORBITALS, REDUCING INPUT...'
              NVAR0=NPARAM
            ENDIF
!
            DO I=1,NVAR0
              IBUF(I)=IDUM(I)
            ENDDO
!
            DEALLOCATE(IDUM)
!
          ENDIF
!
          NVAR=NVAR0
!
          IF(NVARD.GT.0)THEN
!
            ALLOCATE(IDUM(NVARD))
!
            READ(MR5,*)(IDUM(I),I=1,NVARD)
!
            IF(NVARD.GT.NPARAM)THEN
              WRITE(MW6,*)'***SR.MINIM0: CANNOT INPUT MORE VALUES TO ', &
     &                 'VARY THAN THERE ARE ORBITALS, REDUCING FROM/TO:'&
     &                 ,NVARD,NPARAM
              WRITE(MW0,*)'***SR.MINIM0: CANNOT INPUT MORE VALUES TO ', &
     &                 'VARY THAN THERE ARE ORBITALS, REDUCING INPUT...'
              NVARD=NPARAM
            ENDIF
!
            DO I=1,NVARD
              IBUF(NVAR+I)=IDUM(I)+NPARAM
            ENDDO
            NVAR=NVAR+NVARD
            if(nlamd.eq.0)nlamd=1   !need non-zero for set-up
!
            DEALLOCATE(IDUM)
!
          ENDIF
!
          IF(NVARQ.GT.0)THEN
!
            ALLOCATE(IDUM(NVARQ))
!
            READ(MR5,*)(IDUM(I),I=1,NVARQ)
!
            IF(NVARQ.GT.NPARAM)THEN
              WRITE(MW6,*)'***SR.MINIM0: CANNOT INPUT MORE VALUES TO ', &
     &                 'VARY THAN THERE ARE ORBITALS, REDUCING FROM/TO:'&
     &                 ,NVARQ,NPARAM
              WRITE(MW0,*)'***SR.MINIM0: CANNOT INPUT MORE VALUES TO ', &
     &                 'VARY THAN THERE ARE ORBITALS, REDUCING INPUT...'
              NVARQ=NPARAM
            ENDIF
!
            DO I=1,NVARQ
              IBUF(NVAR+I)=IDUM(I)+NPARM2
            ENDDO
            NVAR=NVAR+NVARQ
            if(nlamq.eq.0)nlamq=1   !need non-zero for set-up
!
            DEALLOCATE(IDUM)
!
          ENDIF
!
        ENDIF
!
        IF(INCLUD.EQ.0)THEN
          NVAR0=0
          NVAR=0
          NVARD=0
          NVARQ=0
        ENDIF
!
      ENDIF
!
      IF(NVAR.GT.0)THEN
!
        IBF0=0
        DO K=1,NVAR
!
          II=IBUF(K)
          IF(K.GT.NVAR0)II=II-NPARAM
          IF(K.GT.NVAR0+NVARD)II=II-NPARAM
!
          IF(DEY(II).EQ.DZERO)THEN
            WRITE(MW6,10200)II
            WRITE(MW0,*)'***ERROR, ORBITAL TO BE VARIED DOES NOT EXIST!'
            GO TO 1100
          ENDIF
!
          IF(IBUF(K).LE.IBF0)THEN
            WRITE(MW6,10300)(IBUF(L),L=1,NVAR)
            WRITE(MW0,*)                                                &
     &     '***ERROR, VARIATIONAL PARAMETERS MUST BE IN ASCENDING ORDER'
            GO TO 1100
          ENDIF
!
          IBF0=mod(IBUF(K)-1,nparam)+1
          IF(IBF0.GT.nparam)THEN
            WRITE(MW6,10290)K,IBF0,nparam
            WRITE(MW0,*)                                                &
     &         '***ERROR, INCONSISTENT VARIATIONAL & SCALING PARAMETERS'
            GO TO 1100
          ENDIF
          IBF0=IBUF(K)
!
          IF(IBUF(K).EQ.ISCALR)BSCALR=.TRUE.
!
        ENDDO
!
        IM=NPARM3-NVAR
        IF(IM.GT.0)THEN
          J=0
          DO I=1,IM
            J=J+1
            DO K=1,NVAR
              IF(IBUF(K).EQ.J)J=J+1      !THIS IS WHY WE NEED ASCENDING
            ENDDO
            IBUF(I+NVAR)=J
          ENDDO
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! RE-ENTRY POINT IF NO LAMDA OR VARIATIONAL PARAMETERS ARE READ/ASSIGNED
! BUT READ ANY USER-SPECIFIED IEQUAL INFO, EVEN THOUGH CANNOT BE USED.
!
  400 CONTINUE
!
      T=DONE
      NLAM=NEXTRE
      I0=0
      IM=NPARM3-NVAR
!
  500 CONTINUE
!      MEND=0
      DO I=1,NPARAM                      !NPARM3 - NOW LOOP BACK-UP X2
        IP=I0+I
        JEND(I)=1
        IEQUAL(IP)=NLAM                  !HOLD LAST
        J=IP
        IF(NVAR*IM.GT.0)J=IBUF(IP)
        IF(J.GT.NLAM)THEN                !USE LAST HELD
          IF(MEXTRE.LT.0)GO TO 600
        ELSE
          IEQUAL(IP)=IP
          IF(MEXTRE.GT.0)THEN
            DEXTRE(IP)=DBUF(J)           !<---------------LAMDA ASSIGNED
            IF(DEXTRE(IP).EQ.DZERO)DEXTRE(IP)=T
            IF(IEQ(0).eq.0)T=DEXTRE(IP)
          ENDIF
        ENDIF
!        write(mw6,*)i,iequal(ip),dextre(ip),dbuf(j)
        IF(MEXTRE.GE.0)DADJUS(IP)=DZERO
  600 ENDDO
!
      IF(NLAMD.GT.0)THEN
        NLAM=NPARAM+NLAMD
        NLAMD=-NLAMD
        I0=NPARAM
        GO TO 500
      ENDIF
!
      IF(NLAMQ.GT.0)THEN
        NLAM=NPARM2+NLAMQ
        NLAMQ=-NLAMQ
        I0=NPARAM*2
        GO TO 500
      ENDIF
!
      NLAMD=ABS(NLAMD)
      NLAMQ=ABS(NLAMQ)
!
      NVAR=NVAR0+NVARD+NVARQ
      NLAM=NEXTRE
!
      IF(NVAR.GT.0)THEN
        DO I=1,NPARM3
          DO J=1,NPARM3
            IF(IBUF(J).EQ.I)IEQUAL(I)=J  !<----------------VARY ASSIGNED
          ENDDO
        ENDDO
      ENDIF
!
      IF(ALLOCATED(IBUF))THEN
        DEALLOCATE(IBUF,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM0: DE-ALLOCATION FAILS FOR IBUF'
          NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(DBUF))THEN
        DEALLOCATE(DBUF,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM0: DE-ALLOCATION FAILS FOR DBUF'
          NF=0
        ENDIF
      ENDIF
!
      IF(NF.EQ.0)GO TO 900
!
!-----------------------------------------------------------------------
!
! INSTEAD OF READING IEQUAL DIRECTLY (SEE BELOW), READ WHICH SCALING
! PARAMETER IS TO BE USED BY EACH L- OR NL-DEPENDENT POTENTIAL.
! THE DEFAULT IS 1,2,3,4,5,6,7 ETC. OBVIOUSLY, THIS IS ONLY NECESSARY
! WHEN MINIM0IZATION IS BEING CARRIED-OUT AND YOU WANT TO TIE ONE OR
! MORE POTENTIALS TO ONE OR MORE OF THOSE BEING VARIED. (IF NOT MINI-
! MIZING THEN YOU CAN TRIVIALLY SET THE LAMBDAS THE SAME.)
! TBD: READ NFIXD, NFIXQ FOR PERTURBED TF, ELSE NEED ABSOLUTE POSITION.
!
      IF(NFIX.GT.0)THEN
!
        IF(IPOLFN.LT.0)THEN  !COULD USE IF USER INPUTS ABSOLUTE INDEX...
          WRITE(MW6,*)"***ERROR: CANNOT USE NFIX.GT.0 WITH PERTURBED TF"
          WRITE(MW0,*)"***ERROR: CANNOT USE NFIX.GT.0 WITH PERTURBED TF"
          GO TO 1100
        ENDIF
!
        IF(IEQ(0).NE.0)THEN                      !***NON-UNIQUE BASIS***
!
          NFIX0=NFIX
          DO N=1,NFIX0
!
            READ(MR5,*)K,IDUM0
!
            IF(IDUM0.LE.0)GO TO 650
!
            ALLOCATE(IDUM(IDUM0))
!
            IF(K.EQ.0)THEN
!
              IF(IRLX.GE.0)THEN                   !COMMON CORE
!
                READ(MR5,*)(IDUM(I),I=1,IDUM0)
!
                NFIX=MIN(MB,IDUM0)
!
              ELSE                                !SO IEQ(0).GT.0
!
                WRITE(MW6,*)'*** ERROR: GROUP=0 (COMMON CORE ORBITALS) '&
     &                      ,                                           &
     &                     'CONFLICTS WITH NON-UNIQUE FLAG (KCOR1.LT.0)'
                WRITE(MW0,*)'*** ERROR: GROUP=0 (COMMON CORE ORBITALS) '&
     &                      ,                                           &
     &                     'CONFLICTS WITH NON-UNIQUE FLAG (KCOR1.LT.0)'
                GO TO 1100
!
              ENDIF
!
            ELSE
!
              WRITE(MW6,*)"***ERROR:CANNOT USE VALENCE NFIX.GT.0 WITH", &
     &                    " BASIS='S/RLX'"
              WRITE(MW0,*)"***ERROR:CANNOT USE VALENCE NFIX.GT.0 WITH", &
     &                    " BASIS='S/RLX'"
              GO TO 1100
!
            ENDIF
!
          ENDDO
!
        ELSE                                         !***UNIQUE BASIS***
!
          ALLOCATE(IDUM(NFIX))
!
          READ(MR5,*)(IDUM(I),I=1,NFIX)
!
        ENDIF
!
        IF(INCLUD.NE.0)THEN                       !SET MAPPING
          NFIX=MIN(NFIX,NPARAM)                   !FOR IEQUAL
          DO I=1,NFIX
            ID=IDUM(I)
            IF(ID.GT.0.AND.ID.LE.NPARAM)THEN
              IE=IEQUAL(I)
              IF(IE.NE.IEQUAL(ID).AND.IE.LE.NVAR)THEN
                WRITE(MW6,*)'*** ERROR SR.MINIM0: YOU CANNOT FIX AN',   &
     &                      ' NVAR PARAMETER',I,ID
                WRITE(MW0,*)'*** ERROR SR.MINIM0: YOU CANNOT FIX AN',   &
     &                      ' NVAR PARAMETER'
                DEALLOCATE(IDUM)
                GO TO 1100
              ELSE
                IEQUAL(I)=IEQUAL(ID)
              ENDIF
            ENDIF
          ENDDO
!
        ELSE             !AS DANGEROUS IF NFIX INCONSISTENT WITH LAMBDAS
          WRITE(MW6,*)'*** SR.MINIM0: IGNORING NFIX AS INCLUD=0,',      &
     &                ' USING USER/DEFAULT LAMBDAS'
          WRITE(MW0,*)'*** SR.MINIM0: IGNORING NFIX AS INCLUD=0,',      &
     &                ' USING USER/DEFAULT LAMBDAS'
        ENDIF
!
  650   IF(ALLOCATED(IDUM))DEALLOCATE(IDUM)
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! REDUCE NEXTRE IF NECESS.
!
      IF(NEXTRE.GT.NPARAM+idw)THEN
        IF(NF.GT.0)WRITE(MW6,10220)NEXTRE,NPARAM
        NEXTRE=NPARAM
      ENDIF
!
! INITIALZE IF OLD STYLE NEXTRE
!
      IF(INCLUD.NE.0.AND.NVAR.EQ.0)NVAR=NEXTRE
!
!-----------------------------------------------------------------------
!
! SET IEQUAL RANGE
!
!
      IF(ABS(MEXTRE).GE.10000)THEN  !HISTORIC SS |MEXTRE|.GE.100 OPTION
        IF(IEQ(0).NE.0)THEN
          WRITE(MW6,*)"***ERROR: CANNOT USE THIS NLAM/MEXTRE WITH",     &
     &                " BASIS='S/RLX'",MEXTRE
          WRITE(MW0,*)"***ERROR: CANNOT USE THIS NLAM/MEXTRE WITH",     &
     &                " BASIS='S/RLX'"
          GO TO 1100
        ENDIF
        IF(IPOLFN.LT.0)THEN
          WRITE(MW6,*)"***ERROR: CANNOT USE THIS NLAM/MEXTRE WITH",     &
     &                " PERTURBED TF POTENTIAL",MEXTRE
          WRITE(MW0,*)"***ERROR: CANNOT USE THIS NLAM/MEXTRE WITH",     &
     &                " PERTURBED TF"
          GO TO 1100
        ENDIF
!
! IEQUAL(I)=J FIXES THAT SCALING FACTOR DADJUS(I), FOR L=I-1, EQUAL
! TO VARIATIONAL PARAMETER DEXTRE(J). SUPPOSE THE SAME POTENTIAL IS
! WANTED FOR P,D AND F ELECTRONS BUT A DIFFERENT POTENTIAL FOR S:
! PUT IEQUAL(1)=1,IEQUAL(2)=IEQUAL(3)=IEQUAL(4)=2.
! THE DIFFICULTY WITH THIS HISTORIC INPUT ARISES WHEN YOU WANT TO FIX/
! VARY OUTER ORBITALS BUT LEAVE INNER ONES AT A PREVIOUSLY DETERMINED
! VALUE. THEN IT IS CUMBERSOME AT BEST TO MAP TO THE INTERNAL ORDER.
! BEST USE NFIX ABOVE SINCE IT IS ALL RELATIVE TO THE EXTERNAL ORDER.
!
        DO I=1,IXVAR
          IEQUAL(I)=0
        ENDDO
!
        READ(MR5,*)(IEQUAL(I),I=1,NPARAM)
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      IF(MEXTRE.LT.0)THEN
        IF(IPOLFN.LT.0)THEN
          WRITE(MW6,*)"***ERROR: CANNOT USE THIS NLAM/MEXTRE WITH",     &
     &                " POLARIZED TF POTENTIAL",MEXTRE
          WRITE(MW0,*)"***ERROR: CANNOT USE THIS NLAM/MEXTRE WITH",     &
     &                "POLARIZED TF"
          GO TO 1100
        ENDIF
        DO I=1,NEXTRE
          DO J=1,NPARAM
            IF(IEQUAL(J).EQ.I)DADJUS(J)=DZERO
          ENDDO
        ENDDO
      ENDIF
!
!-----------------------------------------------------------------------
!
! SCREEN RELATES TO THE EIGENVALUE E (IN RYDBERGS) OF THE ONE-
! PARTICLE FUNCTIONS THROUGH E=-(Z-SCREEN)**2/(N*N); N=PRINCIPAL
! QUANTUM NUMBER. A GOOD INITIAL VALUE OF SCREEN WILL SPEED UP THE
! COMPUTATION IN RADWAV. IF NO APPROXIMATION IS KNOWN USE STANDARD
! OPTION BY SKIPPING THIS "READ SCREEN" FOR 1S,2S,2P ETC.
!
!
      DO I=1,MXORB
        IF(DEY(I).NE.DZERO)THEN
          IF(QN(I).GE.Q70.AND.QN(I).LT.Q80.AND.I.LE.ABS(MPSEUD))DEY(I)  &
     &       =DZERO
          IF(QN(I).GE.Q90)SCREEN(I)=9999
        ENDIF
      ENDDO
!
      IF(MGRP.GT.0)THEN             !HISTORIC SCREENING INDEX NOT GROUP!
!
        ALLOCATE(DBUF(MXORB))
!
        IF(IEQ(0).NE.0)THEN                      !***NON-UNIQUE BASIS***
!
          DO I=1,MXORB
            DBUF(I)=DZERO
          ENDDO
!
          DO N=1,MGRP               !MGRP SETS
!
            READ(MR5,*)K,IDUM0      !CF/GRP AND NO. OF VALUES TO READ
!
            IF(IDUM0.LE.0)GO TO 660
!
            ALLOCATE(DUM(IDUM0))
!
            IF(K.EQ.0)THEN                        !CORE/GLOBAL
!
              IF(IRLX.GE.0)THEN                   !COMMON CORE
!
                READ(MR5,*)(DUM(I),I=1,IDUM0)
!
                I1=MIN(IDUM0,MB)
                DO I=1,I1
                  DBUF(I)=DUM(I)
                ENDDO
!
              ELSE                                !SO IEQ(0).GT.0
!
                WRITE(MW6,*)'*** ERROR: GROUP=0 (COMMON CORE ORBITALS) '&
     &                      ,                                           &
     &                     'CONFLICTS WITH NON-UNIQUE FLAG (KCOR1.LT.0)'
                WRITE(MW0,*)'*** ERROR: GROUP=0 (COMMON CORE ORBITALS) '&
     &                      ,                                           &
     &                     'CONFLICTS WITH NON-UNIQUE FLAG (KCOR1.LT.0)'
                GO TO 1100
!
              ENDIF
!
            ELSE                                  !CF/GRP SPECIFIC
!
              READ(MR5,*)(DUM(I),I=1,IDUM0)
!
              IF(IEQ(0).GT.0.AND.K.GT.NGRP)GO TO 660             !IGNORE
              IF(IEQ(0).LT.0.AND.K.GT.KMAX)GO TO 660             !IGNORE
!
              IB=MIN(IDUM0,MXBORB)
              KK=MXBORB*(K-1)+MB0
              DO I=1,IB
                II=KK+I
                DBUF(II)=DUM(I)
              ENDDO
!
              IF(IDUM0.GT.MXBORB)THEN
                IF(IEQ(0).LT.0)THEN
                  IF(.NOT.BDR)THEN
                    II=KMAX*MXBORB+K+MB   !CONT
                  ELSE
                    II=KMAX*MXBORB+K+MB   !VALENCE
                    IF(QN(QCG(NF,K)).GE.90)II=II+KMAX  !CONT
                  ENDIF
                  I0=MXBORB+1       !CONT SIGMA IN FIRST POS AFTER BOUND
                  DBUF(II)=DUM(I0)
                else      !"never" needed, else "copy" lambda assignment
                  write(mw6,*)                                          &
     &                   'cannot assign group specific ryd/cont screens'
                  write(mw0,*)                                          &
     &                   'cannot assign group specific ryd/cont screens'
                ENDIF
              ENDIF
!
            ENDIF
!
  660       IF(ALLOCATED(DUM))DEALLOCATE(DUM)
!
          ENDDO
          MGRP=MXORB
!
        ELSE                                         !***UNIQUE BASIS***
!
          ALLOCATE(DUM(MGRP))
!
          READ(MR5,*)(DUM(I),I=1,MGRP)
!
          IF(MGRP.GT.MXORB)THEN
            WRITE(MW6,*)'SR.MINIM0: THERE ARE MORE SCREENS THAN ',      &
     &                  'ORBITALS REDUCING FROM/TO:',MGRP,MXORB
!           WRITE(MW0,*)'SR.MINIM0:THERE ARE MORE SCREENS THAN ORBITALS'
            MGRP=MXORB
          ENDIF
!
          DO I=1,MGRP
            DBUF(I)=DUM(I)
          ENDDO
!
          DEALLOCATE(DUM)
!
        ENDIF
!
        DO I=1,MGRP
          IF(DBUF(I).NE.DZERO)THEN
            IF(MGRP0.LT.0.AND.ABS(DBUF(I)).LT.999)THEN
              DBUF(I)=DBUF(I)/D1P2
              T1=QN(I)*(MION-1)
              T0=NZION
              T1=T1-T0*DBUF(I)
              T0=QN(I)
              DBUF(I)=T1/(T0-DBUF(I))
            ENDIF
            SCREEN(I)=DBUF(I)            !<--------------SCREEN ASSIGNED
          ENDIF
        ENDDO
!
        DEALLOCATE(DBUF)
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! PERFORM CHECKS ON BOUND, RYDBERG AND CONTINUUM ORBITALS
!
      BHFF=.FALSE.                        !NO EXTERNAL ORBS
      ICP=0
      ICM=0
      MODE=1
!
      DO I=1,MXORB
        IF(I.LE.NGROUP.AND.DEY(I).NE.DZERO.AND.SCREEN(I).GE.999)THEN
!OLD      IF(QN(I).GE.80)MODE=2
          IF(SCREEN(I).LT.5999)THEN       !EXTERNAL
            BHFF=.TRUE.                   !FOR RADWIN ENTRY
            ICM=ICM-1
          ELSEIF(SCREEN(I).GT.7999)THEN   !CONTINUUM
!OLD      MODE=2
            ICP=ICP+1
            IF(IVAL(I).NE.0)THEN
              WRITE(MW6,10250)I
              IV=IV-1
              IVAL(I)=0
            ENDIF
          ELSE                            !DUMMY RYDBERG
            IV=IV-IVAL(I)
            IVAL(I)=1
            IV=IV+1
            SCREEN(I)=MION-1
          ENDIF
! CLOSED-CORE EXTERNAL ONLY IF RELAXED
          IF(ICM*IEQ(0).NE.0.AND.I.GT.MB0)THEN
            WRITE(MW6,10170)I
            WRITE(MW0,*)'*** SR.MINIM0: ERROR, EXTERNAL ORBITAL CANNOT',&
     &                  ' BE A RELAXED ONE!'
            GO TO 1100
          ENDIF
! DO NOT ITERATE VARIATIONALLY FOR THESE RADIAL FUNCTIONS
          IF(INCLUD*ICP.NE.0)THEN
            WRITE(MW6,10230)I
            WRITE(MW0,*)" *** WARNING: SR.MINIM0 RESETS INCLUD=0,",     &
     &                  " BECAUSE YOU'VE FLAGGED CONTINUUM INPUT"
            INCLUD=0
          ENDIF
! DO NOT VARY FIXED INPUT (ERROR)
          IF(INCLUD*ICM.NE.0)THEN
            DO K=1,NVAR
              KK=IBUF(K)
              IF(KK.EQ.I)THEN
                WRITE(MW6,10180)I
                WRITE(MW0,*)                                            &
     &           '*** SR.MINIM0: ERROR, TRYING TO VARY EXTERNAL ORBITAL'
                GO TO 1100
              ELSEIF(KK.LT.I)THEN
                IF(QL(KK).EQ.QL(I).AND.MORT.NE.-3)THEN
                  WRITE(MW6,10270)I,KK
                  WRITE(MW0,*)                                          &
     &              '*** SR.MINIM0: ERROR, INCOMPATIBLE VARIATIONAL AND'&
     &              ,' EXTERNAL ORBITALS!'
                  GO TO 1100
                ENDIF
              ENDIF
            ENDDO
          ENDIF
        ENDIF
      ENDDO
!
      IF(ICM.LT.0)MAUTO=-1                         !ENTER SR.RADWIN ONLY
      IF(ICP.GT.0)MAUTO=1                          !ENTER SR.RADCON ONLY
      IF(ICM*ICP.LT.0)MAUTO=0               !ENTER SR.RADCWN & SR.RADCON
      IF(ICP.GT.0.AND.MODE.EQ.1)MODE=2             !NEW
!
      IF(BHFF.AND.ORTHOG.EQ.'  ')MORT=-3       !DON'T ORTHOG IF EXTERNAL
!
      IF(BDR.AND.IV.LE.0)THEN
        BDR=.FALSE.
        WRITE(MW6,10280)
      ENDIF
!
!-----------------------------------------------------------------------
!
! CHECK PI/PR SET-UP
!
      IF(MODE.EQ.2.OR.MODE.EQ.3)THEN               !B-C
!
        IF(NMETAR.NE.0.AND.EIMXLS.EQ.DZERO)THEN              !SET EIMXLS
          INQUIRE(FILE='TERMS',EXIST=BEX)
          IF(BEX)THEN
            OPEN(MRW14,FILE='TERMS',STATUS='OLD')
            READ(MRW14,*,END=680)
            E2=DZERO
            DUME=DZERO
            N1=ABS(NMETAR)+1
            DO N=1,NTRMS
              IF(N.EQ.N1)E1=DUME
              READ(MRW14,10430,END=680)ISP,NDUM,NDUM,NDUM,NDUM,DUME
              IF(ISP.EQ.0)GO TO 670                !TERMINATOR    ,MYRGE
              IF(N.EQ.N1)E2=DUME
            ENDDO
  670       IF(E2.EQ.DZERO)E2=-DUME
            EIMXLS=(E1+E2)/2                       !RELATIVE TO GROUND
!OLD            EIMXLS=EIMXLS+DUME                     !ABSOLUTE
  680       CLOSE(MRW14)
            IUNIT(MRW14)=-1
          ELSE              !WILL STILL USE SIGN AS A FLAG IF EIMXLS SET
            WRITE(MW0,*)                                                &
     &              'NOTE: NMETAR.NE.0 IGNORED AS NO TERMS FILE PRESENT'
            WRITE(MW6,*)                                                &
     &              'NOTE: NMETAR.NE.0 IGNORED AS NO TERMS FILE PRESENT'
            NMETAR=0
          ENDIF
        ENDIF
!
        IF(NMETARJ.NE.0.AND.EIMXIC.EQ.DZERO)THEN             !SET EIMXIC
          INQUIRE(FILE='LEVELS',EXIST=BEX)
          IF(BEX)THEN
            OPEN(MRW15,FILE='LEVELS',STATUS='OLD')
            READ(MRW15,*,END=700)
            E2=DZERO
            DUME=DZERO
            N1=ABS(NMETARJ)+1
            DO N=1,NLVLS
              IF(N.EQ.N1)E1=DUME
              READ(MRW15,10420,END=700)NDUM,NDUM,ISP,NDUM,NDUM,NDUM,DUME
              IF(ISP.EQ.0)GO TO 690                !TERMINATOR    ,MYRGE
              IF(N.EQ.N1)E2=DUME
            ENDDO
  690       IF(E2.EQ.DZERO)E2=-DUME
            EIMXIC=(E1+E2)/2                       !RELATIVE TO GROUND
!OLD            EIMXIC=EIMXIC+DUME                     !ABSOLUTE
  700       CLOSE(MRW15)
            IUNIT(MRW15)=-1
          ELSE              !WILL STILL USE SIGN AS A FLAG IF EIMXIC SET
            WRITE(MW0,*)                                                &
     &            'NOTE: NMETARJ.NE.0 IGNORED AS NO LEVELS FILE PRESENT'
            WRITE(MW6,*)                                                &
     &            'NOTE: NMETARJ.NE.0 IGNORED AS NO LEVELS FILE PRESENT'
            NMETARJ=0
          ENDIF
        ENDIF
!
! PERFORM CHECKS ON NMETAP/J FOR LOWER RESOLVED PI (BUNDLED CONT):
! N.B. NMETAP/J REFER TO LOWEST DISCRETE STATES ONLY.
!      IF THIS INCLUDES AUTOIONIZING STATES THEN NEED TO SKIP CONTINUUM,
!      I.E. L/JLOWMAX.GT.NMTETAP/J THEN AND SO USER SHOULD NOT RESTRICT
!      THE FORMER. RATHER, SR.DIAGON/DIAGFS WILL DO SO.
!      OBVIOUSLY, RESTRICTING THE RANGE IN ANY OTHER WAY MAY NOT GIVE
!      THE FULL SET OF PI/RADIATIVE DATA, AS IN NON-NMETAP/J OPERATION.
!      BUT JUST FLAG POSSIBLE CONFLICT IN THE CASE OF NMETAP/J.
!
        IF(NMETAP.GT.0)THEN
          NMETAP=MIN(NMETAP,NTRMS-ione1)
          IF(LLOWMX.LT.NTRMS-ione1)THEN
            WRITE(MW6,*)'*** WARNING: RESTRICTING LLOWMX MAY NOT GIVE ',&
     &                  'THE NMETAP IF IT INCLUDES AUTOIONIZING STATES!'
            WRITE(MW0,*)'*** WARNING: RESTRICTING LLOWMX MAY NOT GIVE ',&
     &                  'THE NMETAP IF IT INCLUDES AUTOIONIZING STATES!'
          ENDIF
        ENDIF
        IF(NMETAPJ.GT.0)THEN
          NMETAPJ=MIN(NMETAPJ,NLVLS-ione1)
          IF(JLOWMX.LT.NLVLS-ione1)THEN
            WRITE(MW6,*)'*** WARNING: RESTRICTING JLOWMX MAY NOT GIVE ',&
     &                 'ALL NMETAPJ IF IT INCLUDES AUTOIONIZING STATES!'
            WRITE(MW0,*)'*** WARNING: RESTRICTING JLOWMX MAY NOT GIVE ',&
     &                 'ALL NMETAPJ IF IT INCLUDES AUTOIONIZING STATES!'
          ENDIF
        ENDIF
        IF(NMETAP.GT.0.OR.NMETAPJ.GT.0)THEN
          IF(NRSLMX.LT.0)THEN
            WRITE(MW6,*)'***RESOLUTION CONFLICT:CANNOT HAVE NMETAP/J',  &
     &                  '.GT.0 AND NRSLMX.LT.0'
            WRITE(MW0,*)'***RESOLUTION CONFLICT:CANNOT HAVE NMETAP/J',  &
     &                  '.GT.0 AND NRSLMX.LT.0'
          ELSEIF(NRSLMX.GE.0.AND.NRSLMX.LE.1000)THEN
            WRITE(MW6,*)'*** POSSIBLE RESOLUTION CONFLICT: NMETAP/J',   &
     &                  '.GT.0 AND NRSLMX.GT.0...'
            WRITE(MW0,*)'*** POSSIBLE RESOLUTION CONFLICT: NMETAP/J',   &
     &                  '.GT.0 AND NRSLMX.GT.0...'
          ENDIF
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
! READ CONFIGURATION NOS FOR STOPOT
!
      IF(MCFMX.GT.0.and.mcfmx.le.1000)THEN
!
        IF(IEQ(0).NE.0)THEN                      !***NON-UNIQUE BASIS***
!
          DO I=1,MXORB
            MCFSTO(I)=0
          ENDDO
!
          DO M=1,MCFMX
!
            READ(MR5,*)K,IDUM0
!
            IF(IDUM0.LE.0)GO TO 710
!
            ALLOCATE(IDUM(IDUM0))
!
            IF(K.EQ.0)THEN
!
              IF(IRLX.GE.0)THEN                   !COMMON CORE
!
                READ(MR5,*)(IDUM(I),I=1,IDUM0)
!
                IMB=MIN(MB,IDUM0)
                DO I=1,IMB
                  MCFSTO(I)=IDUM(I)
                ENDDO
!
                IF(IDUM0.LT.MB)THEN               !FILL-IN
                  DO I=IDUM0+1,MB
                    MCFSTO(I)=IDUM(IDUM0)
                  ENDDO
                ENDIF
!
              ELSE                                !SO IEQ(0).GT.0
!
                WRITE(MW6,*)'*** ERROR: GROUP=0 (COMMON CORE ORBITALS) '&
     &                      ,                                           &
     &                     'CONFLICTS WITH NON-UNIQUE FLAG (KCOR1.LT.0)'
                WRITE(MW0,*)'*** ERROR: GROUP=0 (COMMON CORE ORBITALS) '&
     &                      ,                                           &
     &                     'CONFLICTS WITH NON-UNIQUE FLAG (KCOR1.LT.0)'
                GO TO 1100
!
              ENDIF
!
            ELSE
!
              IF(IEQ(0).LT.0)THEN
                WRITE(MW6,*)"*** ONLY SPECIFY STO CF FOR CORE ORBITALS",&
     &                      " WHEN BASIS='RLX'! THUS, MCFMX=1 WITH K=0."
                WRITE(MW0,*)"*** ONLY SPECIFY STO CF FOR CORE ORBITALS"
                GO TO 1100
              ENDIF
!
              READ(MR5,*)(IDUM(I),I=1,IDUM0)
!
              IF(K.GT.NGRP)GO TO 710              !IGNORE
!
              IB=MIN(IDUM0,MXBORB)
              KK=MXBORB*(K-1)+MB0
              DO I=1,IB
                II=KK+I
                MCFSTO(II)=IDUM(I)
!                write(mw0,*)k,ii,i,idum(i)
              ENDDO
!
              IF(IDUM0.GT.MXBORB)THEN
!
                I0=MXBORB
                IF(MXVORB.GT.0)THEN
                  KK=I0*(NGRP-1)+MXVORB*(K-1)+MB0
                  I0=I0+MXVORB
                  IB=MIN(IDUM0,I0)
                  DO I=MXBORB+1,IB
                    II=KK+I
                    MCFSTO(II)=IDUM(I)
!                write(mw0,*)k,ii,i,idum(i)
                  ENDDO
                  IF(IDUM0.LT.I0)THEN      !CASE MULTIPLE RYD, COPY LAST
                    DO I=IDUM0+1,I0
                      II=KK+I
                      MCFSTO(II)=IDUM(IDUM0)
!                write(mw0,*)k,-ii,i,idum(idum0)
                    ENDDO
                  ENDIF
                ENDIF
!
                IF(MXFORB.GT.0)THEN
                  KK=I0*(NGRP-1)+MXFORB*(K-1)+MB0
                  IF(IDUM0.GT.I0)THEN
                    I0=I0+MXFORB
                    IB=MIN(IDUM0,I0)
                    DO I=MXBORB+MXVORB+1,IB
                      II=KK+I
                      MCFSTO(II)=IDUM(I)
!                write(mw0,*)-k,ii,i,idum(i)
                    ENDDO
                  ELSE
                    I0=I0+MXFORB
                  ENDIF
                  IF(IDUM0.LT.I0)THEN            !COPY LAST RYD/CONT
                    DO I=IDUM0+1,I0
                      II=KK+I
                      MCFSTO(II)=IDUM(IDUM0)
!                write(mw0,*)-k,-ii,i,idum(idum0)
                    ENDDO
                  ENDIF
                ENDIF
!
              ENDIF
!
            ENDIF
!
  710       IF(ALLOCATED(IDUM))DEALLOCATE(IDUM)
!
          ENDDO
!
!HOLD          MCFMX0=MCFMX
!OLD          DO I=MXORB,1,-1
!OLD            IF(MCFSTO(I).NE.0)THEN
!OLD              MCFMX=I
!OLD              GO TO 720
!OLD            ENDIF
!OLD          ENDDO
!OLD          MCFMX=MXORB
!OLD  720     CONTINUE
! STOPOT NOW HANDLES ZERO (THE INITIAL) SO
          MCFMX=MXORB
!
        ELSE                                         !***UNIQUE BASIS***
!
          ALLOCATE(IDUM(MCFMX))
!
          READ(MR5,*)(IDUM(I),I=1,MCFMX)
!
          IF(MCFMX.GT.MXORB+idw)THEN
            WRITE(MW6,*)'***SR.MINIM0: CANNOT INPUT MORE MCFSTO VALUES',&
     &                  ' THAN THERE ARE ORBITALS, REDUCING FROM/TO:',  &
     &                  MCFMX,MXORB+idw
            WRITE(MW0,*)'***SR.MINIM0: CANNOT INPUT MORE MCFSTO VALUES',&
     &                  ' THAN THERE ARE ORBITALS, REDUCING INPUT...'
            MCFMX=MXORB+idw
          ENDIF
!
          IF(MCFMX.GT.MXORB)THEN             !SO idw=1
            MCFSTOX=IDUM(MCFMX)              !TRANSFER DW CF DIRECTLY
            MCFMX=MXORB
          ENDIF
!
          KH=0
          DO I=1,MCFMX
            MCFSTO(I)=IDUM(I)
            KS=-MCFSTO(I)
            IF(KS.GT.0)THEN
              KH=MAX(KH,KS)
              MCFSTO(I)=KMAX+KS
            ENDIF
          ENDDO
!
          DEALLOCATE(IDUM)
!
          IF(KH.GT.0)THEN                         !ADDITIONAL CF OCC NOS
!
            KMH=KMAX+KH
!
            CALL RE_ALLOC2(NEL,IONE,MXORB,IONE,KMAX,MXORB,KMH,IERR)
!
            WRITE(MW6,10440)
            DO I=MXORB,1,-1
              IF(ABS(QN(I)).LT.Q80)GO TO 720
            ENDDO
  720       MXVORB=I-MB
!
            DO K=1,KH
              KS=KMAX+K
              READ(MR5,*)(NEL(MB+N,KS),N=1,MXVORB)
              WRITE(MW6,10450)KS,(NEL(MB+N,KS),N=1,MXVORB)
              DO N=1,MB                            !COPY CLOSED-SHELLS
                NEL(N,KS)=NEL(N,1)
              ENDDO
              DO N=MB+1,MB+MXVORB
                IF(NEL(N,KS).LT.0.OR.NEL(N,KS).GT.2*QL(N)+2)THEN
                  WRITE(MW6,10460)KS,N-MB,NEL(N,KS)
                  GO TO 1100
                ENDIF
              ENDDO
              DO N=MB+MXVORB+1,MXORB
                NEL(N,KS)=0
              ENDDO
            ENDDO
!
          ENDIF
!
        ENDIF
!
      ELSEIF(MCFMX.EQ.0.AND.MDEN.lt.0)THEN
!
        IF(IEQ(0).eq.0)THEN
          IF(NOCC.GT.0)MCFMX=-9999                  !FOR FAC='YES'
        ELSEIF(IEQ(0).lt.0)THEN                     !'RLX' SO CORE ONLY
          MCFMX=1                                   !HISTORIC USES
          MCFSTO(1)=1                               !FIRST/GROUND CF
!          MCFMX=0                !MCFX "DEFAULT" AVERAGES OVER ALL CF'S
        ELSE                                        !SO 'SRLX'
          IF(IRLX.GE.0)THEN                         !COMMON CORE
            MCFMX=1                                 !HISTORIC USES
            MCFSTO(1)=1                             !FIRST/GROUND CF
!            MCFMX=0              !MCFX "DEFAULT" AVERAGES OVER ALL CF'S
          ELSE
!            MCFMX=0              !MCFX "DEFAULT" AVERAGES OVER ALL CF'S
          ENDIF
        ENDIF
!
      ELSEIF(MCFMX.LT.0.AND.IEQ(0).NE.0)THEN
!
        WRITE(MW6,*)"*** MCFMX.LT.0 INCONSISTENT WITH BASIS='S/RLX' - ",&
     &              "CANNOT USE A COMMON AVERAGE POTENTIAL"
        WRITE(MW0,*)"*** MCFMX.LT.0 NOT ALLOWED FOR RELAXED ORBITALS"
        GO TO 1100
!
      ENDIF
!
      NLSTOE=ABS(NLSTOE)
!
      IF(.NOT.BSTO.AND.MCFMX.NE.0)THEN
        WRITE(MW6,*)'STO OCCUPATION NOS IGNORED AS THOMAS-FERMI IN USE'
        WRITE(MW0,*)'STO OCCUPATION NOS IGNORED AS THOMAS-FERMI IN USE'
        MCFMX=0
        MCFSTO=0
      ENDIF
!
!-----------------------------------------------------------------------
!
! READ UNIQUE SET OF ORB OCCUPATION NUMBERS FOR MODEL STO/SCF POTENTIAL.
! VALENCE ORBITALS ONLY, CLOSED-SHELL CANNOT BE CHANGED CURRENTLY SO NL.
! IN CASE OF DW, NOCCX OPTIONALLY FLAGS AN ORBITAL WHOSE OCCUPATION
! NUMBER WILL BE INCREASED BY ONE TO GENERATE THE CONTINUUM POTENTIAL.
! NORMALLY NOT SET FOR FAC (UNIQUE/COMMON POTENTIAL FOR BOUND & CONT.)
! BUT SET FOR NON-FAC SO BOUND IS N-ELECTRON AND CONTINUUM IS N+1 ELEC.
!
      NOCC0=NOCC
      NOCC=MOD(NOCC,I1000)
!
      WKT=0
      IF(NOCC.NE.0)THEN
!
        NOCC=ABS(NOCC)
!
        ALLOCATE(DUM(NOCC))
!
        READ(MR5,*)(DUM(I),I=1,NOCC)
!
        IF(NOCC.GT.MXORB-MB)THEN
          WRITE(MW6,*)'***SR.MINIM0: CANNOT INPUT MORE NOCC VALUES',    &
     &                ' THAN THERE ARE ORBITALS, REDUCING FROM/TO:',    &
     &                NOCC,MXORB-MB
          WRITE(MW0,*)'***SR.MINIM0: CANNOT INPUT MORE NOCC VALUES',    &
     &                ' THAN THERE ARE ORBITALS, REDUCING INPUT...'
          NOCC=MXORB-MB
        ENDIF
!
        DO I=1,NOCC
          TEL(I+MB)=DUM(I)
        ENDDO
!
        DEALLOCATE(DUM)
!
        NOCC=NOCC+MB                     !NOW ABSOLUTE POSITION IN MXORB
!
        if(mden.ge.0.and.mhf.gt.0)go to 800           !as not used
!
        IF(NOCCX.LT.0.AND.FAC.EQ.'NO')NOCCX=0
!
        IF(NOCCX.GT.0.AND.FAC.EQ.'YES')THEN
          WRITE(MW6,*)'***SR.MINIM0: CANNOT ADD TO FAC OCC NOS.',       &
     &          ' SET  NOCCX.LT.0 TO FLAG USE OF *UNSCREENED* ORIGINALS'
          WRITE(MW0,*)'***SR.MINIM0: CANNOT ADD TO FAC OCC NOS.',       &
     &          ' SET  NOCCX.LT.0 TO FLAG USE OF *UNSCREENED* ORIGINALS'
          GO TO 1100                                    !MAKE USER THINK
        ENDIF
!
        IF(NOCCX.GT.0)NOCCX=NOCCX+MB     !NOW ABSOLUTE POSITION IN MXORB
!
        IF(NOCCX.GT.MXORB)THEN
          WRITE(MW6,*)'***SR.MINIM0: CANNOT ADD TO OCC. OF AN ORBITAL', &
     &                ' NOT DEFINED IN THE ORB LIST, REDUCING FROM/TO:',&
     &                NOCCX-MB,MXORB-MB
          WRITE(MW6,*)'***SR.MINIM0: CANNOT ADD TO OCC. OF AN ORBITAL', &
     &                ' NOT DEFINED IN THE ORB LIST, REDUCING INPUT...'
          NOCCX=MXORB
        ENDIF
!
        IF(MB.GT.0)THEN
          DO M=MA,MB
            TEL(M)=2*QL(M)+2
            WKT=WKT+TEL(M)
!            WRITE(MW6,"(I5,F6.1)")M,TEL(M)
          ENDDO
        ENDIF
!
        DO IB=1+MB,NOCC
!          WRITE(MW6,"(I5,F6.1)")IB,TEL(IB)
          IF(MORT.LT.0)THEN
            WMAX=2*QL(IB)+2
          ELSE
            WMAX=2*QN(IB)**2
          ENDIF
          IF(TEL(IB).GT.WMAX+DELW.OR.TEL(IB).LT.-DELW)THEN
            WRITE(MW6,*)'*** SR.MINIM0: UNPHYSICAL OCCUPATION NO. INPUT'&
     &                  ,' FOR ORBITAL',IB,' :',TEL(IB)
            WRITE(MW0,*)'*** SR.MINIM0: UNPHYSICAL OCCUPATION NO. INPUT'
            IF(TEL(IB).LT.-DELW)GO TO 1100
!          ELSE
          ENDIF
          WKT=WKT+TEL(IB)
        ENDDO
!
        if(nocc0.lt.0)then              !at least require an integer sum
          isumw=nint(wkt)
          ww1=wkt-isumw
          if(abs(ww1).gt.tolw)then
            WRITE(MW6,10020)WKT
            WRITE(MW0,10020)WKT
            GO TO 1100                   !ABORT - FOR TEST ONLY
          endif
          iflagw=0
          do i=mb+1,nocc
            isumw=nint(tel(i))
            ww1=tel(i)-isumw
            if(abs(ww1).gt.tolw)then
              if(iflagw.eq.0)then
                WRITE(MW6,10030)
                WRITE(MW0,10030)
              endif
              iflagw=i
              WRITE(MW6,10040)iflagw,tel(iflagw)
              WRITE(MW0,10040)iflagw,tel(iflagw)
            endif
          enddo
!          if(iflagw.gt.0)GO TO 1100                 !ABORT?
        else
          if(wkt.lt.d0pt999)then
            write(mw6,10050)wkt
            write(mw0,10050)wkt
            go to 1100
          endif
        endif
!
        IF(BALAN.AND.INCLUD.NE.0)THEN                           !NL ONLY
          DO I=1,NPARAM
            J=IEQUAL(I)
            IF(I.GT.MB.AND.J.LE.NVAR0)THEN
              IF(I.GT.NOCC.OR.TEL(I).LT.DELW)THEN
                WRITE(MW6,*)'*** SR.MINIM0: CANNOT VARY PARAMETER',I,   &
     &                  ' SINCE OCCUPATION NO. FOR ITS SUBSHELL IS ZERO'
                WRITE(MW0,*)'*** SR.MINIM0: CANNOT VARY PARAMETER',I,   &
     &                  ' SINCE OCCUPATION NO. FOR ITS SUBSHELL IS ZERO'
                GO TO 1100
              ENDIF
            ENDIF
          ENDDO
        ENDIF
!
! TRY AND CHECK SOME OBVIOUS ISSUES WITH NOCC, BUT SINCE USER HAS A
! FREE-HAND TO MESS-UP...
!
        iswch1=iswch
  750   MION1=MION-iswch1
        WW1=WKT-MION1
        IF(ABS(WW1).GT.TOLW)THEN
          if(ww1.lt.TOLW)then
            if(iswch1.eq.iswch)then !assume user has removed self-screen
              iswch1=iswch1+1
              iocc=9999               !flag an electron at infinity
              go to 750
            endif
            WRITE(MW6,10060)WKT,MION1
            WRITE(MW0,10060)WKT,MION1
          elseIF(WKT.GT.MION1)THEN
            WW1=WW1-iswch1
            IF(ABS(WW1).GT.TOLW)THEN
              if(ww1.gt.0)then           !SUM OCC NOS GT NO OF ELECTRONS
                if(nocc0.lt.0)then
                  WRITE(MW6,10070)WKT,MION
                  WRITE(MW0,10070)WKT,MION
                  GO TO 1100
                else                     !O.K. TO PROCEED FOR FAC
                  WRITE(MW6,10080)WKT,MION
                endif
              elseif(nocc0.lt.0)then     !SUM OCC NOS LT NO OF ELECTRONS
                WRITE(MW6,10090)WKT,MION
                WRITE(MW0,10090)WKT,MION
                GO TO 1100
              else                       !O.K. TO PROCEED FOR FAC
                WRITE(MW6,10100)WKT,MION
              endif
            elseif(nocc0.lt.0)then       !SELF-SCREENING NOT REMOVED
              WRITE(MW6,10110)WKT,MION
              WRITE(MW0,10110)WKT,MION
              GO TO 1100                 !ABORT - FOR TEST ONLY
            ENDIF
          endif
        else
          IF(iswch1.EQ.izero.AND.nocc0.LT.0)THEN
                                                !SELF-SCREEN NOT REMOVED
            WRITE(MW6,10120)WKT,MION-iswch
            WRITE(MW0,10120)WKT,MION-iswch
            GO TO 1100                   !ABORT - FOR TEST ONLY
          endif
          if(iswch1.ne.iswch.and.nocc0.gt.0)then    !FAC SUM OCC NE MION
            WRITE(MW6,10130)WKT,MION-iswch
          endif
        ENDIF
!
  800   CONTINUE
!
        IF(.NOT.BSTO)THEN
          WRITE(MW6,*)                                                  &
     &               'STO OCCUPATION NOS IGNORED AS THOMAS-FERMI IN USE'
          WRITE(MW0,*)                                                  &
     &               'STO OCCUPATION NOS IGNORED AS THOMAS-FERMI IN USE'
          NOCC=0
          NOCCX=0
        ENDIF
!
        IF(IEQ(0).ne.0)THEN
          WRITE(MW6,*)'*** SR.MINIM0: NOCC IGNORED FOR RELAXED ORBITALS'
          WRITE(MW0,*)'*** SR.MINIM0: NOCC IGNORED FOR RELAXED ORBITALS'
          NOCC=1000
        ENDIF
!
        IF(NOCC0.LT.0)NOCC=-NOCC
!
      ELSE
!
        NOCC=NOCC0
        NOCCX=0
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! GET FAC HARTREE-SLATER EXCHANGE COEFF (CAN BE USED BY NON-FAC...)
! WE DO IT HERE RATHER THAN PASS-ON ALL THE FAC_XXX OPTIONS, JUST faca
! (THE USER CAN ALSO SET AN ARBITRARY VALUE FOR faca DIRECTLY.)
!
      IF(BSTO.and.MEXPOT.EQ.4.and.faca.lt.dzero)THEN
        IF(FAC_AHX.LT.DZERO)THEN
          Z=ABS(NZION)
          IF(WKT.EQ.DZERO)WKT=MION
!
          CALL FACHXS(Z,WKT,FAC_IHX,FAC_HX0,FAC_HX1,FAC_AHX)
!
          IF(FAC_HXS.NE.DONE.OR.FAC_IHX.NE.-DONE.OR.FAC_HX0.NE.-DONE)   &
     &       THEN
            WRITE(MW6,10140)FAC_HXS,FAC_AHX,FAC_IHX,FAC_HX0,FAC_HX1
            WRITE(MW0,*)                                                &
     &     '*** SR MINIM0: NON-DEFAULT FAC HARTREE-SLATER VALUES IN USE'
!          ELSE
!            WRITE(MW6,10140)FAC_HXS*FAC_AHX
!10140 FORMAT(/5X,'FAC HARTREE-SLATER EXCHANGE COEFFICIENT=',1P,E13.5/)
          ENDIF
        ENDIF
        faca=FAC_HXS*FAC_AHX           !C.F. GetXFS, IS DIRECT DONE TOO?
      ENDIF
!
!-----------------------------------------------------------------------
!
! FIX ORBITALS DURING SELF-CONSISTENT OPERATION
! DEFAULT:
!    TRUE FOR CLOSED-SHELLS
!    FALSE FOR VALENCE
! TO OVERRIDE, READ-IN IFIX ORBITAL NUMBERS
!    >0 FOR TRUE
!    <0 FOR FALSE
!
      IF(MB.GT.0)THEN
        DO I=MA,MB
          BFIX(I)=.TRUE.
        ENDDO
      ENDIF
!
      DO I=MB0+1,MXORB                          !NO CONTINUUM HERE
        BFIX(I)=.FALSE.
      ENDDO
!
      IF(IFIX.GT.0)THEN
!
        ALLOCATE(IDUM(IFIX))
!
        READ(MR5,*)(IDUM(I),I=1,IFIX)
!
        IF(IFIX.GT.MXORB)THEN
          WRITE(MW6,*)'***SR.MINIM0: CANNOT INPUT MORE IFIX VALUES',    &
     &                ' THAN THERE ARE ORBITALS, REDUCING FROM/TO:',    &
     &                IFIX,MXORB
          WRITE(MW0,*)'***SR.MINIM0: CANNOT INPUT MORE IFIX VALUES',    &
     &                ' THAN THERE ARE ORBITALS, REDUCING INPUT...'
          IFIX=MXORB
        ENDIF
!
        IF(IEQ(0).ne.0)THEN
          WRITE(MW6,*)'*** SR.MINIM0: IFIX IGNORED FOR RELAXED ORBITALS'
          WRITE(MW0,*)'*** SR.MINIM0: IFIX IGNORED FOR RELAXED ORBITALS'
          NOCC=1000
        ELSE
          DO I=1,IFIX
            J=ABS(IDUM(I))
            IF(J.GT.MXORB)THEN
              WRITE(MW6,*)'**** SR.MINIM0: USER INPUT ILLEGAL ORBITAL', &
     &                    ' NO. (.GT.MXORB) TO FIX:',J,MXORB
              WRITE(MW0,*)'**** SR.MINIM0: USER INPUT ILLEGAL ORBITAL', &
     &                    ' NO. (.GT.MXORB) TO FIX'
              GO TO 1100              !AS CANNOT KNOW MIND OF USER...
            ENDIF
            IF(IDUM(I).GT.0)THEN
              BFIX(J)=.TRUE.
            ELSEIF(IDUM(I).LT.0)THEN
              BFIX(J)=.FALSE.
            ELSE
! DEFAULT
            ENDIF
          ENDDO
        ENDIF
!
        DEALLOCATE(IDUM)
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! READ ANY NUCLEAR SPIN-ORBIT SCREENING
!
      IF(IZESP.NE.0)THEN
!
        IZ=ABS(IZESP)           !IZESP HAS ALREADY BEEN REDUCED TO IXVAR
        READ(MR5,*)(ZESP(I),I=1,IZ)
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! READ DELELS/IC IN UNITS (E.G. FOR TECS AND LECS)
!
      EFLG0=DZERO                 !CAN OVERWRITE ABS GROUND STATE ENERGY
      EFLGJ0=DZERO                !REQUIRED FOR IOPTIM.NE.0
!
      IF(BDELE)THEN
!
! ex-common/nrbdel/
        allocate(delecf(kmax,2),stat=ierr)
        if(ierr.ne.0)then
          write(mw0,*)'minim0: allocation fails for delecf'
          nf=0
          go to 900
        endif
!
        do k=1,kmax
          delecf(k,1)=dzero
        enddo
!
! TERMS
!
        IF(INCLUD.NE.0.AND.ISHFTLS.NE.0)THEN   !RESET
          IF(NJO.GT.0)THEN                     !F-S WEIGHTED LEVELS
            IOPTIM=-2
          ELSE                                 !TERMS
            IOPTIM=1
          ENDIF
          ISHFTLS=2
          IF(INCLUD.GT.0)INCLUD=NTRMS
        ENDIF
!
! EX-COMMON/NRBDEL/
        ALLOCATE(DELELS(NTRMS,2),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM0: ALLOCATION FAILS FOR DELELS'
          NF=0
          GO TO 900
        ENDIF
!
        I0=1                                   !READ TECS
        DO K=1,NTRMS
          DELELS(K,1)=DZERO
        ENDDO
        IF(ISHFTLS.LT.0.OR.ISHFTLS.GT.1)THEN   !READ OBS WEIGHTED TERM E
          I0=2
          DO K=1,NTRMS
            DELELS(K,2)=-DONE
          ENDDO
          do k=1,kmax
            delecf(k,2)=-done
          enddo
        ENDIF
!
        IF(ISHFTLS.NE.0)THEN
!
          IF(MDELE.NE.0)THEN
            WRITE(MW6,*)'MDELE DATA IGNORED BECAUSE ISHFTLS .NE. ZERO'
            MD=ABS(MDELE)
            DO K=1,MD                   !SKIP READS
              READ(MR5,*)
            ENDDO
            MDELE=0                     !ABS(ISHFTLS)
          ENDIF
!
          IF(ISHFTLS.LT.0)ISHFTLS=-1
!
          IF(IUNIT(MR19).EQ.0)THEN
            WRITE(MW6,*)"ISHFTLS.NE.0 BUT MISSING FILE='SHFTLS'..."
            WRITE(MW0,*)'MISSING FILE ON UNIT=MR19'
!            GO TO 1100
            WRITE(MW6,*)'ATTEMPTING HISTORIC READ FROM UNIT5'
            WRITE(MW0,*)'ATTEMPTING HISTORIC READ FROM UNIT5'
            MRTCC=MR5
          ELSE
            MRTCC=MR19
            REWIND(MRTCC)
          ENDIF
!
          READ(MRTCC,*,ERR=1100,END=1100)NOBS,UNITS
          TUNIT=UNITS*DTWO                        !CONVERT TO A.U.
!
          IF(NOBS.LT.0.AND.ISHFTLS.GT.1)THEN
            WRITE(MW6,*)' *** SR.MINIM0: CANNOT ITERATE/OPTIMIZE WITH', &
     &                  ' USER INPUT CONFIG ENERGIES,'
            WRITE(MW0,*)' *** SR.MINIM0: CANNOT ITERATE/OPTIMIZE WITH', &
     &                  ' USER INPUT CONFIG ENERGIES'
            IF(IOPTIM.EQ.0)THEN
              WRITE(MW6,*)'***RE-SETTING ISHFTLS=-1 FOR SINGLE PASS TEC'
              WRITE(MW0,*)'***RE-SETTING ISHFTLS=-1 FOR SINGLE PASS TEC'
              ISHFTLS=-1
            ELSE
              GO TO 1100
            ENDIF
          ENDIF
!
          IF(IOPTIM.NE.0)ISHFTLS=0          !NOW SWITCH OFF & USE IOPTIM
!
          IFLG0=0
          IF(ISHFTLS.EQ.1)IFLG0=-1                !NO GROUND POSS/NEEDED
!
          k1=1
          if(ishftls.eq.-1.and.nobs.lt.0)then       !see if we have k1=2
            read(mrtcc,*,err=1100,end=1100)i,dem
            if(dem.lt.dzero)then       !will form correction for auger e
              k1=2
              delecf(i,2)=dzero                !not actually used thence
            endif
          endif
!
          DO K=K1,abs(NOBS)
!
            READ(MRTCC,*,ERR=1100,END=1100)I,(DUM2(KK),KK=1,K1)
!
            DEM=DUM2(1)
            IF(I0.EQ.2.AND.DEM.LT.DZERO.AND.DEM.GT.-DONE)THEN
              WRITE(MW6,*)' *** SR.MINIM0 INPUT ERROR: OBSERVED ENERGY '&
     &                    ,'.LT. ZERO, PERHAPS A TEC? ',J,DEM
              WRITE(MW0,*)' *** SR.MINIM0 INPUT ERROR: OBSERVED ENERGY '&
     &                    ,'.LT. 0...'
              GO TO 1100
            ENDIF
!
            T=DEM/TUNIT
            IF(IFLG0.EQ.0.AND.T.LE.DZERO)IFLG0=I  !TAKE FIRST SUIT AS E0
!
            if(nobs.gt.0)then                     !term label (T)
              IF(I.GT.NTRMS)THEN
                WRITE(MW6,*)'DELELS TERM INDEX .GT. NTRMS:',I,NTRMS
                GO TO 1100
              ENDIF
              DELELS(I,I0)=T
            else                                  !CF label
              IF(I.GT.KMAX)THEN
                WRITE(MW6,*)'DELECF CF INDEX .GT. NO. CFS:',I,KMAX
                GO TO 1100
              ENDIF
              delecf(i,i0)=t
              if(k1.eq.2)delecf(i,1)=t-dum2(2)/tunit
            endif
!
          ENDDO
!
          IF(IFLG0.GT.0)THEN                      !TRANSFER E0
            if(nobs.gt.0)then
              EFLG0=DELELS(IFLG0,I0)              !I0=2 HERE
              DELELS(IFLG0,I0)=DZERO
            else
              eflg0=delecf(iflg0,i0)              !i0=2 here
              delecf(iflg0,i0)=dzero
            endif
          ELSEIF(IOPTIM.NE.0)THEN
            WRITE(MW6,*)'***SR.MININ: GROUND STATE NOT FOUND IN SHFTLS'
            WRITE(MW0,*)'***SR.MININ: GROUND STATE NOT FOUND IN SHFTLS'
          ENDIF
!
          if(ishftls.eq.1.and.nobs.lt.0)then
            nobs=-nobs                    !all terms of CF use same dE
            do i=1,ntrms
              k=nfk(i)
              k=abs(k)
              delels(i,i0)=delecf(k,i0)
            enddo
            do k=1,kmax
              delecf(k,i0)=dzero
            enddo
          endif
!
          IF(NJO.LE.0.AND.ISHFTLS.GT.1)THEN
            WRITE(MW6,*)'*** NO TEC ITERATION POSSIBLE IN PURE LS RUN, '&
     &                  ,'SET ISHFTLS.LE.1, OR TURN ON IC'
            WRITE(MW0,*)'*** NO TEC ITERATION POSSIBLE IN PURE LS RUN, '&
     &                  ,'SET ISHFTLS.LE.1, OR TURN ON IC'
            GO TO 1100
          ENDIF
!
        ENDIF
!
! LEVELS (SHOULD SEPARATE INTO LS AND IC USAGE...)
!
        IF(INCLUD.NE.0.AND.ISHFTIC.NE.0)THEN   !RESET
          IF(IOPTIM.EQ.-2)THEN                 !IGNORE F-S WGHT LEVS
            WRITE(MW6,*)' *** IGNORING TERM ENERGIES, USING LEVEL INFO',&
     &                  ' DURING MINIM0IZATION OPERATION'
            WRITE(MW0,*)' *** IGNORING TERM ENERGIES, USING LEVEL INFO'
          ENDIF
          IF(NJO.LE.0)THEN
            WRITE(MW6,*)' *** IGNORING LEVEL ENERGIES IN LS-RUN'
            WRITE(MW0,*)' *** IGNORING LEVEL ENERGIES IN LS-RUN'
          ELSE                                 !LEVELS
            IOPTIM=2
          ENDIF
          ISHFTIC=2
          IF(INCLUD.GT.0)INCLUD=NLVLS
        ENDIF
!
! EX-COMMON/NRBDEL/
        ALLOCATE(DELEIC(NLVLS,2),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'MINIM0: ALLOCATION FAILS FOR DELEIC'
          NF=0
          GO TO 900
        ENDIF
!
        J0=1                                   !READ LECS
        DO K=1,NLVLS
          DELEIC(K,1)=DZERO
        ENDDO
        IF(ISHFTIC.LT.0.OR.ISHFTIC.GT.1)THEN   !READ OBS LEVEL ENERGIES
          J0=2
          DO K=1,NLVLS
            DELEIC(K,2)=-DONE
          ENDDO
          do k=1,kmax
            delecf(k,2)=-done
          enddo
        ENDIF
!
        IF(ISHFTIC.NE.0)THEN
!
          IF(ISHFTIC.LT.0)ISHFTIC=-1
!
          IF(IUNIT(MR20).EQ.0)THEN
            WRITE(MW6,*)"ISHFTIC.NE.0 BUT MISSING FILE='SHFTIC'..."
            WRITE(MW0,*)'MISSING FILE ON UNIT=MR20'
!            GO TO 1100
            WRITE(MW6,*)'ATTEMPTING HISTORIC READ FROM UNIT5'
            WRITE(MW0,*)'ATTEMPTING HISTORIC READ FROM UNIT5'
            MRTCC=MR5
          ELSE
            MRTCC=MR20
            REWIND(MRTCC)
          ENDIF
!
          READ(MRTCC,*,ERR=1100,END=1100)NOBSJ,UNITS
          TUNIT=UNITS*DTWO                        !CONVERT TO A.U.
!
          IF(NOBSJ.LT.0.AND.ISHFTIC.GT.1)THEN
            WRITE(MW6,*)' *** SR.MINIM0: CANNOT ITERATE/OPTIMIZE WITH', &
     &                  ' USER INPUT CONFIG ENERGIES,'
            WRITE(MW0,*)' *** SR.MINIM0: CANNOT ITERATE/OPTIMIZE WITH', &
     &                  ' USER INPUT CONFIG ENERGIES'
            IF(IOPTIM.EQ.0)THEN
              WRITE(MW6,*)'***RE-SETTING ISHFTIC=-1 FOR SINGLE PASS LEC'
              WRITE(MW0,*)'***RE-SETTING ISHFTIC=-1 FOR SINGLE PASS LEC'
              ISHFTIC=-1
            ELSE
              GO TO 1100
            ENDIF
          ENDIF
!
          IF(IOPTIM.NE.0)ISHFTIC=0      !NOW SWITCH OFF & USE IOPTIM
!
          IFLGJ0=0
          IF(ISHFTIC.EQ.1)IFLGJ0=-1               !NO GROUND POSS/NEEDED
!
          k1=1
          if(ishftic.eq.-1.and.nobsj.lt.0)then      !see if we have k1=2
            read(mrtcc,*,err=1100,end=1100)j,dem
            if(dem.lt.dzero)then       !will form correction for auger e
              k1=2
              delecf(j,2)=dzero                !not actually used thence
            endif
          endif
!
          DO K=K1,abs(NOBSJ)
!
            READ(MRTCC,*,ERR=1100,END=1100)J,(DUM2(KK),KK=1,K1)
!
            DEM=DUM2(1)
            IF(J0.EQ.2.AND.DEM.LT.DZERO.AND.DEM.GT.-DONE)THEN
              WRITE(MW6,*)' *** SR.MINIM0 INPUT ERROR: OBSERVED ENERGY '&
     &                    ,'.LT. ZERO, PERHAPS A LEC? ',J,DEM
              WRITE(MW0,*)' *** SR.MINIM0 INPUT ERROR: OBSERVED ENERGY '&
     &                    ,'.LT. 0...'
              GO TO 1100
            ENDIF
!
            T=DEM/TUNIT
            IF(IFLGJ0.EQ.0.AND.T.LE.DZERO)IFLGJ0=J     !TAKE FIRST AS E0
!
            if(nobsj.gt.0)then                    !level label (LV)
              IF(J.GT.NLVLS)THEN
                WRITE(MW6,*)'DELEIC LEVEL INDEX .GT. NLVLS:',J,NLVLS
                GO TO 1100
              ENDIF
              DELEIC(J,J0)=T
            else                                  !CF label
              IF(J.GT.KMAX)THEN
                WRITE(MW6,*)'DELECF CF INDEX .GT. NO. CFS:',J,KMAX
                GO TO 1100
              ENDIF
              delecf(j,j0)=t
              if(k1.eq.2)delecf(j,1)=t-dum2(2)/tunit
            endif
!
          ENDDO
!
          IF(IFLGJ0.GT.0)THEN                     !TRANSFER EJ0
            if(nobsj.gt.0)then
              EFLGJ0=DELEIC(IFLGJ0,J0)            !J0=2 HERE
              DELEIC(IFLGJ0,J0)=DZERO
            else
              eflgj0=delecf(iflgj0,j0)            !j0=2 here
              delecf(iflgj0,j0)=dzero
            endif
          ELSEIF(IOPTIM.NE.0)THEN
            WRITE(MW6,*)'***SR.MININ: GROUND LEVEL NOT FOUND IN SHFTIC'
            WRITE(MW0,*)'***SR.MININ: GROUND LEVEL NOT FOUND IN SHFTIC'
          ENDIF
!
          if(nobs.lt.-1.and.nobsj.lt.-1)then
            write(mw6,*)'***sr.minim: configuration energies found in ',&
     &        'both SHFTLS and SHFTIC files; the latter will supplement'&
     &        ,' and/or overwrite the former!'
            write(mw0,*)'***sr.minim: configuration energies found in ',&
     &        'both SHFTLS and SHFTIC files; the latter will supplement'&
     &        ,' and/or overwrite the former!'
            if(ishftls*ishftic.lt.0)then
              write(mw6,*)'***error: inconsistent energies in SHFTLS/IC'
              write(mw6,*)'could set ishftls=0 to use ishftic=1 here...'
              write(mw0,*)'***error: inconsistent energies in SHFTLS/IC'
              write(mw0,*)'could set ishftls=0 to use ishftic=1 here...'
              go to 1100
            endif
          endif
!
          if(ishftic.eq.1.and.nobsj.lt.0)then
            nobsj=-nobsj                     !all lvls of CF use same dE
            do j=1,nlvls
              i=nrr(j)
              k=nfk(i)
              k=abs(k)
              deleic(j,j0)=delecf(k,j0)
            enddo
            do k=1,kmax
              delecf(k,j0)=dzero
            enddo
          endif
!
        ENDIF
!
! OLD TERMS
!
        IF(MDELE.NE.0.AND.ISHFTLS.EQ.0)THEN
          MD=ABS(MDELE)
          ISHFTLS=1
          DO K=1,MD
!
            READ(MR5,*)I,DEM
!
            IF(I.GT.NTRMS)THEN
              WRITE(MW6,*)'DELELS TERM INDEX .GT. NTRMS:',I,NTRMS
              GO TO 1100
            ENDIF
!
            DELELS(I,1)=DEM/(DTWO*DKCM)
          ENDDO
        ENDIF
!
      ELSEIF(INCLUD.NE.0.AND.IOPTIM.EQ.0)THEN
!
! CHECK NOT VARYING SLATER IF NO OBS ENERGIES READ.
!
        IF(BSCALR)THEN
          WRITE(MW6,*)'***SR.MINIM0: VARYING SLATER SCALING TO ',       &
     &               'MINIM0IZE ABSOLUTE ENERGY SUM WILL NOT CONVERGE!!'
          WRITE(MW0,*)'***SR.MINIM0: SLATER SCALING WILL NOT CONVERGE'
          GO TO 1100
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! PLASMA SCREENING:
!   TKAY>0 ELECTRON TEMP*K IN RYD.
!       <0 ELECTRON TEMP IN KELVIN.
!   DENE = ELECTRON DENSITY IN CM-3.
! NDEN<0
!   DENI = ION DENSITY IN CM-3.**** CURRENTLY NOT USED ****
! NDEN>0
!   DENI=DENE/ZN IF NEEDED (MDEN=2 ION-SPHERE)
!        WHERE ZN=Z-N+1 FOR BOUND AND ZN=Z-N FOR CONTINUUM ORBITALS
!        IS SET IN SR.RADIAL AND SR.RADCON (FOR SAFETY) AS INPUT
!        TO SR.VMPOT TO ENSURE CHARGE NEUTRALITY.
!
      ZNP0=-999
      DENE=DZERO
      DENI=DZERO
      TKAY=DONE
!
      IF(MDEN.GT.0)THEN
        NDEN0=NDEN
        NDEN=ABS(NDEN)
!
        IF(NDEN.GT.0)THEN
          ALLOCATE(DENSI(NDEN),DENS(NDEN),TKAYS(NDEN))
        ENDIF
!
        IF(NDEN0.GT.0)THEN
          READ(MR5,*)(DENS(N),TKAYS(N),N=1,NDEN)         !DENE,TKAY
          DO N=1,NDEN
            DENSI(N)=DZERO
          ENDDO
        ELSEIF(NDEN0.LT.0)THEN
          WRITE(MW0,*)                                                  &
     &              '*** ATTENTION: USER INPUT ION DENSITIES NOT IN USE'
          WRITE(MW6,*)                                                  &
     &              '*** ATTENTION: USER INPUT ION DENSITIES NOT IN USE'
          READ(MR5,*)(DENSI(N),DENS(N),TKAYS(N),N=1,NDEN)
                                                         !DENI,DENE,TKAY
        ENDIF
!
        IF(IDW.NE.0.AND.NDEN.GT.1)THEN
          WRITE(MW0,*)                                                  &
     &           '*** MINIM0: NO PLASMA LOOP FOR RUN="DE", USING NDEN=1'
          WRITE(MW6,*)                                                  &
     &           '*** MINIM0: NO PLASMA LOOP FOR RUN="DE", USING NDEN=1'
          NDEN=1
        ENDIF
!
! PRE-LOAD MIN DENSITY CASE FOR SR.MESH (SET ALL INFO)
        N0=1
        DO N=2,NDEN
          IF(DENS(N).LT.DENS(N0))N0=N
        ENDDO
! EX-SR.MINIM
        T=NZION-MION+1               !APPROX, EXACT SET IN RADIAL/RADCON
        DENE=DENS(N0)*DCON3**3
        IF(DENSI(N0).LE.DZERO)DENSI(N0)=DENS(N0)/T       !NOT USED
        DENI=DENSI(N0)*DCON3**3
        R0=DZERO
        IF(DENI.NE.DZERO)R0=(DCON6/DENI)**D1THRD
        TKAY=TKAYS(N0)
        IF(TKAY.LT.DZERO)TKAY=-TKAY/DCON2                !K->RYD
        GAMQ=DZERO
        DEBYE=DZERO
        IF(DENE*TKAY.NE.DZERO)THEN
          DEBYE=SQRT(DCON5*DENE/TKAY)
          DEBYE=DONE/DEBYE
          IF(R0.NE.DZERO)THEN
            GAMQ=DCON4*T*T
            GAMQ=GAMQ*DENI**D1THRD/TKAY
          ENDIF
        ENDIF
!                                                  !suppress
        IF(mden.LT.0)WRITE(MW6,10400)MDEN,DENSI(N0),DENS(N0),TKAY,GAMQ, &
     &                               DEBYE,R0
!
        NDEN=NDEN-1                                !RE-SET FOR INCREMENT
!
      ELSEIF(NDEN.GT.0)THEN                              !READ & SKIP
        READ(MR5,*)(DDUM,DDUM,N=1,NDEN)
        NDEN=0
      ENDIF
!
! END READ INPUT AND INITIAL SETUP--------------------------------------
!
!
  900 NF0=NF
!
! FOR STUPID G77 COMPILER:
!
      MPRNT0=MPRINT
      NLAM0=NLAM
      NVAR0=NVAR*ISVAR
      IMXIT=IMAXIT
      TVARY0=TVARY
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
 1000 WRITE(MW6,10150)
      WRITE(MW0,*)'*** SR.MINIM0: ERROR READING NAMELIST SMINIM!'
                                                                  !FATAL
!
 1100 NF=-1
      GO TO 900
!
!-----------------------------------------------------------------------
!
10010 FORMAT(/' *** STRONG WARNING: AVERAGING-OVER CONFIGURATION ',     &
     &' OCCUPATION NUMBERS FOR STOPOT (MCFMX.LE.0) IS *NOT* RECOMMENDED'&
     &,' WHEN CONTINUUM IS PRESENT! *** '/)
10020 FORMAT(/' *** SR.MINIM0: NEED SUM OF OCCUPATION NOS TO BE AN',    &
     &       ' INTEGER FOR NON-FAC SELF-SCREENING BUT USER SUM=',F6.2)
10030 FORMAT(/' *** SR.MINIM0: USE OF FACTIONAL OCCUPATION NOS MAY NOT',&
     &       ' BE A GOOD IDEA FOR NON-FAC (STO) SELF-SCREENING:')
10040 FORMAT(I5,F6.2)
10050 FORMAT(/'SR.MINIM0: SUM OF INPUT OCC NOS .LT. 1 FOR FAC LEADS TO',&
     &       ' ASYMPTOTIC CHARGE .GT. NUCLEAR:',F7.3)
10060 FORMAT(/' *** SR.MINIM0: SUM OF OCCUPATION NOS NOT EQUAL',        &
     &       ' TO MION(-1)...',F6.2,I5)
10070 FORMAT(/' *** SR.MINIM0: SUM OF OCCUPATION NOS GEATER',           &
     &       ' THAN MION - ABORT:',F6.2,I5)
!                  WRITE(MW0,20015)WKT,MION
10080 FORMAT(/' *** SR.MINIM0: SUM OF OCCUPATION NOS GEATER',           &
     &       ' THAN MION:',F6.2,I5)
10090 FORMAT(/' *** SR.MINIM0: SUM OF OCCUPATION NOS LESS ',            &
     &       'THAN MION - ABORT:',F6.2,I5)
!                WRITE(MW0,20030)WKT,MION
10100 FORMAT(/' *** SR.MINIM0: SUM OF OCCUPATION NOS LESS ',            &
     &       'THAN MION:',F6.2,I5)
10110 FORMAT(/' *** SR.MINIM0: SUM OF OCCUPATION NOS EQUAL TO MION,',   &
     &       ' SELF-SCREENING NOT REMOVED HERE:',F6.2,I5,3X,'-ABORT!!')
10120 FORMAT(/' *** SR.MINIM0: SUM OF OCCUPATION NOS EQUAL TO MION(-1),'&
     &       ,' SELF-SCREENING NOT REMOVED HERE:',F6.2,I5,3X,'-ABORT!!')
!            WRITE(MW0,20060)WKT,MION-iswch
10130 FORMAT(/' *** SR.MINIM0: SUM OF OCCUPATION NOS NOT EQUAL',        &
     &       ' TO MION, CASE OF FAC:',F6.2,I5)
10140 FORMAT(/'FAC HARTREE-SLATER EXCHANGE:'//1P,'#    HXS =',          &
     &       E13.5/'#    AHX =',E13.5/'#    IHX =',E13.5/'#    HX0 =',  &
     &       E13.5/'#    HX1 =',E13.5/)
10150 FORMAT('*** SR.MINIM0: ERROR READING NAMELIST SMINIM!'/4X,        &
     &       'IF PRESENT, CHECK FOR ILLEGAL OR MISTYPED VARIABLE NAMES')
10160 FORMAT(' SR.MINIM0 ALLOCATION INCREASES MXVAR =',I4,' TO',I4)
10170 FORMAT(/' *** SR.MINIM0: ERROR, YOU HAVE SPECIFIED RELAXED ',     &
     &       'ORBITAL',I3,' AS AN EXTERNAL ORBITAL!')
10180 FORMAT(/' *** SR.MINIM0: ERROR, TRYING TO VARY EXTERNAL ORBITAL=',&
     &       I3)
10190 FORMAT(16I5)
10200 FORMAT('***ERROR, ORBITAL K=',I3,' TO BE VARIED DOES NOT EXIST!')
10210 FORMAT(//35X,60('*')/)
10220 FORMAT(' SR.MINIM0 REDUCES NLAM/NEXTRE=',I3,' TO ',I3)
10230 FORMAT(" *** WARNING: SR.MINIM0 RESETS INCLUD=0, BECAUSE YOU'VE ",&
     &       "FLAGGED CONTINUUM INPUT FOR ORBITAL NO. =",I2)
10240 FORMAT(" SR.MINIM0 RESETS EFFECTIVE NUMBER OF ELECTRONS TO",I4,   &
     &       ", BECAUSE YOU'VE SPECIFIED  MRED =",I3)
10250 FORMAT(' ERROR IN SR.MINIM0, YOU HAVE DECLARED ORBITAL',I3,       &
     &       'BOTH AS A VALENCE AND AS A CONTINUUM ORIBTAL'/)
10260 FORMAT(' WARNING, YOU HAVE SPECIFIED MDELE .LT. 0 WITH NO RESTART'&
     &       ,', MDELE HAS BEEN RESET TO ZERO BY SR.MINIM0')
10270 FORMAT(' *** SR.MINIM0: ERROR, EXTERNAL ORBITAL',I3,' WOULD',     &
     &       ' BE REPEATEDLY ORTHOGONALIZED TO VARIATIONAL ORBITAL',I3)
10280 FORMAT(' WARNING, SR.MINIM0 IS UNABLE TO FIND ANY VALENCE ',      &
     &       'ORBITALS SO DR HAS BEEN SWITCHED OFF ')
10290 FORMAT('***ERRROR: VARIATIONAL PARAMETER',I3,' HAS VALUE',I3,     &
     &       ' WHICH EXCEEDS NUMBER OF SCALING PARAMETERS',I3)
10300 FORMAT(//' ****ERROR, VARIATIONAL PARAMETERS MUST BE IN ASCENDING'&
     &       ,' ORDER, NOT:',15I3)
10310 FORMAT(' SR.MINIM0: CANNOT USE NEXTRE/NLAM.LT.0 WITH ISCALR.GT.0:'&
     &       ,2I5)
10320 FORMAT(///'**** BAYLISS 1-BODY POLARIZATION POTLS IN USE *****'// &
     &       '  L',5X,'ALFD',6X,'RCUT'/3(I3,2F10.4/))
10330 FORMAT(///'**** NORCROSS 1-BODY POLARIZATION POTLS IN USE *****'//&
     &       '  L',5X,'ALFD',6X,'RCUT'/3(I3,2F10.4/))
10340 FORMAT(///'**** BAYLISS 2-BODY POLARIZATION POTLS IN USE *****'// &
     &       7X,'<ALFD>',4X,'<RCUT>'/3X,2F10.4/)
10350 FORMAT(///'**** NORCROSS 2-BODY POLARIZATION POTLS IN USE *****'//&
     &       7X,'<ALFD>',4X,'<RCUT>'/3X,2F10.4/)
10360 FORMAT(' *** SR.MINIM0: UNRECOGNIZED OPTION FOR POTIN:  ',A4)
10370 FORMAT(' *** SR.MINIM0: UNRECOGNIZED OPTION FOR DDIAG:  ',A6)
10380 FORMAT(' *** SR.MINIM0: UNRECOGNIZED OPTION FOR RADOUT:  ',A3)
10390 FORMAT(' *** SR.MINIM0: UNRECOGNIZED OPTION FOR POTOUT:  ',A3)
10400 FORMAT(/' MDEN=',I2,3X,'ION DENSITY=',1PE9.2,'CM-3',3X,           &
     &       'ELECTRON DENSITY=',1PE9.2,'CM-3',3X,'TEMPERATURE*K=',     &
     &       0PF7.2,'RYD',3X,'GAMMA=',0PF5.2,3X,'DEBYE=',F7.2,3X,'R0=', &
     &       F7.2/' **** ',5X,'*********** ',16X,'**************** ',   &
     &       16X,'************* ',13X,'***** ',8X,'***** ',10X,'**')
10410 FORMAT(/' **** BOX STATES IN USE WITH BOUNDARY RZERO INPUT AS: ', &
     &       F5.1/)
10420 FORMAT(2I2,2X,2I2,2I5,F18.8,3X,A4)
10430 FORMAT(3I2,I5,I5,F18.6,3X,A4)
10440 FORMAT(//' CF ADDITIONAL FICTICIOUS CONFIGURATION OCCUPATION',    &
     &       ' NUMBERS FOR STO/SELF-CONSISTENT POTENTIALS:'/)
10450 FORMAT(I3,':',(60I2))
10460 FORMAT(' *** SR.MINIM0: ILLEGAL OCCUPATION NUMBER FOR CF=',I3,    &
     &       ' VALENCE ORBITAL=',I2,' OF:',I3)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE MINIM0
!
!                             *******************
!
      SUBROUTINE MKALG1(QLMC,MAXEL,VC1,MAM,NAM)
!
!-----------------------------------------------------------------------
!
!  SR.MKALG1 WORKS OUT SLATER-STATE INTERACTIONS CSLJP-C'S'L'J'P FOR
!  RADIATIVE MK ALGEBRA, INCLUDING BP CORRECTIONS TO M1 AND E1VEL.
!
!  IT IS CALLED BY:
!    SR.ALGEB4
!
!  IT CALLS:
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!    FN.SJS
!    FN.VCC
!
!-----------------------------------------------------------------------
!
      USE COMMON_ALGEB,  ONLY: BFOT
!!      COMMON /BASIC/NF,KF,KG,JA,JB,JAP,JBP,MGAP(5)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,JA=>IBSK4,JB=>IBSK5            &
     &              ,JAP=>IBSK6,JBP=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9    &
     &              ,IBSK10=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_COEFFS, ONLY: DRKPS,QRLPS,NRKPS
      USE COMMON_COEFFS, ONLY: IRKPS,IRKPS0,IRLPS,IRLPS0
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DMQSSS, ONLY: DSSS,MSSS,QSSS
      USE COMMON_DMQSSS, ONLY: IRSS,IRSS0,NLS,NLS00
      USE COMMON_NSTS1,  ONLY: NADS1,NSTJ1,NSTJ1D,IORIG1,JORIG1
      USE COMMON_NSTS2,  ONLY: NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2
!
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL4, ONLY: MBP1MX,MBP2MX,MEKVMX,KUTM1,MPOLM,QCUT
      USE COMMON_NRBAL4, ONLY: DVC12,NC0X,MJS1,MJL1,MJS2,MJL2,MJJL,MJJR &
     &                  ,NC,ND,ICLR,QLIT,BLX1,BLX2,BMSKIP,BOSKIP,BM1BODY
      USE COMMON_NRBAL4, ONLY: DVC,MJ1,MJ2,MLAM,BE1CASE
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M5)
!      PARAMETER (DTOL=D1M8)
      PARAMETER (DFAC1=DTEN/(DTHREE*256))
!
      DIMENSION QLMC(MAXEL,*),MAM(*),NAM(*),VC1(*)
      DIMENSION IGAM(5),ILAM(200),CLTM2(200),CLTM(:)
!
      DATA BDEBUG1,BDEBUG /.FALSE.,.FALSE./
!
      POINTER :: CLTM,MCTO
      TARGET :: CLTM2,MLK
!
      CLTM=>CLTM2(1:10)
      MCTO=>MLK
!
!      EQUIVALENCE (MCTO,MLK),(CLTM2(1),CLTM(1))
!
!-----------------------------------------------------------------------
!
      BPLANT1=MXORB.LT.200.OR.SP.EQ.8
      BPLANT2=MXORB.LT.37.OR.SP.EQ.8
!
      IFOTMX=0
      IF(BFOT)IFOTMX=1
!
      DQ2=SQRT(DTWO)
      DQ3=SQRT(DTHREE)
      DQ3O2=SQRT(DTHREE/DTWO)
      DQ3O4=DQ3/DTWO
!
      MLAM1=MLAM-2
      MLAM2=MLAM+2
      MLAMH=MLAM/2
      MLK=MJ1-MJ2
      MXLL=0
!
      IRLPS1=IRLPS0+1
      NLS01=NLS00+1
!
      IF(ICLR.LT.0)GO TO 1400
!      BEQUCFG=KF.EQ.KG
      JBB=JBP
!
!     IN LOOPS 64,65 SCAN THROUGH SLATER STATES IN INITIAL AND
!     FINAL STATES RESP., AND CALCULATE CONTRIBUTIONS DUE TO EACH PAIR.
!
      DO J1=JA,JB                                        !BEGIN 64
!
        L1=MAM(J1)
!
!      IF(BEQUCFG)JBB=J1
        DO J2=JAP,JBB                                    !BEGIN 65
!
          L2=NAM(J2)
!
!     CALCULATE TRANSFORMATION COEFFICIENT FROM THE LS,ML,MS
!     REPRESENTATION TO THE J,MJ REPRESENTATION.
!
          DDH=DVC12
          IF(ABS(DDH).LT.TYNY)GO TO 1200
                                      ! DTOL -> TYNY
!
!THESE NEXT 2 STATEMENTS RESOLVE INTERACTIONS BY SLATER STATE
!OLD      IRKPS00=IRKPS+1
!OLD      IRSS00=IRSS+1
!
          DO I=IRLPS1,IRLPS
            IORIG1(I)=0
          ENDDO
          DO I=NLS01,NLS
            IORIG2(I)=0
          ENDDO
!
!     NOW COMPARE INITIAL AND FINAL SLATER STATES AND SELECT ONLY THE
!     ONES WHICH DIFFER IN NK=0, 1, OR 2 SETS OF QUANTUM NUMBERS
!
          NK=0
          N2=0
          MU=0
          DO I=1,NF
            N2P=QLMC(I,L1)
            ICG2=QCG(I,KF)
            DO L=1,NF
              IF(QLMC(L,L2).NE.N2P)GO TO 10
              IF(IEQ(QCG(L,KG)).NE.IEQ(ICG2))GO TO 10
              LP=L
              GO TO 30
   10       ENDDO
            NK=NK+1
            IF(NK.GT.2)GO TO 1200
            IF(NK.EQ.2)THEN
              IF(BM1BODY.OR.BMSKIP)GO TO 1200
                                       !******** ONE-BODY SWITCH *******
              GO TO 20
            ENDIF
            N1=I
   20       N1P=I
            MU=I+MU
            LP=0
   30       QLMC(I,1)=INT(LP,QP)
          ENDDO
!
          IF(NK.EQ.0)GO TO 60
          DO L=1,NF
            DO I=1,NF
              IF(QLMC(I,1).EQ.L)GO TO 40
            ENDDO
            N2P=L
            MU=L+MU
            IF(N2.NE.0)GO TO 80
! TMP IF(N2.NE.0)GO TO 65
            N2=N2P
            IF(NK.EQ.1)GO TO 80
!     L1 AND L2 DIFFER IN ONE PAIR, IN POSITIONS NUMBERED N1 AND N2
   40     ENDDO
!
   60     N2=N2+1
          IF(N2.GT.NF)GO TO 1180
          N1=N2
   80     ICG1=QCG(N1,KF)
          ICG2=QCG(N2,KG)
          IFOT1=0
          IF(QN(ICG1).GE.90)IFOT1=1
          IFOT2=0
          IF(QN(ICG2).GE.90)IFOT2=1
!
          IFOT12=IFOT1+IFOT2
          IF(IFOT12.GT.IFOTMX)GO TO 1160       !OMIT CONTINUUM-CONTINUUM
!
!     FIND THE AZIMUTHAL COMPONENTS OF L AND S FOR THE INDIVIDUAL
!     ELECTRONS, WHOSE NUMBERS ARE N1,N2.
!
          LR=QL(ICG2)
          LL=QL(ICG1)
          LAM=QLMC(N2,L2)
          QLML2=INT(((LAM+100)/2)*2-100,QP)
          QLMS2=INT((LAM-QLML2)*2-1,QP)
          LAM=INT(QLMC(N1,L1),SP)
          QLML1=INT(((LAM+100)/2)*2-100,QP)
          QLMS1=INT((LAM-QLML1)*2-1,QP)
!
          IF(BM1BODY)THEN !************** ONE-BODY SWITCH **************
            IF(BE1CASE)GO TO 820
            IF(ABS(MBP2MX).LT.MLAM)GO TO 1060
          ENDIF
!
          IF(QLIT(10).EQ.QCUT)GO TO 820
          IF(BMSKIP)THEN
            IF(MBP1MX.LT.0)GO TO 1060
                                    !for type 9 pure mk
            GO TO 820          !for type 8 etc., i.e. inc. alpha^2 corr.
          ENDIF
          IF((QCUT.EQ.QLIT(8).OR.NC.NE.ND).AND.BOSKIP)GO TO 820
!
          LAM=NF
          IF(NK.GT.1)GO TO 160
          IF(NK.EQ.1)GO TO 100
          LAM=N1
  100     N1P=-NW
  120     N1P=N1P+1
          IF(N1P.GT.0)GO TO 140
          KP=N1P+NW
          ICG1P=NNL(KP,1)
          ICG2P=ICG1P
          M1=NNL(KP,2)                                !M1<-MA (NOT CORE)
          M2=M1                                       !M2<-MC
          GO TO 180
  140     IF(N1P.GT.LAM)GO TO 820
          IF(N1P.EQ.N1)GO TO 120
          N2P=QLMC(N1P,1)
! TST ICG1P=QCG(N1P,KF);  ICG2P=ICG1P
! TST M1=QLMC(N1P,L1);    M2=M1;         GO TO 78     !MC=MA
  160     ICG1P=QCG(N1P,KF)
          ICG2P=QCG(N2P,KG)
          M1=QLMC(N1P,L1)                             !M1<-MA (NOT CORE)
          M2=QLMC(N2P,L2)                             !M2<-MC
  180     QLML2P=INT(((M2+100)/2)*2-100,QP)           !M2<-MC
          QLMS2P=INT((M2-QLML2P)*2-1,QP)              !M2<-MC
          QLML1P=INT(((M1+100)/2)*2-100,QP)           !M1<-MA
          QLMS1P=INT((M1-QLML1P)*2-1,QP)              !M1<-MA
          LLP=INT(QL(ICG1P),SP)
          LRP=INT(QL(ICG2P),SP)
          KP=1
  200     KO=1
  220     LO=ABS(LL-LR)
          IF(LO.GT.6.OR.MBP2MX.LT.0)GO TO 800
                                          !***** ONE-BODY SWITCH *****
!
          I1P=ABS(LLP-LRP)
!       ETC.............
          ILAM(200)=9999
! +-+   +++++++++++++++++++++++++++++++++++++++
!     CLAUDE, INSERT HSC.CZMAGADD.FORT HERE
!     CLTM2(199)=DDH*KO*KP;  ILAM(199)=-9999
!
          KTERM=200
          MTEST2=QLMS1-QLMS2
          MTES2P=QLMS1P-QLMS2P
          IF(MTEST2.NE.0.AND.MTES2P.NE.0)GO TO 800
          MX=-MTEST2-MTES2P
          MTEST1=QLML1-QLML2
          MTES1P=QLML1P-QLML2P
          MP1=QLML1+QLML2+QLML1P+QLML2P
          DDS=DZERO
          IF(MTES2P.NE.0)GO TO 260
!!    DDS=.5773502691896
          DDS=-DONE/DQ3
!!         -'''             TO ABSORB FACTOR (-1)**(-QLMS1-QLMS2)
          IF(QLMS1+QLMS2.NE.0)GO TO 240
          DDS=SQRT(DTWO/DTHREE)
  240     IF(QLMS1.GT.0)DDS=-DDS
          IF(MTEST2.NE.0)GO TO 300
  260     DD=-DONE/DQ3
          IF(QLMS1P+QLMS2P.NE.0)GO TO 280
          DD=SQRT(DTWO/DTHREE)
  280     IF(QLMS1P.GT.0)DD=-DD
          DDS=DD+DDS
  300     I2P=LLP+LRP
          LP=LL+LR
          LA=LO
!
  320     D2C2=VCC(LR,LA,LL,IZERO,IZERO,IZERO)
!
          ID=LA+2
          IC=ABS(LA-2)
          LB=MAX(LA-2,LO)
  340     IF(LB.GT.LP)GO TO 720
          IF(ABS(MTEST1).GT.LB)GO TO 700
!
          D2C3=VCC(LL,LB,LR,-INT(QLML1,SP),MTEST1,-INT(QLML2,SP))
!
          IF(MX.NE.0)GO TO 420
! JJJ  DD   =SJS(LA,ITWO,LB,LR,LL,LR) *
! JJJ X         SQRT(REAL((LA+1)*(LB+1)*(LR+2)*(LR+1)*LR*3,WP))
          LM=LA+2
          IF(LA.GT.LB)GO TO 380
          IF(LA.LT.LB)GO TO 360
          D2C6J=DZERO
          IF(LA.EQ.0)GO TO 420
          D2C6J=((LL+2)*LL-(LR+2)*LR-LM*LA)                             &
     &          *SQRT(((LA+1)*3)/REAL(LM*LA*4,WP))
          GO TO 400
  360     D2C6J=-SQRT(((LR+LL+LA+4)*(LR-LL+LM)*(LM+LL-LR)*(LR+LL-LA)*3) &
     &          /REAL(8*LM,WP))
          GO TO 400
  380     D2C6J=SQRT(((LR+LL+LM)*(LR-LL+LA)*(LA+LL-LR)*(LR+LL-LA+2)*3)  &
     &          /REAL(8*LA,WP))
  400     CONTINUE
!
! JJJ IF(ABS(D2C6J-DD).GT.1.E-4)WRITE(MW6,888)LL,LR,LA,LB, D2C6J, DD
! 888 FORMAT( '  *** LL,LR,LA,LB: SJS ***  ',4I4,2F10.5)
!
  420     LC=I1P
!
  440     D2C4=VCC(LRP,LC,LLP,IZERO,IZERO,IZERO)
!
          IB=LC+2
          IA=ABS(2-LC)
          LD=LC
! 258 IF(LD.LT.I1P.OR.LD.GT.I2P)GO TO 209
          IF(ABS(MTES1P).GT.LD)GO TO 680
!
          D2C5=VCC(LLP,LD,LRP,-INT(QLML1P,SP),MTES1P,-INT(QLML2P,SP))
!
          IF(LB.NE.LA)GO TO 540
          IF(DDS.EQ.DZERO)GO TO 540
          IF(LA.NE.LC)GO TO 460
          IF(MTEST1.NE.-MTES1P)GO TO 460
          KTERM=KTERM-1
          IF(KTERM.LE.0)GO TO 2100
!     CLTM2(KTERM)=(1-MOD(ABS(MCTO+MTEST1),4))*DDS*D2C2*D2C3*
          CLTM2(KTERM)=(MOD(ABS(MTEST1),IFOUR)-1)                       &
     &                 *DDS*D2C2*D2C3*D2C4*D2C5*DQ3
          ILAM(KTERM)=LA
  460     LF=IA
          M1=MTEST1-MX                                !M1<-MA
          DD=-1
          IF(LC.EQ.0)GO TO 480
          DD=(MOD(LC,IFOUR)-1)/SQRT(REAL(LC+1,WP))
          LM=(LC+1)*(LC-1)
          M2=-600                                     !M2<-MC
          GO TO 500
  480     LM=-(LC+1)*(LC+3)
          M2=600                                      !M2<-MC
  500     IF(ABS(LF-LA).NE.2)GO TO 520
          KTERM=KTERM-1
          IF(KTERM.LE.0)GO TO 2100
          II=(LA-LF+2)/4+LF
          KK=(LC-LF+2)/4+LF
          if(ii.gt.nc0x.or.kk.gt.nc0x)then
            stop '*** sr.algeb4: vc1 not set'         !temp
          endif
!t      mc0x=max(mc0x,ii,kk)
!
!     NOTE: (-1)**((LA+LC)/2)=+1, BECAUSE M1-TRANSITIONS CONSERVE PARITY
!
!
! CLAUDE+  CLTM2(KTERM)=2*LM*D2C2*D2C3*D2C4*D2C5/SQRT(3.)
! CLAUDE, SECTION 'MX.NE.0' BUG FREE I HOPE, SINCE JULY 23. WERNER AUG80
!
          CLTM2(KTERM)=((MOD(ABS(MX-MP1),IFOUR)-1)*LM*2)                &
     &                 *D2C2*D2C3*D2C4*D2C5*DDS*VCC(LF,ITWO,LA,M1,MX,   &
     &                 MTEST1)*VC1(II)*DD*VCC(LC,LF,ITWO,MTES1P,M1,MCTO)&
     &                 *VC1(KK)                              !M1<-MA
!
!     VC1(II)=VCC(LF,ITWO,LA,IZERO,IZERO,IZERO)
!     VC1(KK)=VCC(LC,LF,ITWO,IZERO,IZERO,IZERO)
!
          ILAM(KTERM)=SIGN(LC,M2)+M2                  !M2<-MC
  520     LF=LF+4
          IF(LF.LE.IB)GO TO 480
! --- IF(MTEST2.NE.0.OR.MTES2P.NE.0)    I.E.
  540     IF(MX.NE.0)GO TO 680
          IF(MJS2.NE.MJS1)GO TO 680
          IF(LB+LC.EQ.0)GO TO 680
          IF(ABS(LC-LB).GT.2)GO TO 680
!
          D2C0=((MOD(ABS(MTES1P+MP1),IFOUR)-1)*2)                       &
     &         *SQRT(REAL((LC+1)*3,WP))                                 &
     &         *VCC(LC,ITWO,LB,-MTES1P,MCTO,MTEST1)*D2C2*D2C3*D2C4*D2C5
!
          LE=IA
!
  560     DC1=SJS(ITWO,ITWO,ITWO,LE,LD,LB)
!
          DL1=DONE/SQRT(REAL(LE+1,WP))
          KK=(LC-LE+2)/4+LE
          LF=IC
  580     II=(LA-LF+2)/4+LF
          if(ii.gt.nc0x.or.kk.gt.nc0x)then
            stop '*** sr.algeb4: vc1 not set'         !temp
          endif
!t      mc0x=max(mc0x,ii,kk)
          DD1=VC1(II)*VC1(KK)*DC1*D2C0
!
!     VC1(II)=VCC(LF,ITWO,LA,IZERO,IZERO,IZERO)
!     VC1(KK)=VCC(ITWO,LE,LC,IZERO,IZERO,IZERO)
! EVT IF(DD1.EQ.0.)  GO TO 268
!
          DC2=SJS(ITWO,ITWO,ITWO,LA,LB,LF)
!
          DL2=SQRT(REAL(LF+1,WP))
          LG=ABS(2-LE)
          IF(LE.EQ.0)GO TO 600
          LM=(LE+1)*(LE-1)
          M2=-500-LE                                  !M2<-MC
          M1=-600-LE+2                                !M1<-MA
          GO TO 620
  600     LM=-(LE+1)*(LE+3)
          M2=LE+2+700                                 !M2<-MC
          M1=LE+2+600                                 !M1<-MA
  620     IF(ABS(LG-LF).NE.2)GO TO 640
          IF(KTERM.LT.5)GO TO 2100
          I=(LF-LG+2)/4+LG
          K=(LE-LG+2)/4+LG
          if(i.gt.nc0x.or.k.gt.nc0x)then
            stop '*** sr.algeb4: vc1 not set'         !temp
          endif
!t      mc0x=max(mc0x,i,k)
!
!     VCC(ITWO,LG,LF,IZERO,IZERO,IZERO)=VC1(I);VCC(LE,LG,2,..)
!                                      =(MOD(LE,4)-1)* VC1(K)*DL1*SQR(3)
          DD=LM*SJS(LE,LG,ITWO,LF,LB,ITWO)*DD1*VC1(I)*VC1(K)*DL1*DL2
          KTERM=KTERM-1
          CLTM2(KTERM)=D2C6J*DC2*DD
!
! CLAUDE, I REINTRODUCED, NOW THROUGH D2C0, A PHASE FACTOR (-1)**MP1
! WHICH YOU HAD THROWN OUT WITH PHS0 IN JUL. PLEASE CLARIFY. WERNER 80AU
          ILAM(KTERM)=M1                              !M1<-MA
          IF(LB.NE.LA)GO TO 640
          KTERM=KTERM-1
          CLTM2(KTERM)=DD*DQ2
          ILAM(KTERM)=M2                              !M2<-MC
  640     LG=LG+4
          IF(LG.LE.LE+2)GO TO 600
          IF(LF.NE.LE)GO TO 660
!
!     NOTE: LF=LC-2 AND LC+2 (SUBJECT TO .GE.LA-2, .LE.LA+2, SEE IC ID)
!           LE=LC-2 AND LC+2; THUS ALWAYS ONE MATCH FOR LF IN SET LE.
!
          KTERM=KTERM-1
          CLTM2(KTERM)=DC2*D2C6J*DD1
          ILAM(KTERM)=-400-LF
          IF(LB.NE.LA)GO TO 660
          KTERM=KTERM-1
          CLTM2(KTERM)=DD1*DQ2
          ILAM(KTERM)=-300-LF
  660     LF=LF+4
          IF(LF.LE.ID)GO TO 580
          LE=LE+4
          IF(LE.LE.IB)GO TO 560
!
!Q219 IF(MX.NE.0)  GO TO 209
!       ARCHIVED HSC.CZDIRAFS.MAR80.DATA OF MARCH 15TH DOES NOT YET MAKE
!       USE OF PARTICLE SYMMETRY PROPERTIES-HAS OLD BULKY CODE.
!
!O209 LD=LD+2
!O    IF(LD.LE.IB)GO TO 258
  680     LC=LC+4
          IF(LC.LE.I2P)GO TO 440
  700     LB=LB+2
          IF(LB.LE.ID)GO TO 340
  720     LA=LA+4
          IF(LA.LE.LP)GO TO 320
!
! +-+   +++++++++++++++++++++++++++++++++++++++
!
          PHS0=(1-MOD((MU+KO+KP)*2,IFOUR))*DDH
          CLTM2(200)=DZERO
! TST CLTM2(200)=(1-MOD(MJJR-MJ2,IFOUR))*DVC/(17.320508*PHS0)
!
!
! *** STORE TWO-BODY COEFFICIENTS ***
!
          DO K=KTERM,200
!
            DD=CLTM2(K)
            IF(DD.EQ.DZERO)GO TO 780
            LM=ILAM(K)
            M2=(ABS(LM)+2)/100                       !M2<-MC
! XXX IF(M2.NE.0) DD=DD+DD                            !M2<-MC
! XXX CLAUDE HAS NOW ABSORBED FACTORS 2 INTO CLTM2  -- 1980 JULY
            KK=0
            II=0
!-TST IF(M2.GT.4)GO TO 277                            !M2<-MC
            IF(LM.LT.0)GO TO 730
            IF(M2.GT.0)GO TO 740                      !M2<-MC
            IF(ICG1.LE.ICG2)GO TO 740
  730       LM=ABS(LM)
! 275 CONTINUE
            II=1-II
  740       IGAM(1+II+KK)=ICG1
            IGAM(2-II+KK)=ICG1P
            IGAM(3+II-KK)=ICG2
            IGAM(4-II-KK)=ICG2P
!NRB      IF(KK.NE.0)  GO TO 279
! TST IF(LM.EQ.9999)  GO TO 279
!NRB      IF(IGAM(1).LT.IGAM(3))GO TO 279
!NRB      KK=2
!NRB      IF(M2.NE.0)  GO TO 278                      !M2<-MC
!NRB      IF(IGAM(4).LT.IGAM(3))GO TO 275
!NRB  278 IF(MOD(M2,2).EQ.0)  GO TO 277               !M2<-MC
!NRB  279 CONTINUE
            IGAM(5)=LM
! EVT    ADD CODE TO REDUCE NUMBER OF INTEGRALS INVOLVING A DERIVATIVE
!
! STORE CONTRIBUTION TO (EXISTING) COEFFICIENT
!
            IF(BPLANT2)IPLANT=IGAM(5)                                   &
     &                        +((((IGAM(4)*MXORB+IGAM(3))*MXORB+IGAM(2))&
     &                        *MXORB)+IGAM(1))*1000
            DO J=NLS01,NLS
              IF(.NOT.BPLANT2)THEN
                DO I=5,1,-1                               !1,5 SLOWER
                  IF(QSSS(I,J).NE.IGAM(I))GO TO 750
                ENDDO
              ELSE
                IF(IPLANT.NE.JORIG2(J))GO TO 750
              ENDIF
              L=J
              I=IORIG2(L)
              IF(I.GT.0)THEN
                DSSS(I)=DD*PHS0+DSSS(I)
                GO TO 780
              ENDIF
              GO TO 760
  750       ENDDO
!
! CANNOT FIND OLD SET OF ARGUMENTS, SO START CONSTRUCTING A NEW SET
!
            L=NLS+1
            IF(L.GT.IXS2I)THEN
!
              IXXX=7*(IXS2I/5+1)
!
              WRITE(MW6,*)'*** MKALG1: increasing MXS2I from ',IXS2I,   &
     &                    ' to: ',IXXX
              WRITE(MW0,*)'*** MKALG1: increasing MXS2I from ',IXS2I,   &
     &                    ' to: ',IXXX
!
              CALL RE_ALLOC2(QSSS,IONE,IFIVE,IONE,IXS2I,IFIVE,IXXX,IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)'MKALG1: RE-ALLOCATION FAILS FOR QSSS'
                NF=0
                GO TO 2000
              ENDIF
!
              IXXX0=MAX(IXS2I,IAXMI)
              IXXX2=MAX(IXXX,IAXMI)
              IF(IXXX2.GT.IXXX0)CALL RE_ALLOC(IORIG2,IONE,IXXX0,IXXX2,  &
     &           IERR)
              CALL RE_ALLOC(JORIG2,IONE,IXS2I,IXXX,IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)                                            &
     &                   'MKALG1: RE-ALLOCATION FAILS FOR IORIG2,JORIG2'
                NF=0
                GO TO 2000
              ENDIF
!
              IXS2I=IXXX
!
            ENDIF
!
            NLS=L
            DO I=1,5
              QSSS(I,L)=INT(IGAM(I),QP)
            ENDDO
            IF(BPLANT2)JORIG2(L)=IPLANT
!
  760       IRSS=IRSS+1
            IF(IRSS.GT.IXS2C)THEN
!
              IXXX=7*(IXS2C/5+1)
!
              WRITE(MW6,*)'*** MKALG1: increasing MXS2C from ',IXS2C,   &
     &                    ' to: ',IXXX
              WRITE(MW0,*)'*** MKALG1: increasing MXS2C from ',IXS2C,   &
     &                    ' to: ',IXXX
!
              CALL RE_ALLOC(DSSS,IONE,IXS2C,IXXX,IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)'MKALG1: RE-ALLOCATION FAILS FOR DSSS'
                NF=0
                GO TO 2000
              ENDIF
!
              CALL RE_ALLOC(MSSS,IONE,IXS2C,IXXX,IERR)
              CALL RE_ALLOC(NSTJ2,IONE,IXS2C,IXXX,IERR)
              CALL RE_ALLOC(NSTJ2D,IONE,IXS2C,IXXX,IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)'MKALG1: RE-ALLOCATION FAILS FOR MSSS,NSTJ2'
                NF=0
                GO TO 2000
              ENDIF
!
              IXS2C=IXXX
!
            ENDIF
!
            IORIG2(L)=IRSS
            MSSS(IRSS)=L
            DSSS(IRSS)=DD*PHS0
            NSTJ2(IRSS)=L1
            NSTJ2D(IRSS)=L2
!
  780     ENDDO
!
! *** END STORE TWO-BODY COEFFICIENTS ***
!
!
! *********************** END TWO-BODY SECTION *************************
!
  800     II=ICG1P
          ICG1P=ICG1
          ICG1=II
          LM=LLP
          LLP=LL
          LL=LM
          KK=QLML1P
          QLML1P=QLML1
          QLML1=INT(KK,QP)
          KK=QLMS1P
          QLMS1P=QLMS1
          QLMS1=INT(KK,QP)
          KO=KO-1
          IF(KO.GE.0)GO TO 220
          II=ICG2P
          ICG2P=ICG2
          ICG2=II
          LM=LRP
          LRP=LR
          LR=LM
          II=QLML2P
          QLML2P=QLML2
          QLML2=INT(II,QP)
          II=QLMS2P
          QLMS2P=QLMS2
          QLMS2=INT(II,QP)
          KP=KP-1
          IF(KP.GE.0)GO TO 200
          IF(NK.GT.1)GO TO 1200
          GO TO 120
  820     IF(NK.GT.1)GO TO 1200
          IF(ABS(LL-LR).GT.4)GO TO 1160
          MTEST2=QLMS1-QLMS2
          MTEST1=QLML1-QLML2
          DD=DZERO
          IF(MXLL.EQ.-1)DD=DONE
          DO K=1,8
            CLTM(K)=DD
          ENDDO
!
          IF(BDEBUG1)WRITE(MW6,10020)NK,L1,L2,LL,LR
!
!
! CCC DDS=VCC(IONE,ITWO,IONE,-QLMS1,MTEST2,-QLMS2)
!
          DDS=DONE/DQ3
          IF(QLMS1+QLMS2.NE.0)GO TO 840
          DDS=DONE/DQ3O2
  840     IF(QLMS1.GT.0)DDS=-DDS
          M2=1-ABS(MCTO)                             !M2<-MC
          LP=1
!
          IF(BE1CASE)GO TO 960
                           !************** ONE-BODY SWITCH *************
!
          LAM=(LL+2)*LL
          IF(BMSKIP)GO TO 920
          IF(LL+LR.EQ.0)GO TO 1000
          M1=1-ABS(MTEST2)                           !M1<-MA
!
          DD=VCC(LR,IFOUR,LL,IZERO,IZERO,IZERO)
          DL2=VCC(LL,IFOUR,LR,-INT(QLML1,SP),MTEST1,-INT(QLML2,SP))
          DC2=VCC(ITWO,IFOUR,ITWO,MTEST2,MTEST1,MCTO)*(M2*M1) !MC*MA
!
          CLTM(2)=-((LAM-(LR+2)*LR+24))*DL2*DD*DC2*DDS*SQRT(DFAC1)
          CLTM(3)=-((LAM-(LR+2)*LR-24))*DL2*DD*DC2*DDS*SQRT(DFAC1)
          CLTM(4)=-DL2*DD*DC2*DDS*SQRT(DTEN/DTHREE)
          CLTM(5)=CLTM(4)
! *** CLTM(1)=.......                    TERM  LM=MIN(LL,LR)+2
          DL1=6               !4->6
          LM=LL+2
          IF(LR.GT.LL)GO TO 880
          IF(LR.EQ.LL)GO TO 860
          LM=LR+2
          DC1=(LM-2)*LM
          DD1=(LM+3)*5
          DD2=LM-1
          GO TO 900
! 131 DL1=6
  860     DL1=12
          DC1=-(LM+2)*(LM-2)
          DD1=(LM-3)*(LM-2)*15
          DD2=(LM-1)*LM*2
          GO TO 900
  880     DC1=(LM+2)*(LM+4)
          DD1=(LM-1)*5
          DD2=LM+3
  900     II=(LM-LL+2)/4+LL
          KK=(LR-LM+2)/4+LM
          if(ii.gt.nc0x.or.kk.gt.nc0x)then
            stop '*** sr.algeb4: vc1 not set'         !temp
          endif
!t      mc0x=max(mc0x,ii,kk)
!
! TST  CLTM(1)=VCC(LL,ITWO,LM,IZERO,IZERO,IZERO)
! TST X        *VCC(LM,ITWO,LR,IZERO,IZERO,IZERO)
! TST X        *SJS(LL,LM,ITWO,ITWO,ITWO,LM)
! TST X        *SJS(LM,LR,ITWO,ITWO,ITWO,LR)
! TST X        *SJS(LL,LR,IFOUR,ITWO,ITWO,LM)
! TST X        *((LM+1)*30)*DC2*DL2*DDS
! TST X        *SQRT(REAL((LR+2)*LR*(LL+1)*(LM+2)*LM,WP))+CLTM(1)
!
          CLTM(1)=VC1(II)*VC1(KK)*SQRT(DD1/DD2)*DC2*DL2*DDS*DC1/DL1+    &
     &            CLTM(1)
!
          IF(LR.NE.LL)GO TO 1040
          IF(LM.LT.LL)GO TO 940
          LM=LL-2
          IF(LM.EQ.0)GO TO 940
! *** 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 900
  920     LP=8
          IF(MTEST2.NE.0)GO TO 1000
  940     IF(ABS(MTEST1).GT.2)GO TO 1040
!
  960     DL1=VCC(LL,ITWO,LR,-INT(QLML1,SP),MTEST1,-INT(QLML2,SP))
!
          IF(BMSKIP.AND..NOT.BE1CASE)GO TO 980
!
          DC1=VCC(ITWO,ITWO,ITWO,MTEST2,MTEST1,MCTO)
!
          IF(BE1CASE)GO TO 1060
                           !************** ONE-BODY SWITCH *************
!
          DD1=SQRT(REAL(LAM,WP)/6)
          DD2=SQRT(REAL((LL+LR-2)*(LL+LR+6),WP)/24)*(M1*DD)      !M1<-MA
!     CLTM(2)=(DD1*M1-DD2)*DL1*DC1+CLTM(2)                       !M1<-MA
!     CLTM(3)=-(DD1*M2+DD2)*DL1*DC1+CLTM(3)                      !M2<-MC
          DD=(DD1*M1-DD2)*DL1*DC1*M2*DDS                  !M1<-MA,M2<-MC
          CLTM(3)=DD+CLTM(3)
          CLTM(2)=CLTM(2)-DD
          IF(MTEST2.NE.0)GO TO 1000
  980     CLTM(8)=(MOD(ABS(INT(QLMS1+QLMS2,SP)),IFOUR)-1)               &
     &            *M2*SQRT(REAL(LAM/4,WP))*DL1                   !M2<-MC
 1000     IF(MTEST1.NE.0)GO TO 1020
          DD=DDS*DQ3
          CLTM(8)=CLTM(8)+DD
          IF(BMSKIP)GO TO 1020
          CLTM(4)=CLTM(4)+DD/3
          CLTM(5)=CLTM(4)-DD
          IF(LL.NE.0)CLTM(1)=(LAM*DD)/12+CLTM(1)
! OUT IF(QN(ICG2).NE.QN(ICG1))  GO TO 126
          CLTM(6)=DD
 1020     IF(BDEBUG)WRITE(MW6,10010)CLTM(6),CLTM(8)
 1040     MX=8
          KTERM=8
          CLTM(7)=CLTM(5)
          PHS0=(1-MOD((N1+N2)*2+QLMS1+QLMS2,IFOUR))*DDH
          GO TO 1100
!
! ***************** BEGIN NON-BP MK (ONE-BODY) SECTION *****************
!
 1060     IF(.NOT.BE1CASE)THEN           ! CASE MK
            DDV=VCC(LL,MLAM1,LR,IZERO,IZERO,IZERO)
            DD=DZERO
            LP=10
            KTERM=9
            IF(DDV.EQ.DZERO)GO TO 1070
            DDL=DZERO
            IF(QLMS2.EQ.QLMS1)THEN ! CONTRIBUTION {C[K-1]XL[1]}[K]/DD1
              MMM=(MLAM-LL-LR)/2
              ISGN=1-2*mod(abs(MMM),ITWO)
!                                                   !SJS: MLAM1,2 WRONG!
              DDL=VCC(LR,MLAM,LL,INT(QLML2,SP),MLK,INT(QLML1,SP))       &
     &            *SJS(LL,LR,MLAM,ITWO,MLAM1,LR)                        &
     &            *SQRT(REAL((MLAM+1)*(LR+1)*LR/2*(LR/2+1),WP))*ISGN
            ENDIF                     ! PLUS {C[K-1] X (K+1)S[1]}[K]/DD1
!      WRITE(MW6,*)'L',LR,MLAM,LL,QLML2,MLK,QLML1,DDL
            MMM=(MLAM1-LL-LR)/2                !-LL-LR
            ISGN=1-2*mod(abs(MMM),ITWO)
            MQL=QLML1-QLML2
            MQS=QLMS1-QLMS2
            DDS=VCC(LR,MLAM1,LL,INT(QLML2,SP),MQL,INT(QLML1,SP))        &
     &          *VCC(IONE,ITWO,IONE,INT(QLMS2,SP),MQS,INT(QLMS1,SP))    &
     &          *VCC(MLAM1,ITWO,MLAM,MQL,MQS,MLK)*DQ3O4*(MLAMH+1)*ISGN
!      WRITE(MW6,*)'S',LR,MLAM1,LL,QLML2,MQL,QLML1,QLMS2,MQS,QLMS1,DDS
            DD=DDS+DDL
            IF(DD.NE.DZERO)THEN
              LP=9
              CLTM(9)=2*DD*DDV*SQRT(REAL(MLAMH*(MLAM-1),WP))/(MLAMH+1)
!
              DD=-DD*SQRT(REAL(MLAMH*(MLAM-1),WP))/((MLAMH+1)*(MLAM+1))
            ENDIF
!
            IF(MLAM.GT.MBP1MX.AND.IFOT12.eq.0)GO TO 1080
!
 1070       CONTINUE                         !LOOK FOR LAM+1 IF NO LAM-1
!
!      WRITE(MW6,*)MJ1,MJ2,LL,LR,QLML1,QLML2,QLMS1,QLMS2,MLAM2,MLAM,MLK
            DDV1=VCC(LL,MLAM2,LR,IZERO,IZERO,IZERO)
            IF(ABS(DD)+ABS(DDV1).EQ.DZERO)GO TO 1160
            IF(DDV1.EQ.DZERO)GO TO 1080
            DDL1=DZERO
            IF(QLMS2.EQ.QLMS1)THEN ! CONTRIBUTION {C[K+1]XL[1]}[K]/DD1
              MMM=(MLAM-LL-LR)/2
              ISGN=1-2*mod(abs(MMM),ITWO)
!                                                   !SJS: MLAM2,2 WRONG!
              DDL1=VCC(LR,MLAM,LL,INT(QLML2,SP),MLK,INT(QLML1,SP))      &
     &             *SJS(LL,LR,MLAM,ITWO,MLAM2,LR)                       &
     &             *SQRT(REAL((MLAM+1)*(LR+1)*LR/2*(LR/2+1),WP))*ISGN
!      WRITE(MW6,*)'L1',LR,MLAM,LL,QLML2,MLK,QLML1,DDL1
            ENDIF                     ! PLUS {C[K+1] X (K+1)S[1]}[K]/DD1
            MMM=(MLAM2-LL-LR)/2                !-LL-LR
            ISGN=1-2*mod(abs(MMM),ITWO)
            MQL=QLML1-QLML2
            MQS=QLMS1-QLMS2
            DDS1=VCC(LR,MLAM2,LL,INT(QLML2,SP),MQL,INT(QLML1,SP))       &
     &           *VCC(IONE,ITWO,IONE,INT(QLMS2,SP),MQS,INT(QLMS1,SP))   &
     &           *VCC(MLAM2,ITWO,MLAM,MQL,MQS,MLK)*DQ3O4*MLAMH*ISGN
!      WRITE(MW6,*)'S1',LR,MLAM2,LL,QLML2,MQL,QLML1,QLMS2,MQS,QLMS1,DDS1
            DD1=(DDS1+DDL1)
            DD1=DD1*2*SQRT(REAL((MLAM+3)/(MLAMH+1),WP))                 &
     &          /((MLAM+3)*(MLAM+1))
!
            DD=DD+DD1
            IF(DD.EQ.DZERO)GO TO 1160
            KTERM=10
            CLTM(10)=DD*DDV1
!  N.B. VC12 ALREADY IN DDH, BUT COUPLED LSJ, NOT SLJ!
 1080       PHS0=DDH*(1-MOD((N1+N2)*2+MJL1+MJS1+MJJL+MJL2+MJS2+MJJR,    &
     &           IFOUR))
!      WRITE(MW6,*)MJ1,MJ2,LL,LR,QLML1,QLML2,QLMS1,QLMS2,MLAM2,MLAM,MLK
!      write(mw6,*)'lam=',mlam/2,'c9=',ddv,ddh,cltm(9)*phs0
          ELSE                       ! CASE E1VEL
            KTERM=1
            II=(LL-LR+2)/4+LR
            if(ii.gt.nc0x)then
              stop '*** sr.algeb4: vc1 not set'        !temp
            endif
!t        mc0x=max(mc0x,ii)
            CLTM(1)=DC1*DDS*DL1*VC1(II)*SQRT(REAL(2*(MLAM+1),WP))
            PHS0=M2*DDH                               !M2<-MC
          ENDIF
!
! ****************** END NON-BP MK (ONE-BODY) SECTION ******************
!
! *** STORE ONE-BODY COEFFICIENTS ***
!
 1100     IGAM(3)=MLAM
          DO K=LP,KTERM
!
            DD=CLTM(K)*PHS0
            IF(DD.EQ.DZERO)GO TO 1140
            M1=ICG1                                   !M1<-MA
            M2=ICG2                                   !M2<-MC
            IF(ICG1.GE.ICG2)GO TO 1110
            IF(K/2.EQ.1)GO TO 1110
            M1=M2                                     !MA=MC
            M2=M2-ICG2+ICG1                           !MC=MC-...
 1110       MX=MX-1
!
            IGAM(1)=M1                                !M1<-MA
            IGAM(2)=M2                                !M2<-MC
            IGAM(4)=K
            IF(BPLANT1)IPLANT=(((IGAM(4)*1000+IGAM(3))*1000+IGAM(2))    &
     &                        *MXORB)+IGAM(1)
            DO J=IRLPS1,IRLPS
              IF(.NOT.BPLANT1)THEN
                DO I=4,1,-1
                  IF(QRLPS(I,J).NE.IGAM(I))GO TO 1120
                ENDDO
              ELSE
                IF(IPLANT.NE.JORIG1(J))GO TO 1120
              ENDIF
              I=IORIG1(J)
              IF(I.GT.0)THEN
                DRKPS(I)=DRKPS(I)+DD
                GO TO 1140
              ENDIF
              L=J
              GO TO 1130
 1120       ENDDO
!
!     CANNOT FIND AN OLD SET OF ARGUMENTS EQUAL TO THE NEW SET, SO
!     MUST START CONSTRUCTING A NEW COEFFICIENT
!
            L=IRLPS+1
            IF(L.GT.IXS1I)THEN
!
              IXXX=7*(IXS1I/5+1)
!
              WRITE(MW6,*)'*** MKALG1: increasing MXS1I from ',IXS1I,   &
     &                    ' to: ',IXXX
              WRITE(MW0,*)'*** MKALG1: increasing MXS1I from ',IXS1I,   &
     &                    ' to: ',IXXX
!
              CALL RE_ALLOC2(QRLPS,IONE,IFOUR,IONE,IXS1I,IFOUR,IXXX,    &
     &                       IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)'MKALG1: RE-ALLOCATION FAILS FOR QRLPS'
                NF=0
                GO TO 2000
              ENDIF
!
              IXXX0=MAX(IXS1I,IXSOI)
              IXXX1=MAX(IXXX,IXSOI)
              IF(IXXX1.GT.IXXX0)CALL RE_ALLOC(IORIG1,IONE,IXXX0,IXXX1,  &
     &           IERR)
              CALL RE_ALLOC(JORIG1,IONE,IXS1I,IXXX,IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)                                            &
     &                   'MKALG1: RE-ALLOCATION FAILS FOR IORIG1,JORIG1'
                NF=0
                GO TO 2000
              ENDIF
!
              IXS1I=IXXX
!
            ENDIF
!
            IRLPS=L
            DO I=1,4
              QRLPS(I,L)=INT(IGAM(I),QP)
            ENDDO
            IF(BPLANT1)JORIG1(L)=IPLANT
!
 1130       IRKPS=IRKPS+1
            IF(IRKPS.GT.IXS1C)THEN
!
              IXXX=7*(IXS1C/5+1)
!
              WRITE(MW6,*)'*** MKALG1: increasing MXS1C from ',IXS1C,   &
     &                    ' to: ',IXXX
              WRITE(MW0,*)'*** MKALG1: increasing MXS1C from ',IXS1C,   &
     &                    ' to: ',IXXX
!
              CALL RE_ALLOC(DRKPS,IONE,IXS1C,IXXX,IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)'MKALG1: RE-ALLOCATION FAILS FOR DRKPS'
                NF=0
                GO TO 2000
              ENDIF
!
              CALL RE_ALLOC(NRKPS,IONE,IXS1C,IXXX,IERR)
              CALL RE_ALLOC(NSTJ1,IONE,IXS1C,IXXX,IERR)
              CALL RE_ALLOC(NSTJ1D,IONE,IXS1C,IXXX,IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)                                            &
     &                     'MKALG1: RE-ALLOCATION FAILS FOR NRKPS,NSTJ1'
                NF=0
                GO TO 2000
              ENDIF
!
              IXS1C=IXXX
!
            ENDIF
!
            IORIG1(L)=IRKPS
            NRKPS(IRKPS)=L
            DRKPS(IRKPS)=DD
            NSTJ1(IRKPS)=L1
            NSTJ1D(IRKPS)=L2
!
 1140     ENDDO
!
! *** END STORE OF ONE-BODY COEFFICIENTS ***
!
 1160     IF(NK.EQ.0)GO TO 60
!
!     NK.EQ.1 FOR STATES WHICH DIFFER IN ONE SET OF ONE-ELECTRON
!     QUANTUM NOS, THE NECESSARY TERM HAS ALREADY BEEN EVALUATED,
!     THEREFORE PROCEED TO NEXT PAIR OF SLATER STATES.
!
 1180     IF(MXLL.NE.-1)GO TO 1200
          IF(MX.NE.0)GO TO 1200
          IF(IRKPS.GE.IRKPS0)GO TO 1300
!
!
 1200   ENDDO                                           !END
!
      ENDDO                                             !END
!
! IF .T. RETURN AND COMPUTE FOR DIFFERENT MS,ML GIVING THE SAME MS+ML=MJ
!
 1300 IF(BLX2)RETURN
!
      IF(BLX1)RETURN
!
!     INSERT ARRAY CLEARING PARAGRAPHS HERE (BLX1 AND BLX2)
!
 1400 ICLR=0
      PHS0=(1-MOD(MJJR-MJ2,IFOUR))*SQRT(REAL(MLAM+1,WP))/DVC
!
      IF(IRKPS.LT.IRKPS0)GO TO 1700
!
!     IF THE MATRIX ELEMENT HAS BEEN CALCULATED CLEAR THE ARRAY  DRKPS
!       OF ZEROS AND ADJUST NRKPS.
!
      K=IRKPS0-1
      KP=0
!      IF(IRLPS0+1.NE.IRLPS1)STOP 'IRLPS ERROR'
      DO I=IRLPS1,IRLPS
        IORIG1(I)=0
      ENDDO
!
      DO I=IRKPS0,IRKPS
        JD0=NRKPS(I)
        JD=ABS(JD0)
        IF(ABS(DRKPS(I)).GE.TYNY)GO TO 1450
        IF(IORIG1(JD).GT.0)GO TO 1600
        JD0=0             !RE-INDEX QRLPS AS MAY OCCUR LATER
        GO TO 1500
 1450   K=K+1
        DRKPS(K)=DRKPS(I)*PHS0
        NSTJ1(K)=NSTJ1(I)
        NSTJ1D(K)=NSTJ1D(I)
!
 1500   IF(JD.LE.IRLPS0)THEN
          WRITE(MW6,*)'MKALG1: INFORM NRB OF STOP HERE - 1',JD,IRLPS0
          WRITE(MW0,*)'MKALG1: INFORM NRB OF STOP HERE - 1'
          NF=-1
          GO TO 2000
!      LP=JD
!      GO TO 92
        ENDIF
!
        IF(IORIG1(JD).EQ.0)THEN
          LP=JD-KP
          DO L=1,IRLPS0
            DO J=1,4
              IF(QRLPS(J,JD).NE.QRLPS(J,L))GO TO 1520
            ENDDO
            KP=KP+1
            IORIG1(JD)=L
            LP=L
            GO TO 1550
 1520     ENDDO
        ELSE
          LP=IORIG1(JD)
          GO TO 1550
        ENDIF
!
        IORIG1(JD)=LP
        DO J=1,4
          QRLPS(J,LP)=QRLPS(J,JD)
        ENDDO
!
 1550   IF(JD0.EQ.0)GO TO 1600
        NRKPS(K)=LP
!      IF(JD0.LT.0)NRKPS(K)=-NRKPS(K)
 1600 ENDDO
!
      IRLPS=IRLPS-KP
      IRKPS=K
!
!     SIMILARLY, CLEAR TWO-BODY ARRAYS
!
 1700 IF(IRSS.LT.IRSS0)GO TO 2000
!
      K=IRSS0-1
      KP=0
      DO I=NLS01,NLS
        IORIG2(I)=0
      ENDDO
!
      DO I=IRSS0,IRSS
        JD0=MSSS(I)
        JD=ABS(JD0)
        IF(ABS(DSSS(I)).GE.TYNY)GO TO 1750
        IF(IORIG2(JD).GT.0)GO TO 1900
        JD0=0             !RE-INDEX QSSS AS MAY OCCUR LATER
        GO TO 1800
 1750   K=K+1
        DSSS(K)=DSSS(I)*PHS0
        NSTJ2(K)=NSTJ2(I)
        NSTJ2D(K)=NSTJ2D(I)
!
 1800   IF(JD.LE.NLS00)THEN
          WRITE(MW6,*)'MKALG1: INFORM NRB OF STOP HERE - 2',JD,NLS00
          WRITE(MW0,*)'MKALG1: INFORM NRB OF STOP HERE - 2'
          NF=-1
          GO TO 2000
!      LP=JD
!      GO TO 392
        ENDIF
!
        IF(IORIG2(JD).EQ.0)THEN
          LP=JD-KP
          DO L=1,NLS00
            DO J=1,5
              IF(QSSS(J,JD).NE.QSSS(J,L))GO TO 1820
            ENDDO
            KP=KP+1
            IORIG2(JD)=L
            LP=L
            GO TO 1850
 1820     ENDDO
        ELSE
          LP=IORIG2(JD)
          GO TO 1850
        ENDIF
!
        IORIG2(JD)=LP
        DO J=1,5
          QSSS(J,LP)=QSSS(J,JD)
        ENDDO
!
 1850   IF(JD0.EQ.0)GO TO 1900
        MSSS(K)=LP
!      IF(JD0.LT.0)MSSS(K)=-MSSS(K)
 1900 ENDDO
!
      NLS=NLS-KP
      IRSS=K
!
!-----------------------------------------------------------------------
!
 2000 RETURN
!
!-----------------------------------------------------------------------
!
!     E R R O R   M E S S A G E S
!
 2100 WRITE(MW6,10030)
      WRITE(MW0,*)'***SR.MKALG1: INDEXING ERROR ***'
      NF=-1
!
      GO TO 2000
!
!-----------------------------------------------------------------------
!
10010 FORMAT(30X,1P,4E16.6,4I5)
10020 FORMAT(1X,I5,2X,2(I5,I4),I6)
10030 FORMAT('***SR.MKALG1: INDEXING ERROR ***')
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE MKALG1
!
!                             *******************
!
      SUBROUTINE MKALG2(mam,nam,KK)
!
!-----------------------------------------------------------------------
!
!  SR.MKALG2 APPLIES SLATER-STATE ALGEBRA TO INDIVIDUAL LEVELS FOR
!  RADIATIVE MK ALGEBRA, INCLUDING BP CORRECTIONS TO M1 AND E1VEL.
!
!  IT IS CALLED BY:
!    SR.ALGEB4
!
!  IT CALLS:
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_ALGEB,  ONLY: MPRINT
!!      COMMON /BASIC/NF,KF,KG,JA,JB,JAP,JBP,JGAP,ND1,NDP1,ND2,NDP2
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,JA=>IBSK4,JB=>IBSK5            &
     &              ,JAP=>IBSK6,JBP=>IBSK7,IBSK8=>IBSK8,ND1=>IBSK9      &
     &              ,NDP1=>IBSK10,ND2=>IBSK11,NDP2=>IBSK12
      USE COMMON_DC,     ONLY: BFAST,DC
      USE COMMON_COEFF,  ONLY: DRKP,QRLP,IRLP,NRKP,N81,IPLANT_SOI
      USE COMMON_COEFF,  ONLY: IRKP,IRKP0
      USE COMMON_COEFFS, ONLY: DRKPS,QRLPS,NRKPS
      USE COMMON_COEFFS, ONLY: IRKPS,IRKPS0,IRLPS,IRLPS0
      USE COMMON_DMQSS3, ONLY: DSS,MSS,QSS,N82,IPLANT_MI                &
     &                        ,IRS,IRS0,NL000=>NL,NL=>NL000
      USE COMMON_DMQSSS, ONLY: DSSS,MSSS,QSSS
      USE COMMON_DMQSSS, ONLY: IRSS,IRSS0,NLS,NLS00
      USE COMMON_NSTS1,  ONLY: NADS1,NSTJ1,NSTJ1D,IORIG1,JORIG1
      USE COMMON_NSTS2,  ONLY: NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2
!
      USE COMMON_NRBAL4, ONLY: MBP1MX,MBP2MX,MEKVMX,KUTM1,MPOLM,QCUT
      USE COMMON_NRBAL4, ONLY: DVC,MJ1,MJ2,MLAM,BE1CASE
      USE COMMON_NRBRN2, ONLY: BINDB,MENGB
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M5)
      PARAMETER (DTOL=D1M8)
!
      CHARACTER(LEN=1) MP
!
      DIMENSION mam(*),nam(*)
!
      DATA MG/-2/,IRLP0/0/
!
!-----------------------------------------------------------------------
!
!      ICOL(ILI,ILF,IONE1)=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
!-----------------------------------------------------------------------
!
      BFAST=DC(0).LT.DZERO                 !ELSE OPT MEMORY
!
      BLPT=MPRINT.GT.0
      MLAMH=MLAM/2
!      EQUCFG=KF.EQ.KG
!
! BEGIN MAIN LOOP 165 OVER 1-BODY SLATER STATE INTERACTIONS
!
      N81=(NDP1-1)
!
      IF(IRLP.LE.0)THEN                 !FLAG END OF STRUCTURE INTEGRALS
        IRLP=-IRLP
        IRLP0=IRLP
      ENDIF
      IRLP11=IRLP
      IRLP1=IRLP0+1
      K0=NADS1(KK-1)+1
!
      DO J=1,IRLPS
        JORIG1(J)=0
      ENDDO
!
      DO KS=K0,NADS1(KK)
!
        L1=NSTJ1(KS)
        L2=NSTJ1D(KS)
!
        IF(BFAST)THEN
!
          DDH=DC(L1+ND2)*DC(L2+NDP2)*DRKPS(KS)
!
!          IF(EQUCFG.AND.L1.NE.L2)DDH=DDH+DC(L1+NDP2)
!                                        *DC(L2+ND2)*DRKPS(KS)
        ELSE
!
          m1=mam(l1)
          if(m1.eq.0)go to 100
!
          m2=nam(l2)
          if(m2.eq.0)go to 100
!
          DDH=DC(m1)*DC(m2)*DRKPS(KS)
!
!          IF(EQUCFG.AND.L1.NE.L2)then       !& suppress go to 165 above
!            m2=mam(l2)
!            m1=nam(l1)
!            if(m1*m2.gt.0)then
!              DDH=DDH+DC(m2)*DC(m1)*DRKPS(KS)
!            endif
!          endif
!
        ENDIF
!
        IF(ABS(DDH).LT.DTOL)GO TO 100
!
        N=NRKPS(KS)
        L=JORIG1(N)
!
        IF(L.GT.0)THEN
          K=IORIG1(L)
          DRKP(K)=DRKP(K)+DDH
        ELSE
!
! CANNOT FIND AN OLD SET OF ARGUMENTS EQUAL TO THE NEW SET, SO
! MUST START CONSTRUCTING A NEW COEFFICIENT.
!
          L=IRLP+1
          IF(L.GT.IXSOI)THEN
!
            IXXX=7*(IXSOI/5+1)
!
            WRITE(MW6,*)'*** MKALG2: increasing MXSOI from ',IXSOI,     &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** MKALG2: increasing MXSOI from ',IXSOI,     &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC2(QRLP,IONE,IFOUR,IONE,IXSOI,IFOUR,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'MKALG2: RE-ALLOCATION FAILS FOR QRLP'
              NF=0
              GO TO 600
            ENDIF
!
            IXXX0=MAX(IXS1I,IXSOI)
            IXXX1=MAX(IXS1I,IXXX)
            IF(IXXX1.GT.IXXX0)CALL RE_ALLOC(IORIG1,IONE,IXXX0,IXXX1,    &
     &         IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'MKALG2: RE-ALLOCATION FAILS FOR IORIG1'
              NF=0
              GO TO 600
            ENDIF
!
            IXSOI=IXXX
!
            IF(IXSOI.GT.IPLANT_SOI)THEN
              WRITE(MW0,*)'MKALG2:I*4/SP TOO SHORT FOR 1-BODY M_K RAD'
              WRITE(MW6,*)                                              &
     &              'SR.MKALG2: CHANGE TO I*8/EP IN MODULE COMMON_COEFF'
              NF=0
              GO TO 600
            ENDIF
!
          ENDIF
!
          IRKP=IRKP+1
          IF(IRKP.GT.IXSOC)THEN
!
            IXXX=7*(IXSOC/5+1)
!
            WRITE(MW6,*)'*** MKALG2: increasing MXSOC from ',IXSOC,     &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** MKALG2: increasing MXSOC from ',IXSOC,     &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC(DRKP,IONE,IXSOC,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'MKALG2: RE-ALLOCATION FAILS FOR DRKP'
              NF=0
              GO TO 600
            ENDIF
!
            CALL RE_ALLOC(NRKP,IONE,IXSOC,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'MKALG2: RE-ALLOCATION FAILS FOR NRKP'
              NF=0
              GO TO 600
            ENDIF
!
            IXSOC=IXXX
!
          ENDIF
!
          IRLP=L
          DO I=1,4
            QRLP(I,L)=QRLPS(I,N)
          ENDDO
          JORIG1(N)=L
          IORIG1(L)=IRKP
          NRKP(IRKP)=L
          DRKP(IRKP)=DDH
        ENDIF
!
  100 ENDDO
!
! CLEAR THE ARRAY DRKP OF ZEROS AND ADJUST NRKP ACCORDINGLY.
!
      IF(IRKP.LT.IRKP0)GO TO 300
      K=IRKP0-1
      N1=0
!
      DO I=IRKP0,IRKP
!
        IF(ABS(DRKP(I)).LT.TYNY)GO TO 250
!
        K=K+1
        DRKP(K)=DRKP(I)
        N2=INT(NRKP(I),SP)
        LP=N2-N1
!
        DO L=IRLP1,IRLP11
          DO J=1,4
            IF(QRLP(J,N2).NE.QRLP(J,L))GO TO 150
          ENDDO
          LP=L
          GO TO 200
  150   ENDDO
!
        N1=N1-1
        DO J=1,4
          QRLP(J,LP)=QRLP(J,N2)
        ENDDO
!
  200   NRKP(K)=LP+N81*IPLANT_SOI                                 !MXSOI
!
        if(abs(mbp2mx).le.2)then
          ma=qrlp(1,lp)            !historic, but beware if use /NRBAL1/
          mc=qrlp(2,lp)
          mlamh=qrlp(3,lp)/2       !magnetic multipole
          mlamh=mlamh-1            !electric multipole integral required
          mn=min(ma,mc)
          mx=max(ma,mc)
          in=icol(mn,mx,izero)
!          write(mw6,*)'bindb:',in,ma,mc,mlamh
          if(abs(mbp2mx).lt.2)bindb(in,mlamh/2)=.true.
          if(abs(mbp2mx).eq.2)bindb(in,mlamh/2+1)=.true.
        endif
!
        IF(BLPT)THEN
          MP='M'
          IF(BE1CASE.and.QRLP(3,LP).eq.2)MP='E'
          MM=QRLP(3,LP)/2
          IF(ABS(MBP2MX).LT.2)THEN
            DD=DRKP(K)*DVC
            IF(MM.LT.10)THEN
              WRITE(MW6,10020)K,ND1,NDP1,MA,MC,LP,DRKP(K),DD,DVC,MJ1,   &
     &                        MJ2,MP,MM,QRLP(4,LP)
            ELSE
              WRITE(MW6,10030)K,ND1,NDP1,MA,MC,LP,DRKP(K),DD,DVC,MJ1,   &
     &                        MJ2,MP,MM,QRLP(4,LP)
            ENDIF
          ELSE
            IF(MM.LT.10)THEN
              WRITE(MW6,10040)K,ND1,NDP1,(QRLP(J,LP),J=1,2),LP,DRKP(K), &
     &                        MP,MM,QRLP(4,LP)
            ELSE
              WRITE(MW6,10050)K,ND1,NDP1,(QRLP(J,LP),J=1,2),LP,DRKP(K), &
     &                        MP,MM,QRLP(4,LP)
            ENDIF
          ENDIF
        ENDIF
!
  250   N1=N1+1
!
      ENDDO
!
      IRLP=IRLP-N1
      IRKP=K
!
!
! BEGIN MAIN LOOP 265 OVER 2-BODY SLATER STATE INTERACTIONS.
!
  300 CONTINUE
!
      N82=(NDP1-1)
!
      NL00=NL
      NL1=NL000+1
      K0=NADS2(KK-1)+1
!
      DO J=1,NLS
        JORIG2(J)=0
      ENDDO
!
      DO KS=K0,NADS2(KK)
!
        L1=NSTJ2(KS)
        L2=NSTJ2D(KS)
!
        IF(BFAST)THEN
!
          DDH=DC(L1+ND2)*DC(L2+NDP2)*DSSS(KS)
!
!          IF(EQUCFG.AND.L1.NE.L2)DDH=DDH+DC(L1+NDP2)
!                                        *DC(L2+ND2)*DSSS(KS)
        ELSE
!
          m1=mam(l1)
          if(m1.eq.0)go to 400
!
          m2=nam(l2)
          if(m2.eq.0)go to 400
!
          DDH=DC(m1)*DC(m2)*DSSS(KS)
!
!          IF(EQUCFG.AND.L1.NE.L2)then       !& suppress go to 265 above
!            m2=mam(l2)
!            m1=nam(l1)
!            if(m1*m2.gt.0)then
!              DDH=DDH+DC(m2)*DC(m1)*DSSS(KS)
!            endif
!          endif
!
        ENDIF
!
        IF(ABS(DDH).LT.DTOL)GO TO 400
!
        M=MSSS(KS)
        L=JORIG2(M)
        IF(L.GT.0)THEN
          K=IORIG2(L)
          DSS(K)=DSS(K)+DDH
        ELSE
!
! CANNOT FIND AN OLD SET OF ARGUMENTS EQUAL TO THE NEW SET, SO
! MUST START CONSTRUCTING A NEW COEFFICIENT.
!
          L=NL+1
          IF(L.GT.IAXMI)THEN
!
            IXXX=7*(IAXMI/5+1)
!
            WRITE(MW6,*)'*** MKALG2: increasing MAXMI from ',IAXMI,     &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** MKALG2: increasing MAXMI from ',IAXMI,     &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC2(QSS,IONE,IFIVE,IONE,IAXMI,IFIVE,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'MKALG2: RE-ALLOCATION FAILS FOR QSS'
              NF=0
              GO TO 600
            ENDIF
!
            IXXX0=MAX(IXS2I,IAXMI)
            IXXX2=MAX(IXS2I,IXXX)
            IF(IXXX2.GT.IXXX0)CALL RE_ALLOC(IORIG2,IONE,IXXX0,IXXX2,    &
     &         IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'MKALG2: RE-ALLOCATION FAILS FOR IORIG2'
              NF=0
              GO TO 600
            ENDIF
!
            IAXMI=IXXX
!
            IF(IAXMI.GT.IPLANT_MI)THEN
              WRITE(MW0,*)'MKALG2:I*4/SP TOO SHORT FOR 2-BODY M_K RAD'
              WRITE(MW6,*)                                              &
     &             'SR.MKALG2: CHANGE TO I*8/EP IN MODULE COMMON_DMQSS3'
              NF=0
              GO TO 600
            ENDIF
!
          ENDIF
!
          IRS=IRS+1
          IF(IRS.GT.IXRSS)THEN
!
            IXXX=7*(IXRSS/5+1)
!
            WRITE(MW6,*)'*** MKALG2: increasing MXRSS from ',IXRSS,     &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** MKALG2: increasing MXRSS from ',IXRSS,     &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC(DSS,IONE,IXRSS,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'MKALG2: RE-ALLOCATION FAILS FOR DSS'
              NF=0
              GO TO 600
            ENDIF
!
            CALL RE_ALLOC(MSS,IONE,IXRSS,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'MKALG2: RE-ALLOCATION FAILS FOR MSS'
              NF=0
              GO TO 600
            ENDIF
!
            IXRSS=IXXX
!
          ENDIF
!
          NL=L
          DO K=1,5
            QSS(K,L)=QSSS(K,M)
          ENDDO
          JORIG2(M)=L
          IORIG2(L)=IRS
          MSS(IRS)=L
          DSS(IRS)=DDH
!
        ENDIF
!
  400 ENDDO
!
! CLEAR THE ARRAY DSS OF ZEROS AND ADJUST MSS(K) ACCORDINGLY.
!
      IF(IRS.LT.IRS0)GO TO 600
      K=IRS0-1
      KP=0
!
      DO I=IRS0,IRS
!
        IF(ABS(DSS(I)).LT.TYNY)GO TO 550
!
        K=K+1
        DSS(K)=DSS(I)
        JD=INT(MSS(I),SP)
        LP=JD-KP
!
        DO L=NL1,NL00
          DO J=1,5
            IF(QSS(J,JD).NE.QSS(J,L))GO TO 450
          ENDDO
          LP=L
          GO TO 500
  450   ENDDO
!
        KP=KP-1
        DO J=1,5
          QSS(J,LP)=QSS(J,JD)
        ENDDO
  500   MSS(K)=LP+N82*IPLANT_MI                                   !MAXMI
!
  550   KP=KP+1
!
      ENDDO
!
      NL=NL-KP
      IRS=K
!
      IF(BLPT)THEN
        IF(IRS.GE.IRS0)THEN
          WRITE(MW6,10010)ND1,NDP1,IRS,NL,                              &
     &                    (MSS(I)-N82*IPLANT_MI,DSS(I),I=IRS0,IRS)
        ENDIF
      ELSE
        IF(MPRINT.EQ.-3)WRITE(MW6,10060)IRKP,ND1,NDP1,MG,MG,IRLP,ND1,   &
     &                                  NDP1,IRS,NL
      ENDIF
!
!-----------------------------------------------------------------------
!
  600 RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(57X,2I6,I9,I6,3(I7,F9.4)/(84X,3(I7,F9.4)))
10020 FORMAT(I9,3I6,I4,I6,F13.5,2F19.5,6X,2I4,3X,A1,I1,I4)
10030 FORMAT(I9,3I6,I4,I6,F13.5,2F19.5,6X,2I4,3X,A1,I2,I3)
10040 FORMAT(I9,3I6,I4,I6,F13.5,3X,A1,I1,I4)
10050 FORMAT(I9,3I6,I4,I6,F13.5,3X,A1,I2,I3)
10060 FORMAT(I9,3I6,I4,I6,31X,2I6,I9,I6)
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!-----------------------------------------------------------------------
!
      END SUBROUTINE MKALG2
!
!***********************************************************************
!
      SUBROUTINE MULTS(Y,X,A,N)
!
!-----------------------------------------------------------------------
!
!     SYMMETRIC MATRIX MULTIPLICATION: Y=AX
!
! NRB: ADAPTED FROM SYMMETRIC MATRIX TIMES VECTOR: MULTSV
!
!     INPUT:
!
!          A,X   --ARRAYS PACKED WITH ELEMENTS CONTAINED
!                  IN EACH ROW, ON DIAGONAL AND TO RIGHT,
!                  OF COEFFICIENT MATRIX
!
!          N     --MATRIX DIMENSION
!
!     OUTPUT:
!
!          Y     --PRODUCT BETWEEN A AND X    (PACKED)
!
!  IT IS CALLED BY:
!    SR.PQ
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION A(*),X(*),Y(*)
!
!-----------------------------------------------------------------------
!
      NN=N*(N+1)/2
      DO I=1,NN
        Y(I)=DZERO
      ENDDO
!
      LM=0
      DO M=1,N
!
        K=1
        L=0
        KM=1
        IF(N.EQ.1)GO TO 50
        DO J=2,M
          T=X(M+L)
          IM=LM
          DO I=M,N
            IM=IM+1
            Y(IM)=Y(IM)+T*A(I+L)
          ENDDO
          L=L+N-K
          K=J
        ENDDO
        LM=LM+N-M+1
        KM=K+L
        DO J=M+1,N
          T=X(KM)
          S=A(K+L)*T
          IM=KM
          DO I=J,N
            IM=IM+1
            R=A(I+L)
            S=S+R*X(IM)
            Y(IM)=Y(IM)+R*T
          ENDDO
          Y(KM)=Y(KM)+S
          L=L+N-K
          K=J
          KM=KM+1
        ENDDO
   50   Y(KM)=Y(KM)+A(K+L)*X(KM)
!
      ENDDO
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE MULTS
!
!                             *******************
!
      SUBROUTINE MVDINT(K,DE,MRED,MAXPS)
!
!-----------------------------------------------------------------------
!
!  SR.MVDINT DETERMINES THE MASS-VELOCITY AND DARWIN INTEGRALS,
!  ALSO THE M1BP INTEGRALS D2LL, FOR ALL BOUND ORBITALS L.LE.K WHERE K
!  IS THE PRESENT ONE BEING DETERMINED.
!
!  IT IS CALLED BY:
!    SR.RADIAL
!
!  IT CALLS:
!    SR.WEDDLE
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DMQSS3, ONLY: NL000=>NL,NL=>NL000
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
      USE COMMON_REL,    ONLY: DMASS,DCD,D2LL
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,VSC,XC1,XC2,NPITER
      USE COMMON_NRBPOT, ONLY: DPOT,TOL,MEND
      USE COMMON_NRBPOT, ONLY: POTHAM,MPSEUD
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD,BMVD0
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      ALLOCATABLE :: DA(:),DP(:)
!
!-----------------------------------------------------------------------
!
! THE NAMES HERE ARE NOT NECESSARILY SIGNIFICANT THEY ARE COMMON LEGACY.
!
! LOCAL
      ALLOCATE(DA(MAXPS),DP(MAXPS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'MVDINT: ALLOCATION FAILS FOR DA,DP'
        NF=0
        RETURN
      ENDIF
!
! test Darwin with small-r factor
!      if(.not.brel)allocate(derv1(maxps),derv2(maxps))
!
!-----------------------------------------------------------------------
!
      BMVDR=ALLOCATED(DCD)
      B2LL=ALLOCATED(D2LL)
!
!-----------------------------------------------------------------------
!
      DZ=NZION
      BORT=MORT.LT.0
      BREL2=ABS(IREL).EQ.2
!
      bm1bp=NL.GE.NL000         !.eq. allows for .true. but no coeffs...
      tz=dzero
      dee=dzero
      if(.not.bm1bp)then
        igagr=-1
      else
        dza=nzion-mion+1+mred
        if(igagr.gt.0)tz=dza
      endif
      tt=dz-tz
!      ink=icol(k,k,izero)
!
! LOOP OVER ALL OTHER COMPUTED ORBITALS L.LE.K, FOR CURRENT ORBITAL K.
!
      DO L=1,K
!
        DD3=DZERO
                 !INITIALIZE ALL FOR SAFETY AS NANs CAN BE ALLOCATED
        DD2=DZERO
        DD1=DZERO
!
        IF(DEY(L).EQ.DZERO)GO TO 100                             !613
        IF(QL(L).NE.QL(K))GO TO 100             !check rad/diagfs 613
!      if(ql(k).ne.ql(l).and.(.not.bm1bp.or.igagr.lt.0))go to 614!613
        IF((BREL.OR..not.BMVD0).AND..not.bm1bp)GO TO 100  !only radbp
!                            .AND.L.EQ.K .OR.BREL2
        IF(K.LE.ABS(MPSEUD))GO TO 100
!
        INL=ICOL(L,L,IZERO)
!
        IF(BORT.AND..NOT.BREL)THEN
!        IF(MORT.EQ.-3.AND.BREL)GO TO 614
!
!        dee=dzero
!        if(igagr.gt.0.and.ql(l).ne.ql(k))dee=dey(l)-duy(inl)
!        write(mw0,*)'dqnl',dza,tz
!
          DO I=1,MAXPS
            DS=DZ/DX(I)
            DD3=DPNL(I,L)*(tt/dx(i)-dee)+DQNL(I,L)/DTWO
            DD4=DPNL(I,K)
            DA(I)=DD4*DD3
            DD3=DPNL(I,L)*DS+DQNL(I,L)/DTWO
            DD4=DD4*DS+DQNL(I,K)/DTWO
            DP(I)=DD4*DD3
          ENDDO
          GO TO 50
        ENDIF
!
        IF(BREL)THEN
!       write(mw0,*)'rel',dza,tz
          DO I=1,MAXPS
            DA(I)=DPNL(I,L)*(DPOT(I)-tz/dx(i)+VSC(I))*DPNL(I,K)
          ENDDO
          IF(BREL2)THEN
            DO I=1,MAXPS
              DA(I)=DA(I)+DQNL(I,K)*(DPOT(I)-tz/dx(i)+VSC(I))*DQNL(I,L)
            ENDDO
          ENDIF
        ELSE
!       write(mw0,*)'non-rel',dza,tz
          DO I=1,MAXPS
            DA(I)=DPNL(I,L)*(DPOT(I)-tz/dx(i)+VSC(I))*DPNL(I,K)
          ENDDO
          DS=DEY(L)-DUY(INL)
          DO I=1,MAXPS
            T=DPOT(I)+VSC(I)
            DP(I)=DPNL(I,L)*(DE+T)*(DS+T)*DPNL(I,K)
          ENDDO
        ENDIF
!
   50   CALL WEDDLE(DZERO,DA,DD3,MNH,DHNS,MJH,MAXPS)
!
        IF(L.EQ.K)DD3=DE+DD3
!
        IF(BREL.OR..NOT.BMVD0)GO TO 100                             !100
!            .AND..NOT.BORT
!
        IF(QL(K).EQ.0.AND..NOT.BREL)DD2=DORIG(K)*DORIG(L)*DZ*DZ  !ORIGIN
!
!          if(.not.brel)then            !test Darwin with small-r factor
!            call diff(dpnl(1,k),derv1,mnh,dhns,mjh)
!            call diff(dpot,derv2,mnh,dhns,mjh)
!            ds=dey(l)-duy(inl)
!            de=dey(k)-duy(ink)
!!            write(mw0,*)l,k,ds,de,dpot(maxps)*dx(maxps)
!            do i=1,maxps
!              da(i)=dpnl(i,l)*derv2(i)*(dpnl(i,k)/dx(i)-derv1(i))
!              t1=done+dalf*(de+dpot(i))/dtwo
!              t3=done+dalf*(ds+dpot(i))/dtwo
!              da(i)=da(i)/sqrt(t1*t3)
!            enddo
!            call weddle(dd2,da,ddd,mnh,dhns,mjh,maxps)
!          endif
!
        CALL WEDDLE(DD2,DP,DD1,MNH,DHNS,MJH,MAXPS)
!
        DD2=DD2*DALF/(DZ*DEIGHT)
!        dd2=-ddd*dalf/dfour            !test Darwin with small-r factor
        DD1=-DD1*DALF/DTWO                                          !100
!
  100   IN=ICOL(L,K,IZERO)
!
        IF(BMVDR)DMASS(IN)=DD1            !N.B. SWAPPED DMASS, DCD ORDER
        IF(BMVDR)DCD(IN)=DD2
        IF(B2LL)D2LL(IN)=2*DD3                  !M1BP RADIATIVE INTEGRAL
!
      ENDDO                           !END RELATIVISTIC CORRECTIONS !613
!
!-----------------------------------------------------------------------
!
! LOCAL
      DEALLOCATE(DA,DP,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'MVDINT: DE-ALLOCATION FAILS FOR DA,DP'
        NF=0
      ENDIF
!
! test Darwin with small-r factor
!      if(.not.brel)deallocate(derv1,derv2)
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE MVDINT
!
!                             *******************
!
      FUNCTION NCHAJK(KX,KIN,JGIN,LIN,NCJ,NTGJ)
!
!-----------------------------------------------------------------------
!
!  FN.NCHAJK:
!     SETS-UP THE JK-COUPLING CHANNEL LIST FOR JP SYMMETRY INDEX KX
!     AND RETURNS THE NUMBER OF CHANNELS.
!     (THIS IS MAINLY FOR INFO SINCE SR.DWXBP REPLICATES IT.)
!
!  IT IS CALLED BY:
!    SR.DWXBP_DAXPY
!    SR.DWXBP_DDOT
!
!  IT CALLS:
!    FN.SJS
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      USE COMMON_NRBDW9, ONLY: DSPECJ,INDXJ,JNDXJ,NSPECJ,NENERJ
      USE COMMON_NRBGRJ, ONLY: NSLJ,NGSLJ
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,INASTJ=>NASTJ                   &
     &                        ,MINJT,MAXJT,NEIGENJ
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBDWJ, ONLY: JSYMM,NCHGJ,NADGJ,NCHSJ
      USE COMMON_NRBDWX, ONLY: LLCH,ITARG,NCHG
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      INTEGER(SP) SA
!
      DIMENSION NTGJ(*)
!
      DATA MTJOLD/-1/,MTPOLD/-1/
!
!-----------------------------------------------------------------------
!
      BPRNT0=JPRINT.NE.-3
!
      MTJ=JPI(KX)/10
      MTP=JPI(KX)-MTJ*10
      MTP=MTP+MTP
!
      BFIRST=MTJOLD.NE.MTJ.OR.MTPOLD.NE.MTP
!
      IF(BFIRST.AND.BPRNT0)WRITE(MW6,10010)
!
      MTJOLD=MTJ
      MTPOLD=MTP
!
      INASTX=NCHGJ(KX)
!
      NCHJ=0
      nchsj=0
!
      KAY2=MTJ+1
      IF(MTJ.GT.0)THEN
        KAY1=MTJ-1
      ELSE
        KAY1=KAY2
      ENDIF
!
      DO KAY=KAY1,KAY2,2                            !LOOP OVER CHANNEL K
!
        BLASTK=KAY.EQ.KIN
!
        DO JIG=1,NJO                         !LOOP OVER TARGET JP GROUPS
!
          BLASTJ=BLASTK.AND.JIG.EQ.JGIN
!
          NC=NSLJ(1,JIG)
          JIP=QPI(NC)
          LV0=NTGJ(JIG)+1
          JI=JN(LV0)
          L1=ABS(KAY-JI)
          IF(MOD(JIP+L1,IFOUR).NE.MTP)L1=L1+2
          L2=KAY+JI
          IF(MOD(JIP+L2,IFOUR).NE.MTP)L2=L2-2
!
          NCN0=NGSLJ(JIG)
!
          DO LI=L1,L2,4                             !LOOP OVER CHANNEL L
!
            BLASTL=BLASTJ.AND.LI.EQ.LIN
!
            LV0=NTGJ(JIG)
            NCHI=0
!
            DO NC00=1,NCN0             !BEGIN LOOP OVER TARGET SL GROUPS
!
              NC=NSLJ(NC00,JIG)
              MC=NSL(NC)
              SA=QSI(NC)
              LA=QLI(NC)
              MCI=NGRPI(NC)
              BLS=.FALSE.
!
              DO IXX=1,INASTX                        !LOOP OVER LS SYMMS
!
                IX=JSYMM(IXX,KX)
                NCN=NCHG(IX)
!
                DO NC0=1,NCN                       !FIND TARGET SL GROUP
                  IF(NC.EQ.ITARG(NC0,IX))THEN        !MATCHED
                    LL1=LLCH(1,NC0,IX)
                    LL2=LLCH(2,NC0,IX)
                    IF(LI.LT.LL1.OR.LI.GT.LL2)GO TO 2
                    GO TO 4
                  ENDIF
                ENDDO
!
    2           CONTINUE
!                write(mw6,*)'NO CONTRIB. FROM LS SYM',IXX,' IX=',IX
                GO TO 5                         !SLP DOES NOT CONTRIBUTE
!
    4           IS=LSPI(IX)/10000
                IP=LSPI(IX)-IS*10000
                IL=IP/10
                IP=IP-IL*10
!
                IF(MTP.NE.IP+IP)STOP 'IXX ERROR'      !REMOVE
                MTS=IS-1
                MTL=IL+IL
!
                IF(KAY.LT.ABS(MTL-SA).OR.KAY.GT.MTL+SA)GO TO 5    !LAST
!
!               CHECK RECOUPLING COEFFICIENT (TRIANGLE SHOULD'VE CAUGHT)
!
                IF(BFIRST)THEN
!
                  S61=SJS(MTS,MTL,MTJ,KAY,IONE,SA)
!
!                  if(abs(s61).lt.1d-70)
!     &                            write(mw0,*)'1:',mts,mtl,mtj,kay,1,sa
!
                  S62=SJS(LA,LI,MTL,KAY,SA,JI)
!
!                  if(abs(s62).lt.1d-70)
!     &                           write(mw0,*)'2:',la,li,mtl,kay,sa,ji
!
                  S6=S61*S62
!
                  BLS=BLS.OR.ABS(S6).GT.1.D-70
                ELSE
                  BLS=.TRUE.
                  GO TO 10
                ENDIF
!
    5         ENDDO                              !END LOOP OVER LS SYMMS
!
   10         IF(BLS)THEN                    !THIS TARGET SL CONTRIBUTES
                LV=LV0
!                write(mw6,*)jig,ji,nc,jip
                DO MD1=1,MC                     !LOOP OVER TARGET LEVELS
                  IT=MD1+MCI
                  LV=LV+1
                  if(it.ne.nrr(lv))stop 'nchajk???'    !test
                  NCHJ=NCHJ+1
                  if(jndxj(lv).gt.0)nchsj=nchsj+1
                  IF(BFIRST.AND.BPRNT0)WRITE(MW6,10020)NCHJ,LV,IT,LI/2, &
     &               KAY
                  IF(BLASTL.AND.MD1+NCHI.EQ.NCJ)GO TO 100
                ENDDO                       !END LOOP OVER TARGET LEVELS
              ENDIF
!
              LV0=LV0+MC
              NCHI=NCHI+MC
!
            ENDDO                        !END LOOP OVER TARGET SL GROUPS
!
          ENDDO                                 !END LOOP OVER CHANNEL L
!
        ENDDO                            !END LOOP OVER TARGET JP GROUPS
!
      ENDDO                                     !END LOOP OVER CHANNEL K
!
  100 NCHAJK=NCHJ
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(/9X,'CH',8X,'LV',9X,'T',5X,'SMALL L',6X,'2K')
10020 FORMAT(I11,I10,I10,I12,I8)
!
!-----------------------------------------------------------------------
!
      END FUNCTION NCHAJK
!
!                             *******************
!
      SUBROUTINE NLAM(M0,K1,K2,K3,K4,K,TNLAM)
!
!-----------------------------------------------------------------------
!
!  SR.NLAM EVALUATES THE N-INTEGRALS OF THE SPIN-ORBIT AND SPIN-SPIN
!  INTERACTIONS.
!
!  IT IS CALLED BY:
!    SR.SOCC
!
!  IT CALLS:
!    SR.WEDDLE
!    SR.YLAMKR
!    SR.YLAMK
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
!
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBREL, ONLY: RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0
      USE COMMON_NRBREL, ONLY: DNUK0,DNUK1,DNUK2,DNUK
      use common_nrbtmp, only: rnorm
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      ALLOCATABLE :: DPA(:),DP(:)
!
!-----------------------------------------------------------------------
!
! THE NAMES HERE ARE NOT NECESSARILY SIGNIFICANT THEY ARE COMMON LEGACY.
!
! LOCAL
      ALLOCATE(DPA(MAXRS),DP(MAXRS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.NLAM: ALLOCATION FAILS FOR DPA,DP'
        TNLAM=DZERO
        NF=0                                                !NOT TRACKED
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
      BREL2=ABS(IREL).EQ.2
!
      DZ=NZION
      DD=DONE
      INUKP=INUK+1
!
      DO I=1,MAXRS
        DPA(I)=DPNL(I,K2)*DPNL(I,K4)
      ENDDO
!
      I=(QL(K2)+QL(K4))/2+2
!
      IF(BREL)THEN                       !SMALL R CORRECTION
        IK2=ICOL(K2,K2,IZERO)
        IK4=ICOL(K4,K4,IZERO)
        DE2=DEY(K2)-DUY(IK2)
        DE4=DEY(K4)-DUY(IK4)
        DEL=DE2-DE4                                   ! A.U.
        T=DALF4*DTWO
        IF(BREL2)THEN
          DO I=INUKP,MAXRS
            DD2=DONE+T*(DE2+DZ/DX(I))
            DD4=DONE+T*(DE4+DZ/DX(I))
!            DD2=DONE+T*(DE2+POT(I,1))
!            DD4=DONE+T*(DE4+POT(I,1))
            D24=DD2*DD4
            d24=abs(d24)
            DPA(I)=DPA(I)/SQRT(D24)
          ENDDO
        ELSE
          DO I=INUKP,MAXRS
            DD2=DONE+DALF4*(DQNL(I,K2)/DPNL(I,K2)+DTWO*DZ/DX(I))
            DD4=DONE+DALF4*(DQNL(I,K4)/DPNL(I,K4)+DTWO*DZ/DX(I))
!            dd2=done+t*(de2+dz/dx(i))
!            dd4=done+t*(de4+dz/dx(i))
            D24=DD2*DD4
            d24=abs(d24)
            DPA(I)=DPA(I)/SQRT(D24)
          ENDDO
          dd=dd*rnorm(k2)*rnorm(k4)
        ENDIF
        DO I=1,INUK
          DD2=DONE+T*(DE2+DNUK0(I))
          DD4=DONE+T*(DE4+DNUK0(I))
          DPA(I)=DPA(I)/SQRT(DD2*DD4)
        ENDDO
        CALL YLAMKR(K,I,DEL,DPA,DP,DD2,DD4,MNH,DHNS,MJH,M0)
      ELSE
        CALL YLAMK(K,I,DPA,DP,DD2,DD4,MNH,DHNS,MJH,M0)
      ENDIF
!
      DO I=1,MAXRS
        DP(I)=DP(I)*DPNL(I,K1)*DPNL(I,K3)
      ENDDO
!
      IF(BREL)THEN                       !SMALL R CORRECTION
        IK1=ICOL(K1,K1,IZERO)
        IK3=ICOL(K3,K3,IZERO)
        DE1=DEY(K1)-DUY(IK1)
        DE3=DEY(K3)-DUY(IK3)
        DEL=DE1-DE3                                   ! A.U.
        T=DALF4*DTWO
        IF(BREL2)THEN
          DO I=INUKP,MAXRS
            DD1=DONE+T*(DE1+DZ/DX(I))
            DD3=DONE+T*(DE3+DZ/DX(I))
!            DD1=DONE+T*(DE1+POT(I,1))
!            DD3=DONE+T*(DE3+POT(I,1))
            D13=DD1*DD3
            d13=abs(d13)
            DP(I)=DP(I)/SQRT(D13)
          ENDDO
        ELSE
          DO I=INUKP,MAXRS
            DD1=DONE+DALF4*(DQNL(I,K1)/DPNL(I,K1)+DTWO*DZ/DX(I))
            DD3=DONE+DALF4*(DQNL(I,K3)/DPNL(I,K3)+DTWO*DZ/DX(I))
!            dd1=done+t*(de1+dz/dx(i))
!            dd3=done+t*(de3+dz/dx(i))
            D13=DD1*DD3
            d13=abs(d13)
            DP(I)=DP(I)/SQRT(D13)
          ENDDO
          dd=dd*rnorm(k1)*rnorm(k3)
        ENDIF
        DO I=1,INUK
          DD1=DONE+T*(DE1+DNUK0(I))
          DD3=DONE+T*(DE3+DNUK0(I))
          DP(I)=DP(I)/SQRT(DD1*DD3)
        ENDDO
      ENDIF
!
      CALL WEDDLE(DZERO,DP,DKU,MNH,DHNS,MJH,MAXRS)
!
      TNLAM=DKU*DD*DALF4
!
!-----------------------------------------------------------------------
!
! LOCAL
      DEALLOCATE(DPA,DP,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.NLAM: DE-ALLOCATION FAILS FOR DPA,DP'
        NF=0
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE NLAM
!
!                             *******************
!
      SUBROUTINE NORMS(IR,H,L,F1,F2,F12,Y11,Y22,Y12,TM12,VMAX)
!
!-----------------------------------------------------------------------
!
!  FOR A GIVEN INPUT RADIAL MESH, DEFINED BY
!  R=I*H WHERE I=0,1,...,IR AND RADIAL FUNCTIONS F1(0:IR) AND F2(0:IR)
!  SR.NORMS EVALUATES THE INTERGALS, USING SIMPSON'S RULE:
!  Y11=<F1*F1>, Y22=<F2*F2>, Y12=<F1*F2> AND TM12=<F1*F2*R**L>
!  AS WELL AS
!  VMAX=J_L,1/2*RM WHERE J_L,1 IS THE POSITION OF THE FIRST +ZERO OF THE
!  SPHERICAL BESSEL FUNCTION OF ORDER L AND RM IS THE POSITION OF THE
!  ABS MAX OF F1*F2*R.
!  IF ALSO OUTPUTS F12(I)=F1(I)*F2(I) FOR I=0,1,...,IR. F12 IS UNDEFINED
!  ON INPUT.
!
!  A. BURGESS, DAMTP, CAMBRIDGE - SEE ALSO J.PHYS.B30, 33 (1997).
!
!  IT IS CALLED BY:
!    SR.BORN
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
! FIRST TWO EXPANSION COEFFICIENTS FOR THE 1ST POSITIVE ZERO OF A
! SPHERICAL BESSEL OF ORDER L - SEE ABRAMOWITZ & STEGUN 9.5.14
!
      PARAMETER (C1=1.85575_WP)
      PARAMETER (C2=1.03315_WP)
!
      DIMENSION F1(0:*),F2(0:*),F12(0:*)
!
!-----------------------------------------------------------------------
!
      R=DZERO
      X=DZERO
      S1=DZERO
      S2=DZERO
      S=DZERO
      TM12=DZERO
!
      DO 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,ITWO)+1
        S1=T*P1*P1+S1
        S2=T*P2*P2+S2
        T=T*F
        S=T+S
        TM12=TM12+T*R**L
      ENDDO
!
      T=DTWO*H/DTHREE
      Y11=T*S1
      Y22=T*S2
      Y12=T*S
      TM12=T*TM12
      X=L+DHALF
      T=X**(DONE/DTHREE)
      VMAX=(C1*T+C2/T+X)  !POSITION OF 1st +ZERO OF SPHER BESSEL ORDER L
      VMAX=VMAX*DHALF/RM
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE NORMS
!
!                             *******************
!
      SUBROUTINE NUMERO(XA,XB,Y,IND,N,E,ZN,TLL,XY)
!
!-----------------------------------------------------------------------
!
!  SR.NUMERO INTEGRATES SCHRODINGER EQUATION (WITH POTENTIAL DPOT)
!  USING REDUCED NUMEROV (G=0, D.R. HARTREE: NUMERICAL ANALYSIS P.142)
!  A SECOND ORDER DIFFERENTIAL EQUATION Y2=F(X)*Y+G(X) FROM
!  XA TO XB IN NSTEPS.  THE VALUES F,Y,G FOR THE FIRST 2 POINTS
!  ARE TO BE GIVEN IN F(2),F(3),Y(2),Y(3),G(2),G(3). THE VALUES AT
!  THE N POINTS XA+I*DX I=1,N ARE WRITTEN INTO XY(I),I=1,N.
!  E =EBOUND/RY FOR BOUND, =(K*A0)**2 FOR FREE WAVES; LL=L*(L+1).
!
!  IT IS CALLED BY:
!    SR.RADWAV
!
!  IT CALLS:
!    FN.PMVDAR
!
!-----------------------------------------------------------------------
!
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,VSC,XC1,XC2,NPITER
      USE COMMON_NRBPOT, ONLY: DPOT,TOL,MEND
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION Y(3),F(3),IND(3),XY(N)
!
!-----------------------------------------------------------------------
!
      DX=(XB-XA)/N
      X=XA
      DO I=2,3
        IF(IND(1).EQ.0)THEN                  !NOT USED BY AS
          A=DZERO          !DTWO*ZN/X   JUST SUPPRESS NOT INIT. WARNINGS
          stop 'sr.numero: case ind(1)=0 commented-out'
        ELSE
          INDEX2=IND(I)
          A=DTWO*(DPOT(INDEX2)+VSC(INDEX2))
          IF(BREL)A=A+PMVDAR(INDEX2,X,E,ZN,TLL)
        ENDIF
        F(I)=TLL/X**2-A-E
        X=X+DX
      ENDDO
!
      D12=DX*DX/DTWELV
      D56=DTEN*D12
      XY(1)=Y(3)
!
      DO I=2,N
        F(1)=F(2)
        F(2)=F(3)
        Y(1)=Y(2)
        Y(2)=Y(3)
!
!        IF(IND(1).EQ.0)THEN                 !NOT USED BY AS
!          A=DTWO*ZN/X
!        ELSE
!
        INDEX2=IND(1)+INDEX2
        A=DTWO*(DPOT(INDEX2)+VSC(INDEX2))
        IF(BREL)A=A+PMVDAR(INDEX2,X,E,ZN,TLL)
!
!!          IND(2)=IND(3)                    !NOT NEEDED/USED BY AS
!!          IND(3)=INDEX2
!        ENDIF
!
        F(3)=TLL/X**2-A-E
        A=DONE-D12*F(3)
        D=(DTWO+D56*F(2))*Y(2)
        C=(DONE-D12*F(1))*Y(1)
        Y(3)=(D-C)/A
        XY(I)=Y(3)
        X=X+DX
      ENDDO
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE NUMERO
!
!                             *******************
!
      SUBROUTINE NUMSYM(JTOT,JPAR,JCUNT0)
!
!-----------------------------------------------------------------------
!
!  SR.NUMSYM
!     DETERMINES THE LSP SYMMETRIES WHICH CONTRIBUTE TO THE INPUT J,P.
!  IF JCOUNT
!    =0 IT RETURNS THE NUMBER OF LSP
!    >0 IT SEARCHES THE INAST LSPI SYMMETRIES IN /NRBLS/ AND FLAGS
!       ANY THAT ARE NOT PRESENT IN THE INAST.
!    <0 IT EXTENDS THE INAST LSPI SYMMETRY LIST FOR ANY NOT PRESENT.
!
!  IT IS CALLED BY:
!    SR.ALGX0
!    SR.PSYMJ
!    SR.SYMLSJ
!
!par!  and in parallel:                                             !par
!par!    sr.psymj                                                   !par
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,INAST0=>NASTB                            &
     &                        ,INASTJ0=>NASTJB,LFACT,JFACT              &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!
      SAVE QSMIN,QSMAX
      DATA IFIRST/0/
!
!-----------------------------------------------------------------------
!
! MAX TARGET LS IS IN QCL0,QCS0
!
      IF(IFIRST.EQ.0)THEN                       !DETERMINE MIN,MAX TOT S
        QSMIN=999
        DO I=1,NSL0
          IF(QSI(I).LT.QSMIN)QSMIN=QSI(I)
        ENDDO
        QSMIN=ABS(QSMIN-QONE)
        QSMAX=QCS0+QONE
        IFIRST=1
      ENDIF
!
      JCOUNT=JCUNT0
      BTEST1=JCUNT0.NE.0
      IF(BTEST1)JCOUNT=0
      BTEST2=JCUNT0.LT.0
!
      DO MTS=QSMIN,QSMAX,2
        QLMIN=INT(ABS(JTOT-MTS),QP)
        QLMAX=INT(JTOT+MTS,QP)
        DO MTL=QLMIN,QLMAX,2                     !RANGE OF LTOT FOR JTOT
          IL=MTL/2
          DO N=1,NSL0
            IF(ABS(QSI(N)-MTS).gt.1)GO TO 20
            if(il.gt.maxlx.and.qsi(n).gt.mts)go to 20                !nx
            LMIN=ABS(QLI(N)-MTL)
            LMAX=QLI(N)+MTL
            DO L=LMIN,LMAX,2
              LP=(L+QPI(N))/2
              IF(MOD(LP,ITWO).EQ.JPAR)THEN             !WE HAVE A WINNER
                JCOUNT=JCOUNT+1
                IF(BTEST1)THEN                           !SEE IF PRESENT
                  LSPIT=10000*(MTS+1)+IL*10+JPAR
                  KX=MIN(INAST,IAXSL)
                  DO K=1,KX
                    IF(LSPIT.EQ.LSPI(K))GO TO 50
                  ENDDO
                  IF(BTEST2)THEN
                    INAST=INAST+1
                    IF(INAST.LE.IAXSL)LSPI(INAST)=LSPIT
                  ELSE
                    WRITE(MW6,*)'*** MISSING SYM   (2S+1)  L  P=',MTS+1,&
     &                          IL,JPAR,'  FOR 2J P =',JTOT,JPAR
                    WRITE(MW0,*)'*** MISSING SYM   (2S+1)  L  P=',MTS+1,&
     &                          IL,JPAR,'  FOR 2J P =',JTOT,JPAR
                  ENDIF
                ENDIF
                GO TO 50
              ENDIF
            ENDDO
   20     ENDDO
   50   ENDDO
      ENDDO
!
      IF(.NOT.BTEST2)JCUNT0=JCOUNT
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE NUMSYM
!
!                             *******************
!
      FUNCTION PHASEX(E,C,Q,U,L,Z,X)
!
!-----------------------------------------------------------------------
!
!  N.R.BADNELL D.A.M.T.P. CAMBRIDGE
!
!  FN.PHASEX CALCULATES THE PHASE ASSOCIATED WITH A MODIFIED COULOMB
!  POTENTIAL -2Z/X -C/X**2 -Q/X**3 -U/X**4  (Z<0)
!  L .GE. 0, L DENOTES NON-RELATIVISTIC ANG. MOM.
!  L .LT. 0, A.M.=-(L+1) I.E. L=KAPPA (J=A.M.+DHALF)
!            RELATIVISTIC COULOMB PHASE, ASSUMES E,C,Z
!            CONTAIN THE MODIFIED COULOMB POTENTIAL.
!
!  IT IS CALLED BY:
!    SR.ASSX
!    SR.FCF6
!
!  IT CALLS:
!    FN.ARGAM
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
      REAL(WP) Q
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (D24=24)
!
!-----------------------------------------------------------------------
!
      PI=ACOS(-DONE)
      EL=L
      ZZ=Z*Z
      CK=SQRT(E)
      XK=X*CK
      XZ=X*Z
      C1=XK*XK-XZ-XZ-C
      IF(C1.LT.D1M10)THEN
        WRITE(MW6,10010)E,C,Q,U,L,Z,X
!
        PHASEX=DQUART*PI
        GO TO 100
      ENDIF
!
      CHI=SQRT(C1)
      IF(CHI.LT.DFIVE)WRITE(MW6,10020)E,C,Q,U,L,Z,X,CHI
!
      PHI=DZERO
      C1=DONE/CHI
      P=CHI-D8TH*C1
!
      IF(ABS(Z)+ABS(C).GT.D1M15)THEN
        D=E*C+ZZ
        A=ZZ*(CHI-XK)-CK*C*Z
        P=P-(A/(D24*D*(CHI+XK))+DFIVE*(XZ+C)*C1*C1/D24)*C1
      ENDIF
!
      IF(E.LT.D1M10)THEN
        P=P+CHI
      ELSE
        A=Z/CK
        P=P+A*(DONE-LOG(CHI+XK-A))
      ENDIF
!
      IF(L.LT.0)THEN                          !RELATIVISTIC
        T=SQRT(DONE+DALF*E)
        T=DTWO*(T-DONE)/DALF
        Z0=Z/(DONE+DHALF*DALF*T)
        G=-EL+DHALF*DALF*Z0*Z0/EL
        ETA=DZERO
        IF(E.GT.D1M10)ETA=ATAN(Z0/(CK*EL))+ATAN(Z/(CK*G))
        ETA=ETA*DHALF
        EL=G-DONE
        P=P+ETA
      ENDIF
!
      IF(E.LT.D1M10)THEN
        P=P-(EL+DQUART)*PI
      ELSE
        P=P-DHALF*EL*PI+ARGAM(EL,A)
      ENDIF
!
      IF(L.EQ.-1111)THEN                    !TEST RELATIVISTIC S-ORBITAL
        C1=SQRT(-C)
        T=DFSC*Z0
        IF(ABS(C1+T).GT.DALF)THEN
          WRITE(MW6,10030)C,Z0
          WRITE(MW0,10030)C,Z0
          PHASEX=DZERO
          GO TO 100
        ENDIF
        T0=CHI+XK
        T1=DONE+T0*DALF/(DTWO*X)
        T2=DONE+DALF*CK
        Y=DTWO*T1/(T2*T0)
      ELSEIF(C.LT.-D1M10)THEN
        C1=SQRT(-C)
        T1=C1*CHI-C-XZ
        T2=C1*XK-XZ
        Y=LOG(T1/T2)/C1
      ELSE
!
        IF(C.LT.D1M10)THEN
          T0=CHI+XK
          IF(ABS(Q).GT.D1M15)PHI=Q*(T0+XK)/(DTHREE*X*T0**2)
          IF(ABS(U).GT.D1M15)PHI=PHI+U*(DNINE*XK*CHI+DELEVN*XK*XK-DSIX* &
     &                           XZ)/(D5TEEN*X*X*T0**3)
!
          PHASEX=P+DONE/(DFOUR*(CHI+XK))+PHI
          GO TO 100
!
        ENDIF
!
        T=CK*C*CHI+ZZ*X+C*Z
        T1=(ZZ+E*C)*X
        Y=ACOS(T/T1)/SQRT(C)
!
      ENDIF
!
      IF(ABS(Q).GT.D1M15)PHI=Q*((XZ+XZ+C)/(X*(CHI+XK))-Z*Y)/C
      IF(ABS(U).GT.D1M15)THEN
        T1=DTHREE*Z*(XZ+XZ+C)/(X*(CHI+XK))+C*CHI/(X*X)
        PHI=PHI+U*(Y*(DTHREE*ZZ+E*C)-T1)/(DTWO*C*C)
      ENDIF
!
      PHASEX=P+(C+D8TH)*Y+PHI/DTWO
!
!-----------------------------------------------------------------------
!
  100 RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT('*** FAILED IN PHASEX:  E=',1PE10.2,' C=',1PE10.2,' Q=',   &
     &       1PE10.2,' U=',1PE10.2,' L=',I3,' Z=',1PE10.2,' X=',1PE10.2)
10020 FORMAT('*** INACCURACY IN PHASEX FOR E=',1PE10.2,' C=',1PE10.2,   &
     &       ' Q=',1PE10.2,' U=',1PE10.2,' L=',I3,' Z=',1PE10.2,' X=',  &
     &       1PE10.2,'CHI=',1PE10.2)
10030 FORMAT('*** FAILED IN PHASEX FOR RELATIVISTIC S-ORBITAL:',' C=',  &
     &       1PE10.2,' Z=',1PE10.2)
!
!-----------------------------------------------------------------------
!
      END FUNCTION PHASEX
!
!                             *******************
!
      FUNCTION PMVDAR(J,X,E,DZ,ELLP)
!
!-----------------------------------------------------------------------
!
!  FN.PMVDAR EVALUATES THE MASS-VELOCITY AND DARWIN POTENTIALS
!  AT RADIAL COORDINATE X(J).
!
!  E IS THE ELECTRON ENERGY
!  DZ IS THE NUCLEAR CHARGE, IF E.GE.0.
!  DZ IS NOT USED IF E.LT.0.
!  FOR ALL E, DZ IS THE ASYMPTOTIC CHARGE IF J.LT.0.
!  ELLP=L(L+1) IS NOT USED, EXCEPT FOR TEST CODE (AND KAPPA.NE.0)
!
!  IT IS CALLED BY:
!    SR.FCF6 (VIA SR.RADCON)
!    SR.NUMERO (VIA SR.RADIAL/RADWAV)
!    SR.RADWAV
!    FN.ZEFXL
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,VSC,XC1,XC2,NPITER
      USE COMMON_NRBPOT, ONLY: DPOT,TOL,MEND
      USE COMMON_NRBPOT, ONLY: DERV1,DERV2
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
      DUM=ELLP                                         !SUPPRESS WARNING
!
      TKAP=-DONE                          !(2J+1)-WEIGHTED KAPPA-AVERAGE
      IF(KAPPA.NE.0)TKAP=KAPPA
!
      if(j.lt.0)then                                !Darwin only (asymp)
        t=dz/x                                            !dz=asymp here
        dv1=-t/x
        dv2=-dtwo*dv1/x
        t=e+dtwo*t
        tt=done+dquart*dalf*t
        tt=done/tt
        if(kappa.eq.0)then
          a=-tt*(dv1*d3qrt*dalf*tt*dv1)
        else
          a=tt*(dv1*(-dtwo*tkap/x-d3qrt*dalf*tt*dv1)+dv2)
        endif
        pmvdar=dquart*dalf*a
        return
      endif
!
! MASS-VELOCITY
!
      IF(E.LT.DZERO)T=E+DTWO*DPOT(J)           !HISTORIC POT DIFF E<,>=0
      IF(E.GE.DZERO)T=E+DPOT(J)+DTWO*DZ/X               !DZ=nuclear here
      T=T+DTWO*VSC(J)                                   !+PLASMA POT
!
! DARWIN
!
!      w=done                                           !standard Darwin
!      if(kappa.ne.0)w=-2.                         !see also radwav/fcf6
!
      TT=DONE+DQUART*DALF*T
      TT=DONE/TT
      A=TT*(DERV1(J)*(-DTWO*TKAP/X-D3QRT*DALF*TT*DERV1(J))+DERV2(J))
!
!      a=tt*(derv1(j)*(-dtwo*tkap/x-(w+dtwo)*dalf*tt*derv1(j)/dfour)
!     &     +derv2(j))*w
!
!      if(kappa.ne.0)then
!        l=sqrt(ellp)
!        a=-(2*l)*a                          !c.f. bound case correction
!      endif
!
      PMVDAR=DQUART*DALF*(T*T+A)
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION PMVDAR
!
!                             *******************
!
      SUBROUTINE PNL(IR,H,L,X,P,JMAX,F)
!
!-----------------------------------------------------------------------
!
!  SR.PNL INTERPOLATES THE INPUT RADIAL FUNCTION P(X) TO OUTPUT F(Y)
!  FOR SUBSEQUENT USE BY SR.ROMB AND SR.FILON.
!
!  A. BURGESS DAMTP CAMBRIDGE - SEE ALSO J.PHYS.B30, 33 (1997).
!
!  IT IS CALLED BY:
!    SR.BORN
!
!  IT CALLS:
!
!  IT CONTAINS:
!    FN.FLAGR
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (J0=1)
!
      DIMENSION X(J0:*),P(J0:*),F(0:*)
!
!-----------------------------------------------------------------------
!
!      FLAGR(X1,X2,X3,X4,Z1,Z2,Z3,Z4,Z) =
!     &   ((Z-X2)*(Z-X3)*(Z-X4)/((X1-X2)*(X1-X3)*(X1-X4)))*Z1
!     & + ((Z-X1)*(Z-X3)*(Z-X4)/((X2-X1)*(X2-X3)*(X2-X4)))*Z2
!     & + ((Z-X1)*(Z-X2)*(Z-X4)/((X3-X1)*(X3-X2)*(X3-X4)))*Z3
!     & + ((Z-X1)*(Z-X2)*(Z-X3)/((X4-X1)*(X4-X2)*(X4-X3)))*Z4
!
!-----------------------------------------------------------------------
!
      R=DZERO
      F(0)=DZERO
      M=L+1
      J=J0
      DO I=1,IR
        R=R+H
   50   IF(R.GT.X(J).AND.J.LT.JMAX)THEN
          J=J+1
          GO TO 50
        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(DZERO,X(1),X(2),X(3),DZERO,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
        F(I)=T
      ENDDO
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      CONTAINS
!
!-----------------------------------------------------------------------
!
      FUNCTION FLAGR(X1,X2,X3,X4,Z1,Z2,Z3,Z4,Z)
!
      REAL(WP) X1,X2,X3,X4,Z1,Z2,Z3,Z4,Z,FLAGR
!
      FLAGR=((Z-X2)*(Z-X3)*(Z-X4)/((X1-X2)*(X1-X3)*(X1-X4)))            &
     &      *Z1+((Z-X1)*(Z-X3)*(Z-X4)/((X2-X1)*(X2-X3)*(X2-X4)))        &
     &      *Z2+((Z-X1)*(Z-X2)*(Z-X4)/((X3-X1)*(X3-X2)*(X3-X4)))        &
     &      *Z3+((Z-X1)*(Z-X2)*(Z-X3)/((X4-X1)*(X4-X2)*(X4-X3)))*Z4
!
      END FUNCTION FLAGR
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE PNL
!
!                             *******************
!
      subroutine pomrecv(nomt,omv,nr,omx)
!
!-----------------------------------------------------------------------
!
! sr.pomrecev transfers a slice of a vector (omv) to omega matrix (omx)
! where the slice may include part of a column.
!
! *** parallel *** may only be called by the parallel version.
!
!  it is called by:
!    sr.cadwx
!    sr.dwxbp_daxpy
!    sr.dwxbp_ddot
!    sr.dwxls_daxpy
!    sr.dwxls_ddot
!
!  it calls:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      real(rp) omx(*),omv(*)
!
!-----------------------------------------------------------------------
!
      do n=1,nomt
        nr=nr+1
        omx(nr)=omv(n)
      enddo
!
!-----------------------------------------------------------------------
!
      return
!
!-----------------------------------------------------------------------
!
      end subroutine pomrecv
!
!                             *******************
!
      subroutine pomsend(ns,omx,nomt,omv)
!
!-----------------------------------------------------------------------
!
! sr.pomsend transfers a slice of omega matrix (omx) to a vector (omv)
! where the slice may include part of a column.
!
! *** parallel *** may only be called by the parallel version.
!
!  it is called by:
!    sr.cadwx
!    sr.dwxbp_daxpy
!    sr.dwxbp_ddot
!    sr.dwxls_daxpy
!    sr.dwxls_ddot
!
!  it calls:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,RP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      real(rp) omx(*),omv(*)
!
!-----------------------------------------------------------------------
!
      do n=1,nomt
        ns=ns+1
        omv(n)=omx(ns)
      enddo
!
!-----------------------------------------------------------------------
!
      return
!
!-----------------------------------------------------------------------
!
      end subroutine pomsend
!
!                             *******************
!
      SUBROUTINE POTF(ZN,NPOINT,X,POT,TOL,IEND)
!
!-----------------------------------------------------------------------
!
!  SR.POTF CALCULATES THE R-MATRIX PARAMETRIC POTENTIAL.
!   DEFINED IN CPC 92,290(1995) EQS (79) & (80) BUT *NOT* (81)
!   BUT IS ASYMPTOTIC TO ZN/R, NOT 2*ZN/R.
!
!  IT IS CALLED BY:
!    SR.RADCON
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE COMMON_NRBPOT, ONLY: CPOT,XPOT,IPOT,NPOT
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION POT(*),X(*)
!
!-----------------------------------------------------------------------
!
      DTOL=TOL
      IF(ZN.GT.DZERO)DTOL=DTOL*ZN
!
      IEND=1
      DO I=1,NPOINT
        P=DZERO
        DO K=1,NPOT
          P=CPOT(K)*X(I)**IPOT(K)*EXP(-XPOT(K)*X(I))+P
        ENDDO
!        write(mw6,*)x(i),p,p*x(i)
        P=P/2                                          !AS RM 2V
        IF(ABS(P*X(I)-ZN).GT.DTOL)IEND=I
        POT(I)=P
      ENDDO
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE POTF
!
!                             *******************
!
      SUBROUTINE POTIN(Z0,MIONX,MK,MPOT,X,POT,MEND)
!
!-----------------------------------------------------------------------
!
!  SR.POTIN READS EXTERNAL POTENTIAL AND INTERPOLATES ONTO INTERNAL GRID
!   ATTEMPTS TO ADJUST NORMALIZATION BY EXAMINING LARGE R.
!   (CANNOT CHECK R=0 SINCE MAY BE FINITE NUCLEUS.)
!   SINCE NO STANDARD FORMAT EXISTS, ADJUST IT AS NEEDED.
!   BUT POTIN='AS' OR 'FAC' CAN BE SET IN NAMELIST SMINIM, FOR EXAMPLE.
!  N.B. MIONX CAN IN PRINCIPAL BE N- (SR.RADIAL) OR N+1 (SR.RADCON).
!
!  IT IS CALLED BY:
!    SR.STOPOT
!    SR.TFDAPO
!
!  IT CALLS:
!    SR.RE_ALLOC
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: MHF,MRAD,MSTEP,IXTRA,xmax
      USE COMMON_CMESH,  ONLY: IFLAGV
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
!
      USE COMMON_NRBREL, ONLY: RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      CHARACTER(LEN=1) CHAR1
!
      ALLOCATABLE :: XIN(:),PIN(:),KHLP(:)
!
      DIMENSION POT(*),X(*)
!
!-------------------------------------------------------------------
!
      IF(IUNIT(MR9).EQ.0)THEN
        WRITE(MW6,*)"MISSING INPUT FILE='hffcin/potin'..."
        WRITE(MW0,*)'MISSING FILE ON UNIT=MR9'
        GO TO 800
      ENDIF
!
      REWIND(MR9)
!
      ALLOCATE(KHLP(MPOT))
!
      TOLH=D1M2
!
! DETERMINE EXPECTED ASYMPTOTIC CHARGE
!
      Z=ABS(Z0)
!      N=MIONX
      ZN=1-MIONX
      ZN=Z+ZN
      ZN1=ZN
      IF(NINT(ZN1,SP).EQ.IZERO)ZN1=DONE
!
      IF(MHF.EQ.1)THEN
!
        READ(MR9,*)MPIN
!
        IF(MPIN.LT.DZERO)THEN
!
! USE RADWIN FORMAT AS WRITTEN TO POTOUT/RADOUT
!
          BACKSPACE(MR9)
          READ(MR9,*)IDUM,IDUM,IDUM,MPIN
!
          ALLOCATE(XIN(MPIN),PIN(MPIN))
!
          I=1
          DO J=1,MPIN/2
            READ(MR9,10030)IDUM,IDUM,XIN(I),PIN(I),IDUM,XIN(I+1),       &
     &                     PIN(I+1)
            I=I+2
          ENDDO
!
        ELSE
!
!  USE ORIGINAL AS X vs V*X GRID
!
          READ(MR9,*)XDUM,P
!
          P=ABS(P)
!
          IFLAG=0
          IF(P.GT.3*Z)THEN                  !LIKELY V(R) INPUT
            IF(IFLAGV.LE.0)THEN             !USER NOT FLAGGED OR WRONG
              WRITE(MW0,*)                                              &
     &    '*** SR.POTIN: EXPECTS EFFECTIVE CHARGE, BUT POTENTIAL FOUND?'
              WRITE(MW0,*)'ATTEMPTING TO COMPENSATE...'
              WRITE(MW6,*)                                              &
     &    '*** SR.POTIN: EXPECTS EFFECTIVE CHARGE, BUT POTENTIAL FOUND?'
              WRITE(MW6,*)'ATTEMPTING TO COMPENSATE...'
            ENDIF
            IFLAG=1
          ELSEIF(P.LT.D0PT1)THEN            !FINITE NUCLEUS..
            IF(IFLAGV.EQ.0)THEN             !USER NOT FLAGGED
              WRITE(MW0,*)                                              &
     &     '*** SR.POTIN: FINITE NUCLEUS FOUND. EXPECT EFFECTIVE CHARGE'
              WRITE(MW0,*)'BUT CANNOT COMPENSATE IF POTENTIAL INPUT'
              WRITE(MW0,*)                                              &
     &     '*** SR.POTIN: FINITE NUCLEUS FOUND. EXPECT EFFECTIVE CHARGE'
              WRITE(MW0,*)'BUT CANNOT COMPENSATE IF POTENTIAL INPUT'
              WRITE(MW0,*)'SET IFLAGV=1 IN SMINIM IF POTENTIAL INPUT'
              WRITE(MW6,*)'SET IFLAGV=1 IN SMINIM IF POTENTIAL INPUT'
            ENDIF
            IFLAG=IFLAGV                    !SET IFLAGV=1 IF POTENTIAL
          ENDIF
!
          BACKSPACE(MR9)
!
          ALLOCATE(XIN(MPIN),PIN(MPIN))
!
          IF(IFLAG.LE.0)THEN                !R*V(R) INPUT
            DO J=1,MPIN
              READ(MR9,*,END=20)XIN(J),PIN(J)
            ENDDO
          ELSE                              !V(R) INPUT
            DO J=1,MPIN
              READ(MR9,*,END=20)XIN(J),PIN(J)
              PIN(J)=PIN(J)*XIN(J)          !CONVERT TO R*V(R)
            ENDDO
          ENDIF
          J=MPIN+1
!
   20     MPIN=J-1
!
        ENDIF
!
      ELSEIF(MHF.EQ.2)THEN
!
! FAC (UNIQUE)
!
        WRITE(MW0,10010)
        WRITE(MW6,10020)
!
        IBUFIN=2*MPOT                                  !INPUT BUFFER
        ALLOCATE(XIN(IBUFIN),PIN(IBUFIN))
!
        J1=1
        DO J=J1,99                                          !SKIP HEADER
          READ(MR9,*,END=50)CHAR1
          IF(CHAR1.NE.'#'.AND.CHAR1.NE.' ')THEN
            IF(CHAR1.NE.'0')GO TO 50
            BACKSPACE(MR9)
            GO TO 100
          ENDIF
        ENDDO
   50   CONTINUE
        WRITE(MW6,*)'*** SR.POTIN: UNABLE TO DECODE FAC HEADER...'
        WRITE(MW6,*)'*** SR.POTIN: UNABLE TO DECODE FAC HEADER...'
        GO TO 800
!
  100   DO J=J1,IBUFIN
!          READ(MR9,*,END=50)ICDUM,XXX,DUMZ,PPP,VDIR,VXCH     !OLD FAC
          READ(MR9,*,END=150)ICDUM,XXX,DUMZ,VXTRA,VFIT,VRES   !NEW FAC
          XIN(J)=XXX
          ZNUKE=DUMZ
          FNUKE=ZNUKE-Z-VXTRA                                 !FINITE
          PPP=VFIT+VRES+VXTRA
          PPP=PPP+FNUKE                     !MUST REMOVE FINITE NUCLEUS
!          IF(XXX.LT.RNUK)PPP=-Z            !TEST FULL RE-SET
          PIN(J)=-PPP
!          PIN(J)=PIN(J)*XIN(J)             !COMMENT OUT IF R*V(R) INPUT
        ENDDO
!
        J1=IBUFIN+1
        MPIN=IBUFIN
        IBUFIN=(3*IBUFIN)/2
!
        CALL RE_ALLOC(XIN,IONE,MPIN,IBUFIN,IERR)
        CALL RE_ALLOC(PIN,IONE,MPIN,IBUFIN,IERR)
!
        GO TO 100
!
  150   MPIN=J-1
        IF(ABS(ZNUKE-Z).GT.D1M1)THEN              !CHECK NUCLEAR CHARGES
          WRITE(MW6,10040)ZNUKE
          WRITE(MW0,10040)ZNUKE
          GO TO 800
        ENDIF
!
        PNORM=1               !FAC ASYMPTOTIC CHARGE DIFFER BY +-/1 UNIT
!
      ELSEIF(MHF.EQ.3)THEN
!
! NL-DEPENDENT
!
  200   READ(MR9,*,END=700)MPIN,MYN,MYL
!
        IF(MYN.NE.QN(MK).OR.MYL*2.NE.QL(MK))THEN
!
          DO I=1,MPIN
            READ(MR9,*)
          ENDDO
!
          GO TO 200
!
        ELSE
!
          READ(MR9,*)XDUM,P
!
          P=ABS(P)
!
          IFLAG=0
          IF(P.GT.3*Z)THEN                    !LIKELY V(R) INPUT
            IF(IFLAGV.LE.0)THEN               !USER NOT FLAGGED OR WRONG
              WRITE(MW0,*)                                              &
     &    '*** SR.POTIN: EXPECTS EFFECTIVE CHARGE, BUT POTENTIAL FOUND?'
              WRITE(MW0,*)'ATTEMPTING TO COMPENSATE...'
              WRITE(MW6,*)                                              &
     &    '*** SR.POTIN: EXPECTS EFFECTIVE CHARGE, BUT POTENTIAL FOUND?'
              WRITE(MW6,*)'ATTEMPTING TO COMPENSATE...'
            ENDIF
            IFLAG=1
          ELSEIF(P.LT.D0PT1)THEN              !FINITE NUCLEUS...
            IF(IFLAGV.EQ.0)THEN               !USER NOT FLAGGED
              WRITE(MW0,*)                                              &
     &     '*** SR.POTIN: FINITE NUCLEUS FOUND. EXPECT EFFECTIVE CHARGE'
              WRITE(MW0,*)'BUT CANNOT COMPENSATE IF POTENTIAL INPUT'
              WRITE(MW6,*)                                              &
     &     '*** SR.POTIN: FINITE NUCLEUS FOUND. EXPECT EFFECTIVE CHARGE'
              WRITE(MW6,*)'BUT CANNOT COMPENSATE IF POTENTIAL INPUT'
              WRITE(MW0,*)'SET IFLAGV=1 IN SMINIM IF POTENTIAL INPUT'
              WRITE(MW6,*)'SET IFLAGV=1 IN SMINIM IF POTENTIAL INPUT'
            ENDIF
            IFLAG=IFLAGV                      !SET IFLAGV=1 IF POTENTIAL
          ENDIF
!
          BACKSPACE(MR9)
!
          ALLOCATE(XIN(MPIN),PIN(MPIN))
!
          IF(IFLAG.LE.0)THEN                !R*V(R) INPUT
            DO I=1,MPIN
              READ(MR9,*)XIN(I),PIN(I)
            ENDDO
          ELSE                              !V(R) INPUT
            DO I=1,MPIN
              READ(MR9,*)XIN(I),PIN(I)
              PIN(I)=PIN(I)*XIN(I)          !CONVERT TO R*V(R)
            ENDDO
          ENDIF
!
        ENDIF
!
      ELSE
        WRITE(MW0,*)'***SR.POTIN: ILLEGAL INPUT VALUE FOR MHF'
        WRITE(MW6,*)'***SR.POTIN: ILLEGAL INPUT VALUE FOR MHF: ',MHF
        GO TO 800
      ENDIF
!
! CHECK NORM
!
      IF(MHF.NE.2)THEN
        P=ABS(PIN(1))
        IF(P.GT.D0PT1)THEN              !ASSUME POINT NUCLEUS
          PNORM=PIN(1)/Z
          IP=1
        ELSE
          PNORM=PIN(MPIN)/ZN
          IP=MPIN
        ENDIF
        INORM=NINT(PNORM,SP)
        IF(ABS(PNORM-REAL(INORM,WP)).GT.D1M1.OR.inorm.EQ.0.OR.abs(inorm)&
     &     .gt.2)THEN
          WRITE(MW6,10050)IP,XIN(IP),PIN(IP)
          WRITE(MW0,10060)
          GO TO 800
        ELSE
          PNORM=DONE/PNORM
        ENDIF
      ELSE
! ADD COMMENT IF FAC AYMPTOTIC CHARGE DIFFERS FROM "EXPECTED"?
      ENDIF
!
! HELP INTERPOLATE
!
      II=1
      DO K=1,MPOT
        KHLP(K)=0
        GO TO 300
  250   II=II+1
  300   IF(II.GT.MPIN)GO TO 400
        IF(II.EQ.MPIN)GO TO 350
        IF(XIN(II+1)+XIN(II).LT.X(K)*DTWO)GO TO 250
  350   IF(X(K).GT.XIN(MPIN))GO TO 250
        KHLP(K)=II
  400 ENDDO
!
! LAGRANGE INTERPOLATION (NLAG+1 POINTS) FROM ARGUMENTS XIN TO X
!
      NLAG=4
!
      MEND=1
      DO L=1,MPOT
        IF(X(L).GT.XIN(MPIN))GO TO 500
        DD1=DZERO
        M=KHLP(L)-NLAG/2
        I1=MAX(M,IONE)
        I2=I1+NLAG
        IF(I2.GT.MPIN)I2=MPIN
        DO I=I1,I2
          DD=DONE
          DM=DONE
          DO J=I1,I2
            IF(J.NE.I)THEN
              DM=(X(L)-XIN(J))*DM
              DD=(XIN(I)-XIN(J))*DD
            ENDIF
          ENDDO
          DD1=PIN(I)*DM/DD+DD1
        ENDDO
        DD1=DD1*PNORM
!        j=khlp(l)
!        write(mw6,1005)l,x(l),dd1,j,i1,i2,xin(j),pin(j)
! 1005 format(5x,i4,1p,2e14.7,14x,3i4,2e14.7)
        POT(L)=DD1/X(L)
        T=DD1-ZN
        IF(ABS(T/ZN1).GT.TOLH)MEND=L
      ENDDO
!
! FILL THE REMAINING POTENTIAL AS A COULOMB POTENTIAL
!
  500 DO J=L,MPOT
        POT(J)=ZN/X(J)
      ENDDO
!
  600 IF(ALLOCATED(KHLP))DEALLOCATE(KHLP,XIN,PIN)
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
  700 NF=0                                            !NOT FOUND
      GO TO 600
!
  800 NF=-1
      GO TO 600
!
!-----------------------------------------------------------------------
!
10010 FORMAT(//'*** ATTENTION: SEE COMMENTS IN olg REGARDING NUMERICAL',&
     &       ' ACCURACY WHEN USING THE DEFAULT FAC GetPotential() ***')
10020 FORMAT(//'*** ATTENTION: THE DEFAULT PRINT OF THE FAC POTENTIAL ',&
     &   'USES TOO FEW SIGNIFICANT FIGURES FOR AS TO REPRODUCE THE FAC '&
     &   ,                                                              &
     &   'ENERGIES EXACTLY ***'/'*** IT IS RECOMMENDED TO EDIT THE FAC '&
     &   ,                                                              &
     &   'ROUTINE radial.c SO THAT THE PRINT FORMAT USES 8 SIGNIFICANT '&
     &   ,'FIGURES (E.G. %12.5E -> %15.8) ***'/)
10030 FORMAT(I5,2(I4,2D14.7))
10040 FORMAT(' *** SR.POTIN: MIS-MATCH OF NUCLEAR CHARGE WITH FAC',     &
     &       ' EXTERNAL POTENTIAL, Z=',F8.2)
10050 FORMAT(/' *** SR.POTIN: UNABLE TO DETERMINE NORM OF EXTERNAL',    &
     &       ' POTENTIAL AT I, R(I), R(I)*V(I) =',I6,1P,2E10.2)
10060 FORMAT(/' *** SR.POTIN: UNABLE TO DETERMINE NORM OF EXTERNAL',    &
     &       ' POTENTIAL')
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE POTIN
!
!                     *******************
!
      SUBROUTINE PQ(NCHLT,RHO,TP,TQ,WORK,NF)
!
!-------------------------------------------------------------------
!
!  SR.PQ DETERMINES THE P AND Q MATRICES, WHICH ARE RELATED
!    TO THE REAL AND IMAGINARY PARTS OF THE T-MATRIX BY
!      T=-2(P+I*Q), I=SQRT(-1)
!    USING THE FULL RHO-MATRIX,
!      P=-RHO^2/(1+RHO^2)
!      Q=RHO/(1+RHO^2)
!    I.E. THE S-MATRIX IS UNITARY
!  N.B. STGICF SR.TMTRIX DETERMINES -TR=P AND TI=Q
!       STGF SR.PQ DETERMINES P=Q AND Q=-P
!    THIS IS THE NON-LAPACK VERSION
!    IT REQUIRES NO ADDITIONAL INTERNAL MEMORY
!
!  IT IS CALLED BY:
!    SR.DWXBP_DAXPY
!    SR.DWXBP_DDOT
!    SR.DWXLS_DAXPY
!    SR.DWXLS_DDOT
!
!  IT CALLS:
!    SR.MULTS
!    SR.VERTS
!
!-------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION RHO(*),TP(*),TQ(*),WORK(*)
!
!-------------------------------------------------------------------
!
      CALL MULTS(TP,RHO,RHO,NCHLT)
!
      N=1
      DO J=NCHLT,1,-1
        TP(N)=TP(N)+DONE
        N=N+J
      ENDDO
!
      CALL VERTS(TP,-NCHLT,NCHLT,WORK,IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW6,10010)
        WRITE(MW0,*)'***SR.PQ: NO INVERSE FOUND'
        NF=-1
        GO TO 100
      ENDIF
!
      CALL MULTS(TQ,RHO,TP,NCHLT)
!
      N=1
      DO J=NCHLT,1,-1
        TP(N)=TP(N)-DONE
        N=N+J
      ENDDO
!
!-----------------------------------------------------------------------
!
  100 RETURN
!
!-------------------------------------------------------------------
!
10010 FORMAT(' ***SR.PQ: THE MATRIX: 1 + K^2 HAS NO INVERSE',           &
     &       ' - MUST ABORT')
!
!-------------------------------------------------------------------
!
      END SUBROUTINE PQ
!
!                     *******************
!
      SUBROUTINE PQLAP(NCHLT,RHO,TP,TQ,WORK,NF)
!
!-------------------------------------------------------------------
!
!  SR.PQ DETERMINES THE P AND Q MATRICES, WHICH ARE RELATED
!    TO THE REAL AND IMAGINARY PARTS OF THE T-MATRIX BY
!      T=-2(P+I*Q), I=SQRT(-1)
!    USING THE FULL RHO-MATRIX,
!      P=-RHO^2/(1+RHO^2)
!      Q=RHO/(1+RHO^2)
!    I.E. THE S-MATRIX IS UNITARY.
!  N.B. STGICF SR.TMTRIX DETERMINES -TR=P AND TI=Q
!       STGF SR.PQ DETERMINES P=Q AND Q=-P
!
!    THIS IS THE LAPACK VERSION
!    IT IS A MEMORY HOG
!  N.B. ARGUMENT WORK IS ONLY USED BY LAPACK
!
!  IT IS CALLED BY:
!    SR.DWXBP_DAXPY
!    SR.DWXBP_DDOT
!    SR.DWXLS_DAXPY
!    SR.DWXLS_DDOT
!
!  IT CALLS:
!    SR.DGEMM
!    SR.DSYTRF
!    SR.DSYTRI
!    SR.DSYTRS
!
!-------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION RHO(*),TP(*),TQ(*),WORK(*)
!
      ALLOCATABLE :: TEMP(:),TEMP2(:)
      ALLOCATABLE :: IPIVOT(:)                                   !LAPACK
!
!-----------------------------------------------------------------------
!
      NCHSQ=NCHLT*NCHLT
!
      ALLOCATE(TEMP(NCHSQ),TEMP2(NCHSQ),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'PQLAP: ALLOCATION FAILS FOR TEMP'
        NF=0
        RETURN
      ENDIF
!                                                                !LAPACK
      ALLOCATE(IPIVOT(NCHLT),STAT=IERR)                          !LAPACK
!
      TEMP2=DZERO                      !JUST SUPPRESS NOT INIT. WARNINGS
!
      N=0
      NI=0
      NJ0=0
      DO J=1,NCHLT
        NJ=NJ0+J
        DO I=J,NCHLT
          N=N+1
          NI=NI+1
          TEMP(NI)=RHO(N)
          TEMP(NJ)=RHO(N)
          NJ=NJ+NCHLT
        ENDDO
        NI=NI+J
        NJ0=NJ0+NCHLT
      ENDDO
!                                                                !LAPACK
      CALL DGEMM('N','N',NCHLT,NCHLT,NCHLT,DONE,TEMP                    &!LAPACK
     &           ,NCHLT,TEMP,NCHLT,DZERO,TEMP2,NCHLT)            !LAPACK
!
      N=0
      DO I=1,NCHLT
        N=N+1
        TEMP2(N)=TEMP2(N)+DONE
        N=N+NCHLT
      ENDDO
!                                                                !LAPACK
      CALL DSYTRF('L',NCHLT,TEMP2,NCHLT,IPIVOT,WORK,NCHLT               &!LAPACK
     &           ,INFO)                                          !LAPACK
!                                                                !LAPACK
      IF(INFO.NE.0)THEN                                          !LAPACK
        WRITE(MW6,70000)INFO                                     !LAPACK
        WRITE(MW0,*)                                                    &!LAPACK
     &       'SR.PQLAP: FAILURE IN LAPACK ROUTINE DSYTRF'        !LAPACK
        NF=-1                                                    !LAPACK
        GO TO 7000                                               !LAPACK
      ENDIF                                                      !LAPACK
!                                                                !LAPACK
      CALL DSYTRS('L',NCHLT,NCHLT,TEMP2,NCHLT,IPIVOT,TEMP               &!LAPACK
     &           ,NCHLT,INFO)                                    !LAPACK
!                                                                !LAPACK
      IF(INFO.NE.0)THEN                                          !LAPACK
        WRITE(MW6,70010)INFO                                     !LAPACK
        WRITE(MW0,*)                                                    &!LAPACK
     &       'SR.PQLAP: FAILURE IN LAPACK ROUTINE DSYTRS'        !LAPACK
        NF=-1                                                    !LAPACK
        GO TO 7000                                               !LAPACK
      ENDIF                                                      !LAPACK
!                                                                !LAPACK
      CALL DSYTRI('L',NCHLT,TEMP2,NCHLT,IPIVOT,WORK,INFO)        !LAPACK
!                                                                !LAPACK
      IF(INFO.NE.0)THEN                                          !LAPACK
        WRITE(MW6,70020)INFO                                     !LAPACK
        WRITE(MW0,*)                                                    &!LAPACK
     &       'SR.PQLAP: FAILURE IN LAPACK ROUTINE DSYTRI'        !LAPACK
      ENDIF                                                      !LAPACK
!
      N=0
      DO I=1,NCHLT
        N=N+1
        TEMP2(N)=TEMP2(N)-DONE
        N=N+NCHLT
      ENDDO
!
      N=0
      NI=0
      DO J=1,NCHLT
        DO I=J,NCHLT
          N=N+1
          NI=NI+1
          TP(N)=TEMP2(NI)
          TQ(N)=TEMP(NI)
        ENDDO
        NI=NI+J
      ENDDO
!
!-----------------------------------------------------------------------
!                                                                !LAPACK
 7000 CONTINUE                                                   !LAPACK
!
      DEALLOCATE(TEMP,TEMP2,STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'PQLAP: DE-ALLOCATION FAILS FOR TEMP'
        NF=0
      ENDIF
!                                                                !LAPACK
      DEALLOCATE(IPIVOT,STAT=IERR)                               !LAPACK
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!                                                                !LAPACK
70000 FORMAT(//10X,10('*'),                                             &!LAPACK
     &' SR.PQLAP: DSYTRF RETURNED WITH INFO =',I6)               !LAPACK
70010 FORMAT(//10X,10('*'),                                             &!LAPACK
     &' SR.PQLAP: DSYTRS RETURNED WITH INFO =',I6)               !LAPACK
70020 FORMAT(//10X,10('*'),                                             &!LAPACK
     &' SR.PQLAP: DSYTRI RETURNED WITH INFO =',I6)               !LAPACK
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE PQLAP
!
!                             *******************
!
      subroutine pcasym(iam,nproc)
!
!-----------------------------------------------------------------------
!
! *** parallel *** may only be called by the parallel version.
!
! sr.pcasym distributes l-symmetries over the nproc processors
! by defining local inast, l-values, based on the global
! value. attempts to load balance exchange and non-exchange,
! in the case of inast.le.0. up to user in case of inast.gt.0.
! there is no allowance for scaling from one-l to the other
! since at best there is likely to be a few l per-processor.
!
! only called in ca-coupling.
! - see psymls for ls-coupling.
! - see psymj for lsj-coupling.
!
!  it is called by:
!    sr.algx
!
!  it calls:
!    sr.dimuse
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : sp_mpi                         !par
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_QTG,    ONLY: MTGD,NXLL,NTT,NTG,JTGD,QTGS,QTGL,QTGD
!
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,INAST0=>NASTB                            &
     &                        ,INASTJ0=>NASTJB,LFACT,JFACT              &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!par!                                                               !par
!par      integer(sp_mpi) iam,nproc                                 !par
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
! inast=inast0 here
!
      if(inast0.gt.0)then
!
! just extract an iam subset of pre-defined global lspi
!
        lmin=1
        lrange=inast0                             !global
        if(nproc.gt.lrange)then
          write(mw6,*)'too many processors for specified inast,',       &
     &                ' use nproc=',lrange
          if(iam.eq.0)then
            write(mw0,*)'too many processors for specified inast'
          endif
          nf=-1
          go to 100
        endif
        lperproc=lrange/nproc
        lxtra=lrange-lperproc*nproc
!
        lmin=lmin+iam*lperproc+min(lxtra,iam)
        lmax=lmin+lperproc-1
        if(iam.lt.lxtra)lmax=lmax+1
        write(mw0,*)iam,lmin,lmax
!
! shift down global lspi symms to form local
!
        i=0
        do l=lmin,lmax
          i=i+1
          lspi(i)=lspi(l)
        enddo
        inast=i                                   !local
!
      else
!
! set-up a global set of lspi and then extract an iam subset
! (not the most elegant way of doing it, perhaps, but makes
!  it easier to play around with the local distribution
!  because the complete global distribution is present to
!  select from. of course, at the end of the day, each lspi
!  must be selected once.)
!
! defaults (see/sync. sr.casym)
! n.b.exchange settings redundant here for ca since no x/nx partition...
!
        if(mxlamx.eq.1000)then                   !max exchange multipole
          if(maxlx.ge.100)then
!x            mxlamx=nxll+3                  !twice max orb l+3 (was +1)
            mxlamx=nxll/2+nmultx-1           !nmultx=no. lambdas:  gefgw
          else
!            mxlamx=(maxlx+1)/2
            mxlamx=maxlx-nxll/2
          endif
        endif
!        if(maxlx.ge.100)maxlx=2*mxlamx              !max l for exchange
        if(maxlx.ge.100)maxlx=mxlamx+nxll/2          !max l for exchange
!t      if(maxlx.lt.maxlt+2)then      !ca only for comparison with ls/bp
!t        maxlx=max(maxlx,QCL0/2-1)   !need all channels to scale direct
!t      endif
!
        if(lvmax.ge.0)then                                !bthrsh=.true.
!
          maxl=lvmax+QCL0/2
          if(maxlt.eq.1000)maxlt=maxl
          if(maxlt.gt.maxl)then
            write(mw6,10020)
            write(mw6,10030)maxl,lvmax
            write(mw6,10020)
            maxlt=maxl
          elseif(maxlt.lt.maxl)then
            write(mw6,10020)
            write(mw6,10040)maxlt,lvmax,maxl
            write(mw6,10020)
!            maxlt=maxl                       !allow user to restrict...
          endif
!
          minl=lvmin-QCL0/2
          minl=max(izero,minl)
          if(minlt.gt.minl)then
            write(mw6,10020)
            write(mw6,10050)minlt,lvmin,minl
            write(mw6,10020)
!            minlt=minl                       !allow user to restrict...
          elseif(minlt.lt.minl)then
            write(mw6,10020)
            write(mw6,10060)minl,lvmin
            write(mw6,10020)
            minlt=minl
          endif
!
        else
!
          if(maxlt.eq.1000)maxlt=30
          if(maxlt.gt.100)maxlt=100
          if(minlt.lt.0)minlt=0
!
        endif
!
        if(lrglam.gt.maxlt)then
          lrglam=-1                                        !so no top-up
        else
          if(lrglam.eq.-999)lrglam=maxlt
        endif
        if(lrglam.eq.0)lrglam=-1
!
! global no. symms,
!   check dimension & if too many processors assigned.
!
        lrange=maxlt-minlt+1
!
        if(lrange.gt.iaxsl)then
          if(maxsl.gt.0)write(mw6,10010)lrange
        endif
!
        if(nproc.gt.lrange)then
          write(mw6,*)'too many processors for l-symmetries,',          &
     &                ' use nproc=',lrange
          if(iam.eq.0)write(mw0,*)'too many processors for l-symmetries'
          nf=-1
          go to 100
        endif
!
        iaxsl=lrange
        allocate(lspi(iaxsl),stat=ierr)
        if(ierr.ne.0)then
          write(mw0,*)'pcasym: allocation fails for lspi'
          nf=0
          go to 100
        endif
        call dimuse('MAXSL',iaxsl)
!
! attempt to balance low- and high-l, case more l's than proc's.
!
        ngrpl=nproc              ! =nproc, or =1 for sequential l
!
! assign global exchange lsp
!
        i=0
        do n=0,ngrpl-1
          il0=minlt+n
          do il=il0,maxlt,ngrpl
            i=i+1
            lspi(i)=il
          enddo
        enddo
!
        if(lrange.ne.i)then
          if(iam.eq.0)write(mw0,*)'ca l:',lrange,i
          nf=-1
          go to 100
        endif
        inast0=i                                  !global
!
! shift down global lspi symms to form local
!
        lperproc=lrange/nproc
        lxtra=lrange-lperproc*nproc
!
        lmin=1
        lmin=lmin+iam*lperproc+min(lxtra,iam)
        lmax=lmin+lperproc-1
        if(iam.lt.lxtra)lmax=lmax+1
!        write(mw0,*)iam,lmin,lmax
!
        i=0
        do l=lmin,lmax
          i=i+1
          lspi(i)=lspi(l)
!          write(mw0,*)iam,i,lspi(i)
        enddo
        inast=i                                   !local
!
      endif
!
      inast0=inast                                !re-sync.
!
!-----------------------------------------------------------------------
!
  100 return
!
!-----------------------------------------------------------------------
!
10010 FORMAT('***sr.pcasym: allocation increases number of symmetries ',&
     &       ' iaxsl =',i3,' .gt. maxsl=',i3)
10020 FORMAT(//1x,136('-')//)
10030 FORMAT(/' note: reducing maxlt to',i3,', that needed by lvmax=',  &
     &       i3)
10040 FORMAT(/' ***warning: you have set maxlt=',i3,', less than that', &
     &       ' formally needed by lvmax=',i3/22x,'set maxlt=',i3,       &
     &       ', to satisfy triangle relation')
10050 FORMAT(/' ***warning: you have set minlt=',i3,', greater that',   &
     &       ' formally needed by lvmin=',i3/22x,'set minlt=',i3,       &
     &       ', to satisfy triangle relation')
10060 FORMAT(/' note: increasing minlt to',i3,', that needed by lvmin=',&
     &       i3)
!
!-----------------------------------------------------------------------
!
      end subroutine pcasym
!
!                             *******************
!
      subroutine psymj(iam,nproc)
!
!-----------------------------------------------------------------------
!
! *** parallel *** may only be called by the parallel version.
!
! sr.psymj distributes jp symmetries over the nproc processors
! by defining local inastj, jpi values, based on the global
! values. attempts to load balance 2-body fine-structure with rest,
! in the case of inast.le.0. up to user in case of inast.gt.0.
! all lspi values that are needed for the jpi on each processor
! are calculated independently by said processor. there is no
! read of a common calculated set from disk (currently).
!
! only called in lsj-coupling.
! - see psymls for ls-coupling.
!
!  it is called by:
!    sr.algx
!
!  it calls:
!    sr.dimuse
!    sr.numsym
!
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : sp_mpi                         !par
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
!
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,INAST0=>NASTB                            &
     &                        ,INASTJ0=>NASTJB,LFACT,JFACT              &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,INASTJ=>NASTJ                   &
     &                        ,MINJT,MAXJT,NEIGENJ
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!par!                                                               !par
!par      integer(sp_mpi) iam,nproc                                 !par
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
! inastj=inastj0 here
!
      if(inastj0.gt.0)then
!
! just extract an iam subset of pre-defined global jpi
!
        jmin=1
        jrange=inastj0                             !global
        if(nproc.gt.jrange)then
          write(mw6,*)'too many processors for specified inastj,',      &
     &                ' use nproc=',jrange
          if(iam.eq.0)then
            write(mw0,*)'too many processors for specified inastj'
          endif
          nf=-1
          go to 100
        endif
        jperproc=jrange/nproc
        jxtra=jrange-jperproc*nproc
!
        jmin=jmin+iam*jperproc+min(jxtra,iam)
        jmax=jmin+jperproc-1
        if(iam.lt.jxtra)jmax=jmax+1
        write(mw0,*)iam,jmin,jmax
!
! shift down global jpi symms to form local
!
        i=0
        do j=jmin,jmax
          i=i+1
          jpi(i)=jpi(j)
        enddo
        inastj=i                                   !local
!
      else
!
! set-up a global set of jpi and then extract an iam subset
! (not the most elegant way of doing it, perhaps, but makes
!  it easier to play around with the local distribution
!  because the complete global distribution is present to
!  select from. of course, at the end of the day, each jpi
!  must be selected once.)
!
! defaults (lsp & jp - see/sync. sr.symls/j)
!
        if(inast0.le.0)then
!          if(maxlt.eq.1000)maxlt=30
!          if(maxlt.gt.100)maxlt=100
          if(minlt.lt.0)minlt=0
          if(minsp.lt.1)minsp=1
          i1=mod(INT(QCS0,SP),ITWO)
          i0=mod(minsp-1,itwo)
          if(i0.eq.i1)minsp=minsp+1
          maxsp=min(maxsp,INT(QCS0+2,SP))
        endif
!
        ipar=abs(ipar)
        ipar=mod(ipar,ithree)
        ip0=mod(ipar,itwo)
        ip1=min(ipar,ione)
        ipart=max(ione,ipar)
!
        if(maxjt.gt.200)maxjt=60
        if(minjt.lt.0)minjt=0
        mtest=mod(int(QCS0,sp),ITWO)
        if(mod(minjt,itwo).eq.mtest)minjt=minjt+1
        if(mod(maxjt,itwo).eq.mtest)maxjt=maxjt-1
        if(mod(maxjfs,itwo).eq.mtest)maxjfs=maxjfs-1
!
        if(lrglam.gt.maxjt)then
          lrglam=-1                                        !so no top-up
        else
          if(lrglam.eq.-999)lrglam=maxjt
        endif
        if(lrglam.eq.0)lrglam=-1
!
        jfs=min(maxjfs,maxjt)
        jj=max(minjt,maxjfs+2)
!
! global no. symms,
!   check dimension & if too many processors assigned.
!
        jrngfs=max(ipart*(jfs-minjt+2)/2,izero)
        jrng=max(ipart*(maxjt-jj+2)/2,izero)
        jrange=jrngfs+jrng
!
        if(jrange.gt.iaxjg)then
          if(maxjg.gt.0)write(mw6,10010)jrange
        endif
!
        if(nproc.gt.jrange)then
          write(mw6,*)'too many processors for jp symmetries,',         &
     &                ' use nproc=',jrange
          if(iam.eq.0)then
            write(mw0,*)'too many processors for jp symmetries'
          endif
          nf=-1
          go to 100
        endif
!
        iaxjg=jrange
        allocate(jpi(iaxjg),stat=ierr)
        if(ierr.ne.0)then
          write(mw0,*)'psymj: allocation fails for jpi'
          nf=0
          go to 100
        endif
        call dimuse('MAXJG',iaxjg)
!
! assign global fine-structure jpi
! (want same parity and adjacent j on same processor so as to minimize
!  the ls recomputation.)
!
        i=0
        do ip=ip0,ip1
          do ij=minjt,jfs,2
            i=i+1
            jpi(i)=10*ij+ip
          enddo
        enddo
!
        if(jrngfs.ne.i)then
          write(mw6,*)'sr.psymj: mis-match fine-structure j:',jrngfs,i
          if(iam.eq.0)write(mw0,*)'sr.psymj: mis-match fine-structure j'
          nf=-1
          go to 100
        endif
        inastj0=i                                  !global
!
! shift down global jpi symms to form local
!
        jrange=jrngfs
        jperproc=jrange/nproc
        jxtra=jrange-jperproc*nproc
!
        jmin=1
        jmin=jmin+iam*jperproc+min(jxtra,iam)
        jmax=jmin+jperproc-1
        if(iam.lt.jxtra)jmax=jmax+1
!        write(mw6,*)iam,jmin,jmax
!
        i=0
        do j=jmin,jmax
          i=i+1
          jpi(i)=jpi(j)
        enddo
        inastj=i                                   !local
!
! assign global ordinary jpi
!
        i=inastj0
        do ip=ip0,ip1
          do ij=jj,maxjt,2
            i=i+1
            jpi(i)=10*ij+ip
          enddo
        enddo
!
        if(jrng.ne.i-inastj0)then
          if(iam.eq.0)write(mw0,*)'ordinary j:',jrng,i-inastj0
          nf=-1
          go to 100
        endif
        inastj0=i                                  !global
!
! shift down global jpi symms to form local
!
        jrange=jrng
        jperproc=jrange/nproc
        jxtra=jrange-jperproc*nproc
!
        jmin=jrngfs+1
        jmin=jmin+iam*jperproc+min(jxtra,iam)
        jmax=jmin+jperproc-1
        if(iam.lt.jxtra)jmax=jmax+1
!        write(mw6,*)iam,jmin,jmax
!
        i=inastj
        do j=jmin,jmax
          i=i+1
          jpi(i)=jpi(j)
        enddo
        inastj=i                                   !local
!
      endif
!
      inastj0=inastj                               !re-sync.
!
! now, given the jp set on each processor, we need to assign all of the
! necessary local lsp. since currently there is no passing file, and we
! don't want to message pass the ls algebra (!), this means lsp symmetry
! algebra is being multiplicated. however, since the jk-coupling problem
! is an order of magnitude more demanding than the ls-coupling one, this
! may not be critical. eventually, will code a restartx file(s), along
! the lines of the target algebra restart file. then, each processor can
! read the appropriate lsp symmetry data it needs for its jp.
!
! first get a maximal value for the total no. of lspi for the jpi set
! (recall, lspi is not yet allocated here)
!
      iaxsl=0
      do i=1,inastj
        ij=jpi(i)/10
        ipj=jpi(i)-ij*10
        jcount=0
        call numsym(ij,ipj,jcount)
        iaxsl=iaxsl+jcount
      enddo
!
      allocate(lspi(iaxsl),stat=ierr)
      if(ierr.ne.0)then
        write(mw0,*)'psymj: allocation fails for lspi'
        nf=0
        go to 100
      endif
!
! now create the actual lspi set
!
      jcount=-1
      inast=0
      do i=1,inastj
        ij=jpi(i)/10
        ipj=jpi(i)-ij*10
        call numsym(ij,ipj,jcount)
      enddo
!
! tidy-up
!
      if(inast.lt.iaxsl)then
        call re_alloc(lspi,ione,iaxsl,inast,ierr)
        if(ierr.ne.0)then
          write(mw0,*)'psymj: re-allocation fails for lspi'
          nf=0
          go to 100
        endif
        iaxsl=inast
        call dimuse('MAXSL',iaxsl)
      elseif(inast.gt.iaxsl)then                  !should not happen
        write(mw0,*)'sr.psymj: inast.gt.iaxsl:',inast,iaxsl
        nf=0
        go to 100
      endif
!
      inast0=inast                                !re-sync.
!
!-----------------------------------------------------------------------
!
  100 return
!
!-----------------------------------------------------------------------
!
10010 FORMAT('***sr.psymj: allocation increases number of symmetries ', &
     &       ' iaxjg =',i3,' .gt. maxjg=',i3)
!
!-----------------------------------------------------------------------
!
      end subroutine psymj
!
!                             *******************
!
      subroutine psymls(iam,nproc)
!
!-----------------------------------------------------------------------
!
! *** parallel *** may only be called by the parallel version.
!
! sr.psymls distributes lsp symmetries over the nproc processors
! by defining local inast, lspi values, based on the global
! values. attempts to load balance exchange and non-exchange,
! in the case of inast.le.0. up to user in case of inast.gt.0.
! there is no allowance for scaling from one-l to the other
! since at best there is likely to be a few l per-processor.
!
! only called in ls-coupling.
! - see psymj for lsj-coupling.
!
!  it is called by:
!    sr.algx
!
!  it calls:
!    sr.dimuse
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : sp_mpi                         !par
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_QTG,    ONLY: MTGD,NXLL,NTT,NTG,JTGD,QTGS,QTGL,QTGD
!
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,INAST0=>NASTB                            &
     &                        ,INASTJ0=>NASTJB,LFACT,JFACT              &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!par!                                                               !par
!par      integer(sp_mpi) iam,nproc                                 !par
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
! inast=inast0 here
!
      if(inast0.gt.0)then
!
! just extract an iam subset of pre-defined global lspi
!
        lmin=1
        lrange=inast0                             !global
        if(nproc.gt.lrange)then
          write(mw6,*)'too many processors for specified inast,',       &
     &                ' use nproc=',lrange
          if(iam.eq.0)then
            write(mw0,*)'too many processors for specified inast'
          endif
          nf=-1
          go to 100
        endif
        lperproc=lrange/nproc
        lxtra=lrange-lperproc*nproc
!
        lmin=lmin+iam*lperproc+min(lxtra,iam)
        lmax=lmin+lperproc-1
        if(iam.lt.lxtra)lmax=lmax+1
        write(mw0,*)iam,lmin,lmax
!
! shift down global lspi symms to form local
!
        i=0
        do l=lmin,lmax
          i=i+1
          lspi(i)=lspi(l)
        enddo
        inast=i                                   !local
!
      else
!
! set-up a global set of lspi and then extract an iam subset
! (not the most elegant way of doing it, perhaps, but makes
!  it easier to play around with the local distribution
!  because the complete global distribution is present to
!  select from. of course, at the end of the day, each lspi
!  must be selected once.)
!
! defaults (see/sync. sr.symls)
!
        if(mxlamx.eq.1000)then                   !max exchange multipole
          if(maxlx.ge.100)then
            mxlamx=nxll+3                    !twice max orb l+3 (was +1)
          else
!            mxlamx=(maxlx+1)/2
            mxlamx=maxlx-nxll/2
          endif
        endif
!        if(maxlx.ge.100)maxlx=2*mxlamx              !max l for exchange
        if(maxlx.ge.100)maxlx=mxlamx+nxll/2          !max l for exchange
        maxlx=max(maxlx,INT(QCL0/2-1,SP))  !all channels to scale direct
!
        if(maxloo.ge.100)maxloo=maxlx
!
        if(lvmax.ge.0)then                                !bthrsh=.true.
!
          maxl=lvmax+QCL0/2
          if(maxlt.eq.1000)maxlt=maxl
          if(maxlt.gt.maxl)then
            write(mw6,10020)
            write(mw6,10030)maxl,lvmax
            write(mw6,10020)
            maxlt=maxl
          elseif(maxlt.lt.maxl)then
            write(mw6,10020)
            write(mw6,10040)maxlt,lvmax,maxl
            write(mw6,10020)
!            maxlt=maxl                       !allow user to restrict...
          endif
!
          minl=lvmin-QCL0/2
          minl=max(izero,minl)
          if(minlt.gt.minl)then
            write(mw6,10020)
            write(mw6,10050)minlt,lvmin,minl
            write(mw6,10020)
!            minlt=minl                       !allow user to restrict...
          elseif(minlt.lt.minl)then
            write(mw6,10020)
            write(mw6,10060)minl,lvmin
            write(mw6,10020)
            minlt=minl
          endif
!
        else
!
          if(maxlt.eq.1000)maxlt=30
          if(maxlt.gt.100)maxlt=100
          if(minlt.lt.0)minlt=0
!
        endif
!
        if(lrglam.gt.maxlt)then
          lrglam=-1                                        !so no top-up
        else
          if(lrglam.eq.-999)lrglam=maxlt
        endif
        if(lrglam.eq.0)lrglam=-1
!
        if(minsp.lt.1)minsp=1
        i1=mod(INT(QCS0,SP),ITWO)
        i0=mod(minsp-1,itwo)
        if(i0.eq.i1)minsp=minsp+1
        maxsp=min(maxsp,INT(QCS0+2,SP))
!
        ipar=abs(ipar)
        ipar=mod(ipar,ithree)
        ip0=mod(ipar,itwo)
        ip1=min(ipar,ione)
        ipart=max(ione,ipar)
!
        qsrngx=INT((maxsp-minsp+2)/2,QP)
        lx=min(maxlx,maxlt)
        if(minsp.eq.1)then
          is1=3
          is2=max(ithree,maxsp)
        else
          is1=minsp
          is2=maxsp
        endif
        qsrngnx=INT((is2-is1+2)/2,QP)
        lnx=max(minlt,maxlx+1)
!
! global no. symms,
!   check dimension & if too many processors assigned.
!
        lrngx=max(ipart*(lx-minlt+1)*qsrngx,izero)
        lrngnx=max(ipart*(maxlt-lnx+1)*qsrngnx,izero)
        lrange=lrngx+lrngnx
!
        if(lrange.gt.iaxsl)then
          if(maxsl.gt.0)write(mw6,10010)lrange
        endif
!
        if(nproc.gt.lrange)then
          write(mw6,*)'too many processors for lsp symmetries,',        &
     &                ' use nproc=',lrange
          if(iam.eq.0)then
            write(mw0,*)'too many processors for lsp symmetries'
          endif
          nf=-1
          go to 100
        endif
!
        iaxsl=lrange
        allocate(lspi(iaxsl),stat=ierr)
        if(ierr.ne.0)then
          write(mw0,*)'psymls: allocation fails for lspi'
          nf=0
          go to 100
        endif
        call dimuse('MAXSL',iaxsl)
!
! attempt to balance low- and high-l, case more l's than proc's.
!
        ngrpl=nproc              ! =nproc, or =1 for sequential l
!
! assign global exchange lsp
!
        i=0
        do n=0,ngrpl-1
          il0=minlt+n
          do il=il0,lx,ngrpl
            do is=minsp,maxsp,2
              do ip=ip0,ip1
                i=i+1
                lspi(i)=10000*is+10*il+ip
              enddo
            enddo
          enddo
        enddo
!
        if(lrngx.ne.i)then
          if(iam.eq.0)write(mw0,*)'exchange:',lrngx,i
          nf=-1
          go to 100
        endif
        inast0=i                                  !global
!
! shift down global lspi symms to form local
!
        lrange=lrngx
        lperproc=lrange/nproc
        lxtra=lrange-lperproc*nproc
!
        lmin=1
        lmin=lmin+iam*lperproc+min(lxtra,iam)
        lmax=lmin+lperproc-1
        if(iam.lt.lxtra)lmax=lmax+1
!        write(mw6,*)iam,lmin,lmax
!
        i=0
        do l=lmin,lmax
          i=i+1
          lspi(i)=lspi(l)
        enddo
        inast=i                                   !local
!
! assign global non-exchange lsp
!
        i=inast0
        do il=lnx,maxlt
          do is=is1,is2,2
            do ip=ip0,ip1
              i=i+1
              lspi(i)=10000*is+10*il+ip
            enddo
          enddo
        enddo
!
        if(lrngnx.ne.i-inast0)then
          if(iam.eq.0)write(mw0,*)'non-exchange:',lrngnx,i-inast0
          nf=-1
          go to 100
        endif
        inast0=i                                  !global
!
! shift down global lspi symms to form local
!
        lrange=lrngnx
        lperproc=lrange/nproc
        lxtra=lrange-lperproc*nproc
!
        lmin=lrngx+1
        lmin=lmin+iam*lperproc+min(lxtra,iam)
        lmax=lmin+lperproc-1
        if(iam.lt.lxtra)lmax=lmax+1
!        write(mw6,*)iam,lmin,lmax
!
        i=inast
        do l=lmin,lmax
          i=i+1
          lspi(i)=lspi(l)
        enddo
        inast=i                                   !local
!
      endif
!
      inast0=inast                                !re-sync.
!
!-----------------------------------------------------------------------
!
  100 return
!
!-----------------------------------------------------------------------
!
10010 FORMAT('***sr.psymls: allocation increases number of symmetries ',&
     &       ' iaxsl =',i3,' .gt. maxsl=',i3)
10020 FORMAT(//1x,136('-')//)
10030 FORMAT(/' note: reducing maxlt to',i3,', that needed by lvmax=',  &
     &       i3)
10040 FORMAT(/' ***warning: you have set maxlt=',i3,', less than that', &
     &       ' formally needed by lvmax=',i3/22x,'set maxlt=',i3,       &
     &       ', to satisfy triangle relation')
10050 FORMAT(/' ***warning: you have set minlt=',i3,', greater that',   &
     &       ' formally needed by lvmin=',i3/22x,'set minlt=',i3,       &
     &       ', to satisfy triangle relation')
10060 FORMAT(/' note: increasing minlt to',i3,', that needed by lvmin=',&
     &       i3)
!
!-----------------------------------------------------------------------
!
      end subroutine psymls
!
!                             *******************
!
      FUNCTION QBINOM(N0,M0)
!
!-----------------------------------------------------------------------
!
! DETERMINE BINOMIAL COEFFICIENT: N!/(N-M)!*M!
! RETURNS ZERO SILENTLY IF ARGUMENT(S) OUT OF RANGE.
!
!  IT IS CALLED BY:
!    SR.ALGEB1
!    SR.CADWX
!    SR.CAEKAL
!    SR.CALGEB
!    SR.CARATE
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      INTEGER(SP) QBINOM                       !DO NOT USE SHORT INTEGER
!
!-----------------------------------------------------------------------
!
      IF(M0.LT.0.OR.M0.GT.N0)THEN
        I8=0
      ELSE
        N=N0
        M=M0
        IF(2*M0.GT.N0)M=N-M
        N=N+1
        I8=1
        DO J=1,M                  !J=1 CATCHES M=0
          I8=I8*(N-J)
          I8=I8/J
        ENDDO
      ENDIF
!
      QBINOM=I8
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION QBINOM
!
!                             *******************
!
      SUBROUTINE QEDINT(MAXPS)
!
!-----------------------------------------------------------------------
!
!  This routine evaluates the QED corrections to the energy levels
!  due to vacuum polarisation (correct to first order) and a crude
!  approximation to the self energy.
!  The V.P. contribution is calculated using the results of Fullerton
!  and Rinker Phys. Rev. A  Vol 13  P 1283 (1976) while the S.E.
!  contribution is estimated for S, P- and P orbitals by interpolating
!  among the values given by P. Mohr for Coulomb type wavefunctions
!  after an effective nuclear charge, ZEFF, is obtained by finding the
!  ZEFF required to give a Coulomb orbital with the same average R
!  as the MCDF orbital.
!
!  Very loosely adapted from PHN's GRASP0 routine by NRB.
!
!  IT IS CALLED BY:
!    SR.RADIAL
!    SR.RADWIN
!
!  IT CALLS:
!    SR.FZALF
!    SR.VACPOL
!    SR.WEDDLE
!    SR.ZEFR
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
!
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBQED, ONLY: VPINT,SLFINT,QED
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBVAL, ONLY: FACT,IVAL,NNEW,NNOLD,BJUMP,BJUMP2,BRAD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (DKEY=999)
!
      ALLOCATABLE :: DA(:),DPA(:)
!
!-----------------------------------------------------------------------
!
! THE NAMES HERE ARE NOT NECESSARILY SIGNIFICANT THEY ARE COMMON LEGACY.
!
! LOCAL
      ALLOCATE(DA(MAXPS),DPA(MAXPS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'QEDINT: ALLOCATION FAILS FOR DA,DPA'
        NF=0
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
!      write(mw6,3000)
!
      PI=ACOS(-DONE)
!
      BREL2=ABS(IREL).EQ.2
!
!  Calculate the vacuum polarisation potential at each of the grid
!  points
!
      Z=NZION
!
      CALL VACPOL(Z,DX,MAXPS,DPA)
!
!  Obtain contribution from each orbital
!
      DO K=1,MXORB
!
        IF(DEY(K).EQ.DZERO)GO TO 100
        IF(BJUMP.AND.IVAL(K).EQ.0)GO TO 100
        IF(SCREEN(K).GE.DKEY)GO TO 100                 !NOT YET COMPUTED
!
!  Obtain v.p. contribution for orbital K
!
        DO I=1,MAXPS
          DA(I)=DPNL(I,K)*DPNL(I,K)*DPA(I)
        ENDDO
!
        IF(BREL2)THEN
          DO I=1,MAXPS
            DA(I)=DA(I)+DQNL(I,K)*DQNL(I,K)*DPA(I)
          ENDDO
        ENDIF
!
        CALL WEDDLE(DZERO,DA,ALLINT,MNH,DHNS,MJH,MAXPS)
!
        VPINT(K)=ALLINT
!
!  Obtain s.e. contribution for orbital I
!
        IF(QL(K).GT.2)THEN
!
!  No estimate for other than s, p- or p states
!
          VALU=DZERO
!
        ELSE
!
          IF(BREL)THEN
!
!  ...find average R for Dirac orbital...
!
            DO I=1,MAXPS
              DA(I)=DPNL(I,K)*DPNL(I,K)*DX(I)
            ENDDO
!
            IF(BREL2)THEN
              DO I=1,MAXPS
                DA(I)=DA(I)+DQNL(I,K)*DQNL(I,K)*DX(I)
              ENDDO
            ENDIF
!
            CALL WEDDLE(DZERO,DA,RAV,MNH,DHNS,MJH,MAXPS)
!
!  ...find effective Z of Coulomb orbital with same average R...
!
            CALL ZEFR(K,RAV,ZEFF)
!
            IF(ZEFF.LE.DZERO)ZEFF=Z
!
          ELSE
!
            ZEFF=Z-SCREEN(K)
!
          ENDIF
!
!  ...interpolate among P. Mohr data...
!
          CALL FZALF(ZEFF,K,VALU)
!
!  ...scale as required...
!
!          VALU=(ZEFF**4/XCL**3)*VALU/(PI*REAL(QN(K)**3,WP))
          VALU=ZEFF*(ZEFF*DFSC/REAL(QN(K),WP))**3*VALU/PI
!
        ENDIF
!
        SLFINT(K)=VALU
!
!  Print contributions if requested
!
!        write(6,3010)k,qn(k),ql(k)/2,vpint(k),slfint(k)
!     &              ,vpint(k)+slfint(k)
!     &              ,zeff,rav
!
  100 ENDDO
!
!-----------------------------------------------------------------------
!
! LOCAL
      DEALLOCATE(DA,DPA,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'QEDINT: DE-ALLOCATION FAILS FOR DA,DPA'
        NF=0
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
! 3000 FORMAT (/25X,' Q.E.D. CONTRIBUTIONS /2RY'/8X,'  GAM    N    L',
!     +1X,' VACUUM POLARIZ.',5X,'SELF ENERGY',8X,'TOTAL')
! 3010 FORMAT (8X,3I5,3(2X,D15.8),2f10.5)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE QEDINT
!
!                             *******************
!
      FUNCTION QPTLS(IX,NC00,ND00,LI0,LF0)
!
!-----------------------------------------------------------------------
!
!  FN.QPTLS INITIALIZES THE POINTER FOR DETERMINING THE 2-BODY
!           NFS INTERACTIONS (ALGEBRA) FOR:
!  INPUT:
!    IX IS THE LSP SYMMETRY INDEX
!    NC0 IS THE INITIAL TARGET LSP INDEX
!    ND0 IS THE FINAL TARGET LSP INDEX
!    LI IS THE INITIAL CONTINUUM ORBITAL ANG. MOM.
!    LF IS THE FINAL CONTINUUM ORBITAL ANG. MOM.
!    bcorr flags if correlation may be present (then corr-corr was
!    omitted from algebra - default, anyway - see algxls to sync.)
!
!  IT IS CALLED BY:
!    SR.DWXBP_DAXPY
!    SR.DWXBP_DDOT
!    SR.DWXLS_DAXPY
!    SR.DWXLS_DDOT
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE COMMON_MINIM,  ONLY: BECOR
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      use common_misc,   only: ione1,ione0
!
      USE COMMON_NRBDW4, ONLY: DSPECE,INDEX,JNDEX,NSPECE,NENERG
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBDWX, ONLY: LLCH,ITARG,NCHG
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBKUT, ONLY: KCUTX,LSKUT,NASTK
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      INTEGER(SP) QPTLS                        !DO NOT USE SHORT INTEGER
!
!-----------------------------------------------------------------------
!
! if elastic is dropped here then it has an effect on inelastic
! transitions between terms of same symmetry because they are mixed
!
!old  ione0=0                                    !=0 retain elastic here
!
! if bcor then we have algebraic correlation, and we know how ordered
!
      bcor=kmax*kcut.ne.kcut*kcut
!
! if becor then we have correlation by energy, and we know not where, so
!
      beqgrpl0=.not.becor                       !false for full li=lf mx
!
! if only algebraic then can reduce memory requirement  NAD(NCOR)
!
      bcorr=bcor.and..not.becor.and.kcutx.ge.0
!
!-----------------------------------------------------------------------
!
      IF(NC00.GT.ND00)THEN
        IREV=1
        NC0=NC00
        ND0=ND00
        LI=LI0
        LF=LF0
      ELSEIF(NC00.LT.ND00)THEN
        IREV=-1
        NC0=ND00
        ND0=NC00
        LI=LF0
        LF=LI0
      ELSE
        NC0=NC00
        ND0=ND00
        IF(LI0.GE.LF0)THEN
          IREV=1
          LI=LI0
          LF=LF0
        ELSE
          IREV=-1
          LI=LF0
          LF=LI0
        ENDIF
      ENDIF
!
      NNN=0
!      NCN=NC0
      ncorr=0
!
      DO N=1,NC0
        NC=ITARG(N,IX)
        MC=NSL(NC)
        L1=LLCH(1,N,IX)
        L2=LLCH(2,N,IX)
        LD=((L2-L1)/4+1)
        NCH=MC*LD
        if(bcorr)mci=ngrpi(nc)
!
        NCNP=N
        IF(N.EQ.NC0)NCNP=ND0
!
        DO NP=1,NCNP
          ND=ITARG(NP,IX)
          beqgrp=nc.eq.nd
          beqgrpl=beqgrpl0.and.beqgrp
          IF(NMETAG(NC)+NMETAG(ND).LT.2)THEN
            IF(beqgrp)THEN
              L1P=L1
              LDP=(LD*(LD+1))/2
              LD=1
              NCH=MC
            ELSE
              L1P=LLCH(1,NP,IX)
              L2P=LLCH(2,NP,IX)
              LDP=((L2P-L1P)/4+1)
            ENDIF
            MCP=NSL(ND)
            NCHP=MCP*LDP
            NNN=NNN+NCH*NCHP
!
            if(bcorr)then
              nco=0
              nce=0
!            do lli=l1,l2,4
!              lf2=l2p
!              if(nc.eq.nd)lf2=lli
!              do llf=l1p,lf2,4
              mcip=ngrpi(nd)
              do m=1,mc
                j1=m+mci
                j=jndex(j1)
                do mp=1,mcp
                  j1p=mp+mcip
!                  if(j1p.gt.j1-ione0.and.lli.eq.llf)go to 61
                  jp=jndex(j1p)
                  if(j.lt.0.and.jp.lt.0)then
                    nco=nco+1                         !corr.-corr.
                    if(j1.eq.j1p)nce=nce+1
                  endif
                enddo
!   61           continue
              enddo
              ncorr=ncorr+nco*ld*ldp
            endif
          ENDIF
        ENDDO
!
        IF(beqgrpl.and.NMETAG(NC).LT.1)THEN
          LDD=(L2-L1)/4+1
          MM=MC+ione0
          NNN=NNN-LDD*(MM*(MM-1))/2                   !FOR LI.EQ.LF
          if(bcorr)ncorr=ncorr-ldd*(nco-nce)/2        !for li.eq.lf
!          write(mw0,*)-nadg(ix)-nnn,-ldd*(mm*(mm-1))/2,ldd,mc
        ENDIF
!
      ENDDO
!                                                     !ADJUST LAST BLOCK
      IF(beqgrpl.and.NMETAG(NC).LT.1)THEN
        NNN=NNN+LDD*(MM*(MM-1))/2                     !FOR LI.EQ.LF
        if(bcorr)ncorr=ncorr+ldd*(nco-nce)/2          !for li.eq.lf
      ENDIF
!
      IF(NMETAG(NC)+NMETAG(ND).LT.2)THEN
        NNN=NNN-NCH*NCHP
        if(bcorr)ncorr=ncorr-nco*ld*ldp
!
!          write(mw0,*)'nadg',nadg(ix)
        IF(beqgrp)THEN
          LD=(LI-L1)/4
          LDP=(LD*(LD+1))/2
          NNN=NNN+MC*MC*LDP
          if(bcorr)ncorr=ncorr+nco*ldp
!          write(mw0,*)nadg(ix)+nnn,ldp,mc
          if(beqgrpl)then
            MM=MC+ione0
            NNN=NNN-LD*(MM*(MM-1))/2                  !FOR LI.EQ.LF
            if(bcorr)ncorr=ncorr-ld*(nco-nce)/2       !for li.eq.lf
!            write(mw0,*)nadg(ix)+nnn,-ld,mm
          endif
          LDP=(LF-L1P)/4
          NCHP=MCP*LDP
          NNN=NNN+MC*NCHP
          if(bcorr)ncorr=ncorr+nco*ldp
!          write(mw0,*)nadg(ix)+nnn,ldp
        ELSE
          LD=(LI-L1)/4
          NCH=MC*LD
          NNN=NNN+NCH*NCHP
          if(bcorr)ncorr=ncorr+nco*ld*ldp
          LDP=(LF-L1P)/4
          NCHP=MCP*LDP
          NNN=NNN+MC*NCHP
          if(bcorr)ncorr=ncorr+nco*ldp
!          write(mw0,*)-nadg(ix)-nnn
        ENDIF
!
      ENDIF
!
      IADD=NADG(IX)+NNN-ncorr              !assuming corr.-corr. omitted
!
!      write(mw0,*)irev*ix,nc00,nd00,li0,lf0,nadg(ix),nnn,-ncorr,iadd
!      write(mw6,*)irev*ix,nc00,nd00,li0,lf0,nadg(ix),nnn,-ncorr,iadd
!
      if(irev.lt.0)iadd=iadd+1         !for case iadd=0 (e.g. bp nmetag)
!
      QPTLS=IADD*IREV
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION QPTLS
!
!                             *******************
!
      FUNCTION QPTLSJ(KX,IX00,JX00,NC00,ND00,LI0,LF0)
!
!-----------------------------------------------------------------------
!
!  FN.QPTLSJ INITIALIZES THE POINTER FOR DETERMINING THE 2-BODY
!           FS INTERACTIONS (ALGEBRA) FOR:
!  INPUT:
!    KX IS THE JP SYMMETRY INDEX
!    IX0 IS THE INITIAL LSP SYMMETRY INDEX
!    JX0 IS THE FINAL LSP SYMMETRY INDEX
!    NC0 IS THE INITIAL TARGET LSP INDEX
!    ND0 IS THE FINAL TARGET LSP INDEX
!    LI IS THE INITIAL CONTINUUM ORBITAL ANG. MOM.
!    LF IS THE FINAL CONTINUUM ORBITAL ANG. MOM.
!    bcorr flags if correlation may be present (then corr-corr was
!    omitted from algebra - default, anyway - see algxls to sync.)
!
!  IT IS CALLED BY:
!    SR.ALGXFS
!    SR.DWXBP_DAXPY
!    SR.DWXBP_DDOT
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE COMMON_MINIM,  ONLY: BECOR
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      use common_misc,   only: ione1,ione0
!
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,INAST0=>NASTB                            &
     &                        ,INASTJ0=>NASTJB,LFACT,JFACT              &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDW4, ONLY: DSPECE,INDEX,JNDEX,NSPECE,NENERG
      USE COMMON_NRBDWJ, ONLY: JSYMM,NCHGJ,NADGJ
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBDWX, ONLY: LLCH,ITARG,NCHG
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,INASTJ=>NASTJ                   &
     &                        ,MINJT,MAXJT,NEIGENJ
      USE COMMON_NRBKUT, ONLY: KCUTX,LSKUT,NASTK
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      INTEGER(SP) QPTLSJ                       !DO NOT USE SHORT INTEGER
!
!
!-----------------------------------------------------------------------
!
! if elastic is dropped here then it has an effect on inelastic
! transitions between terms of same symmetry because they are mixed
!
!old  ione0=0                                    !=0 retain elastic here
!
! if bcor then we have algebraic correlation, and we know how ordered
!
      bcor=kmax*kcut.ne.kcut*kcut
!
! if becor then we have correlation by energy, and we know not where, so
!
      beqgrpl0=.not.becor                       !false for full li=lf mx
!
! if only algebraic then can reduce memory requirement  NAD/J(NCOR/J)
!
      bcorr=bcor.and..not.becor.and.kcutx.ge.0
!
!-----------------------------------------------------------------------
!
      IJ=JPI(KX)/10
      if(ij.gt.maxjfs)stop 'qptlsj called for 2j>maxjfs!'  !shouldn't be
!
      IF(IX00.GT.JX00)THEN
        IREV=1
        IX0=IX00
        JX0=JX00
        NC0=NC00
        ND0=ND00
        LI=LI0
        LF=LF0
      ELSEIF(IX00.LT.JX00)THEN
        IREV=-1
        IX0=JX00
        JX0=IX00
        NC0=ND00
        ND0=NC00
        LI=LF0
        LF=LI0
      ELSE        !THEN AS LS CASE, LIKELY NCOR WILL FLAG BUT TO BE SAFE
        IX0=IX00
        JX0=JX00
        IF(NC00.GT.ND00)THEN
          IREV=1
          NC0=NC00
          ND0=ND00
          LI=LI0
          LF=LF0
        ELSEIF(NC00.LT.ND00)THEN
          IREV=-1
          NC0=ND00
          ND0=NC00
          LI=LF0
          LF=LI0
        ELSE
          NC0=NC00
          ND0=ND00
          IF(LI0.GE.LF0)THEN
            IREV=1
            LI=LI0
            LF=LF0
          ELSE
            IREV=-1
            LI=LF0
            LF=LI0
          ENDIF
        ENDIF
      ENDIF
!
      NNN2=0
      ncorr2=0
!
      DO NX=1,IX0
        IX=JSYMM(NX,KX)
        IS=LSPI(IX)/10000
        IP=LSPI(IX)-IS*10000
        IL=IP/10
        NCN=NCHG(IX)
!
        MXP=NX
        IF(NX.EQ.IX0)MXP=JX0
!
        DO MX=1,MXP
          JX=JSYMM(MX,KX)
          ISP=LSPI(JX)/10000
          IPP=LSPI(JX)-ISP*10000
          ILP=IPP/10
          IF((IS+ISP-2)*(IL+ILP).GT.0)THEN
!
            BSYM=NX.EQ.IX0.AND.MX.EQ.JX0
            IF(BSYM)NCN=NC0
            NCNP=NCHG(JX)
!
!          write(mw0,*)'q-start',kx,nx,mx,nadgj(kx)+nnn2-ncorr2
            DO N=1,NCN
              NC=ITARG(N,IX)
              MC=NSL(NC)
              L1=LLCH(1,N,IX)
              L2=LLCH(2,N,IX)
              LD=((L2-L1)/4+1)
              NCH=MC*LD
              if(bcorr)mci=ngrpi(nc)
!
              IF(IX.EQ.JX)NCNP=N
              IF(BSYM.AND.N.EQ.NC0)NCNP=ND0
!
              DO NP=1,NCNP
                ND=ITARG(NP,JX)
                beqgrp=ix.eq.jx.and.nc.eq.nd
                beqgrpl=beqgrpl0.and.beqgrp
                IF(abs(NMETAG(NC))+abs(NMETAG(ND)).LT.2)THEN
                  IF(beqgrp)THEN
                    L1P=L1
                    LDP=(LD*(LD+1))/2
                    LD=1
                    NCH=MC
                  ELSE
                    L1P=LLCH(1,NP,JX)
                    L2P=LLCH(2,NP,JX)
                    LDP=((L2P-L1P)/4+1)
                  ENDIF
                  MCP=NSL(ND)
                  NCHP=MCP*LDP
                  NNN2=NNN2+NCH*NCHP
!
                  if(bcorr)then
                    nco=0
                    nce=0
!            do lli=l1,l2,4
!              lf2=l2p
!              if(nc.eq.nd)lf2=lli
!              do llf=l1p,lf2,4
                    mcip=ngrpi(nd)
                    do m=1,mc
                      j1=m+mci
                      j=jndex(j1)
                      do mp=1,mcp
                        j1p=mp+mcip
!                if(ix.eq.jx.and.j1p.gt.j1-ione0.and.lli.eq.llf)go to 61
                        jp=jndex(j1p)
                        if(j.lt.0.and.jp.lt.0)then
                          nco=nco+1                         !corr.-corr.
                          if(j1.eq.j1p)nce=nce+1
                        endif
                      enddo
!   61                 continue
                    enddo
                    ncorr2=ncorr2+nco*ld*ldp
                  endif
                ENDIF
              ENDDO
!
              IF(beqgrpl.and.NMETAG(NC).eq.0)THEN
                LDD=(L2-L1)/4+1
                MM=MC+ione0
                NNN2=NNN2-LDD*(MM*(MM-1))/2                !FOR LI.EQ.LF
                if(bcorr)ncorr2=ncorr2-ldd*(nco-nce)/2     !for li.eq.lf
              ENDIF
!
            ENDDO
!          write(mw0,*)'q-end',kx,nx,mx,nadgj(kx)+nnn2-ncorr2
          ENDIF
        ENDDO
      ENDDO
!                                                     !ADJUST LAST BLOCK
      IF(beqgrpl.and.abs(NMETAG(NC)).lt.1)THEN
        NNN2=NNN2+LDD*(MM*(MM-1))/2                        !FOR LI.EQ.LF
        if(bcorr)ncorr2=ncorr2+ldd*(nco-nce)/2             !for li.eq.lf
      ENDIF
!
      IF(abs(NMETAG(NC))+abs(NMETAG(ND)).LT.2)THEN
        NNN2=NNN2-NCH*NCHP
        if(bcorr)ncorr2=ncorr2-nco*ld*ldp
!
!          write(mw0,*)'nadg',nadg(ix)
        IF(beqgrp)THEN
          LD=(LI-L1)/4
          LDP=(LD*(LD+1))/2
          NNN2=NNN2+MC*MC*LDP
          if(bcorr)ncorr2=ncorr2+nco*ldp
!          write(mw0,*)nadgj(kx)+nnn2,ldp,mc
          if(beqgrpl)then
            MM=MC+ione0
            NNN2=NNN2-LD*(MM*(MM-1))/2                     !FOR LI.EQ.LF
            if(bcorr)ncorr2=ncorr2-ld*(nco-nce)/2          !for li.eq.lf
!            write(mw0,*)nadgj(kx)+nnn2,-ld,mm
          endif
          LDP=(LF-L1P)/4
          NCHP=MCP*LDP
          NNN2=NNN2+MC*NCHP
          if(bcorr)ncorr2=ncorr2+nco*ldp
!          write(mw0,*)nadgj(kx)+nnn2,ldp
        ELSE
          LD=(LI-L1)/4
          NCH=MC*LD
          NNN2=NNN2+NCH*NCHP
          if(bcorr)ncorr2=ncorr2+nco*ld*ldp
          LDP=(LF-L1P)/4
          NCHP=MCP*LDP
          NNN2=NNN2+MC*NCHP
          if(bcorr)ncorr2=ncorr2+nco*ldp
!          write(mw0,*)-nadgj(kx)-nnn2
        ENDIF
!
      ENDIF
!
      IADJ=NADGJ(KX)+NNN2-ncorr2           !assuming corr.-corr. omitted
!
      if(irev.lt.0)iadj=iadj+1            !for case iadj=0 (e.g. nmetag)
!
      QPTLSJ=IADJ*IREV
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION QPTLSJ
!
!                             *******************
!
      SUBROUTINE RADBP1(K2,K4,KTYPE,DK,M00)
!
!-----------------------------------------------------------------------
!
!  SR.RADBP1 CALCULATES MAGNETIC ONE-BODY RADIATIVE INTEGRALS:
!  M1+BP  FOR KTYPE=1-8, OR
!  M_K FOR KTYPE=9,10 (SEE BELOW FOR DEFINITIONS).
!
!  IT IS CALLED BY:
!    SR.SOCC
!
!  IT CALLS:
!    SR.DIFF
!    FN.SBESS
!    SR.WEDDLE
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_INTS,   ONLY: DOSC
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
      USE COMMON_REL,    ONLY: DMASS,DCD,D2LL
!
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      ALLOCATABLE :: DWRK1(:),DWRK2(:),DWRK3(:)
!
      DIMENSION CON(10)
!
      ALLOCATE(DWRK1(MAXRS),DWRK2(MAXRS),DWRK3(MAXRS))
!
!-----------------------------------------------------------------------
!
      BREL2=ABS(IREL).EQ.2
!
      IK2=ICOL(K2,K2,IZERO)
      IK4=ICOL(K4,K4,IZERO)
!
      if(k4.gt.k2.and.ktype.ne.2.and.ktype.ne.3)stop 'radbp1: k4.gt.k2'
!
      CON(1)=DALF4
      CON(2)=CON(1)
      CON(3)=CON(1)
      CON(4)=CON(1)
      CON(5)=DALF/DTWO
      CON(6)=DALF/DEIGHT
      CON(7)=CON(5)
      CON(8)=DONE
      CON(9)=DONE
      CON(10)=CON(1)
!
      N=KTYPE
      M0=MOD(M00,I1000)
!
      if(m0.ne.0.or.m0.eq.0.and.n.eq.0)then      !should not occur (now)
        write(mw6,*)'radbp1, what are we doing here?',m0,m00,n
        write(mw0,*)'radbp1, what are we doing here?'
        go to 1300
      endif
!
      JSWTCH=1
!
! COMPUTE M1BP RADIATIVE ONE-BODY INTEGRALS
!
!  P1(R)*P2(R)*F(R) WHERE F(R) DEPENDS ON THE TYPE
!
!      N=ABS(N)
      if(n.lt.0)then                             !should not occur (now)
        write(mw6,*)'radbp1: ktype.lt.0!!',m0,m00,n
        write(mw0,*)'radbp1: ktype.lt.0!!'
        go to 1300
      endif
!
      DKU=DZERO
      D00=DZERO
!
!      GO TO (31,32,33,34,35,36,37,35,50,51),N
!
      IF(N.EQ.1)THEN
        GO TO 100
      ELSEIF(N.EQ.2)THEN
        GO TO 200
      ELSEIF(N.EQ.3)THEN
        GO TO 300
      ELSEIF(N.EQ.4)THEN
        GO TO 400
      ELSEIF(N.EQ.5)THEN
        GO TO 600
      ELSEIF(N.EQ.6)THEN
        GO TO 700
      ELSEIF(N.EQ.7)THEN
        GO TO 800
      ELSEIF(N.EQ.8)THEN
        GO TO 600
      ELSEIF(N.EQ.9)THEN
        GO TO 1000
      ELSEIF(N.EQ.10)THEN
        GO TO 1000
      ELSE
        write(mw6,*)'Index error in SR.RADBP1: N.gt.10:',n
        write(mw0,*)'Index error in SR.RADBP1'
        go to 1300
      ENDIF
!
! TYPE-1: P1*P2/X**2
!
  100 DO I=1,MAXRS
        DWRK1(I)=DPNL(I,K2)*DPNL(I,K4)/(DX(I)*DX(I))
      ENDDO
!
      IF(BREL2)THEN
        DO I=1,MAXRS
          DWRK1(I)=DWRK1(I)+DQNL(I,K2)*DQNL(I,K4)/(DX(I)*DX(I))
        ENDDO
      ENDIF
      GO TO 900
!
! TYPE-2: (P1/X)*P2'
!
  200 DO I=1,MAXRS
        DWRK2(I)=DPNL(I,K2)/DX(I)
        DWRK1(I)=DPNL(I,K4)
      ENDDO
      GO TO 500
!
! TYPE-3: P1*(P2/X)'
!
  300 DO I=1,MAXRS
        DWRK2(I)=DPNL(I,K2)
        DWRK1(I)=DPNL(I,K4)/DX(I)
      ENDDO
      GO TO 500
!
! TYPE-4: P1'*P2'
!
  400 if(igagr.gt.0.and.ql(k2).eq.ql(k4))then         !see radial/diagfs
!
        IN=ICOL(K4,K2,IZERO)
        DKU=D2LL(IN)
!        write(mw0,*)k2,k4,dku
        IF(QL(K2)+QL(K4).GT.0)THEN
          DO I=1,MAXRS
            DWRK1(I)=DPNL(I,K2)*DPNL(I,K4)/(DX(I)*DX(I))
          ENDDO
          CALL WEDDLE(DZERO,DWRK1,DKU0,MNH,DHNS,MJH,MAXRS)
          TL=QL(K2)*(QL(K2)+2)+QL(K4)*(QL(K4)+2)
          DKU=-DKU0*TL/8+DKU
          IF(QL(K2).NE.QL(K4))THEN                    !see radial/diagfs
            DS=DEY(K2)-DUY(IK2)
            DE=DEY(K4)-DUY(IK4)
            DO I=1,MAXRS
              DWRK1(I)=DPNL(I,K2)*DPNL(I,K4)
            ENDDO
            CALL WEDDLE(DZERO,DWRK1,OVL,MNH,DHNS,MJH,MAXRS)
            DKU=DKU+OVL*(DE+DS)
!            write(mw0,*)ds,de,k2,k4,ovl
          ENDIF
        ENDIF
!        write(mw0,*)k2,k4,dku,dku0
        GO TO 1100
      endif
!
      DO I=1,MAXRS
        DWRK3(I)=DPNL(I,K2)
        DWRK1(I)=DPNL(I,K4)
      ENDDO
!
      IF(QL(K2)+QL(K4).EQ.0)D00=DORIG(K2)*DORIG(K4)
!
      CALL DIFF(DWRK3,DWRK2,MNH,DHNS,MJH)
!
! ENTRY POINT FOR TYPES-2 AND-3
!
  500 CALL DIFF(DWRK1,DWRK3,MNH,DHNS,MJH)
!
      DO I=1,MAXRS
        DWRK1(I)=DWRK2(I)*DWRK3(I)
      ENDDO
      GO TO 900
!
! TYPES-5 & -8: P1*P2*X**2
!
  600 DO I=1,MAXRS
        DWRK1(I)=DPNL(I,K2)*DPNL(I,K4)*DX(I)*DX(I)
      ENDDO
!
      IF(BREL2)THEN
        DO I=1,MAXRS
          DWRK1(I)=DWRK1(I)+DQNL(I,K2)*DQNL(I,K4)*DX(I)*DX(I)
        ENDDO
      ENDIF
      GO TO 900
!
! TYPE-6: P1*P2
!
  700 IF(QL(K2).EQ.QL(K4))THEN
        DKU=DZERO
        IF(K2.EQ.K4)DKU=DONE
        GO TO 1100
      ELSE        !not allowed?
!       write(mw0,*)'rad:',k2,k4
        DO I=1,MAXRS
          DWRK1(I)=DPNL(I,K2)*DPNL(I,K4)
        ENDDO
!
        IF(BREL2)THEN
          DO I=1,MAXRS
            DWRK1(I)=DWRK1(I)+DQNL(I,K2)*DQNL(I,K4)
          ENDDO
        ENDIF
        GO TO 900
      ENDIF
!
! TYPE-7: P1*P2/X
!
  800 if(igagr.gt.0.and.ql(k2).eq.ql(k4))then         !see radial/diagfs
        n=5                                      !not actually used then
        go to 600
      endif
!
      DO I=1,MAXRS
        DWRK1(I)=DPNL(I,K2)*DPNL(I,K4)/DX(I)
      ENDDO
!
      IF(BREL2)THEN
        DO I=1,MAXRS
          DWRK1(I)=DWRK1(I)+DQNL(I,K2)*DQNL(I,K4)/DX(I)
        ENDDO
      ENDIF
!
! **********************************************
!
  900 CALL WEDDLE(D00,DWRK1,DKU,MNH,DHNS,MJH,MAXRS)
!
! **********************************************
!
      GO TO 1100
!
! TYPES-9 AND -10 (FOR 1-BODY M_K) P1*P2*X**(K-1) AND P1*P2*X**(K+1)
!
 1000 MGROUP=M00/2000                                !magnetic multipole
!
      if(n.eq.9)then
        ml=mgroup
      else                                           !n=10
        ml=mgroup+2
      endif
!
      IN=ICOL(K4,K2,IZERO)
!
      IF(BREL2)THEN
        TJ=-2/(DFSC*(ml+2))
        IF(qn(k2).eq.qn(k4).OR.irtard.eq.0.AND.ml.GT.1)THEN
          DO I=1,MAXRS
            DWRK1(I)=(DPNL(I,K2)*DQNL(I,K4)+DQNL(I,K2)*DPNL(I,K4))*DX(I)&
     &               **ml
          ENDDO
        ELSEIF(irtard.lt.0.OR.qn(k2).lt.0)THEN
          DEL=DEY(K2)-DUY(IK2)-DEY(K4)+DUY(IK4)  !A.U.
          TE=abs(DFSC*DEL)
          TJ=TJ*3/TE**ml
          DO I=2,ml
            TJ=TJ*(2*I+1)
          ENDDO
          DO I=1,MAXRS
            TZ=DX(I)*TE
            DWRK1(I)=DPNL(I,K2)*DQNL(I,K4)+DQNL(I,K2)*DPNL(I,K4)
            DWRK1(I)=DWRK1(I)*SBESS(ml,TZ,JSWTCH)
          ENDDO
        ELSE                                     !ml.eq.1.or.irtard.gt.0
          DEL=DEY(K2)-DUY(IK2)-DEY(K4)+DUY(IK4)  !A.U.
          TE=DFSC*DEL
          TE=TE*TE/(2*(2*ml+3))
          DO I=1,MAXRS
            DWRK1(I)=(DPNL(I,K2)*DQNL(I,K4)+DQNL(I,K2)*DPNL(I,K4))*DX(I)&
     &               **ml*(DONE-TE*DX(I)*DX(I))
          ENDDO
        ENDIF
!
        CALL WEDDLE(DZERO,DWRK1,DKU,MNH,DHNS,MJH,MAXRS)
!
        DKU=DKU*TJ
!
!test compare with e_k integral
!        if(ml.eq.1)then
!          ml1=ml+1
!          t=dosc(in,ml1/2)
!          del=dey(k2)-duy(ik2)-dey(k4)+duy(ik4)  !a.u.
!          te=dfsc*del
!          t=t*2*te*te/6
!        else
!          ml1=ml-1
!          t=dosc(in,ml1/2)
!        endif
!        write(mw0,*)'bess',n,ml,k2,k4,dku,t
!
      ELSE
        IF(ml.GT.1)THEN
          ml1=ml-1
          DKU=DOSC(IN,ml1/2)
!          write(mw0,*)'DOSC',k2,k4,ml1/2,dku
        ELSE
          IF(K2.EQ.K4)THEN
            DKU=DONE
          ELSE
            DKU=DZERO
          ENDIF
        ENDIF
      ENDIF
!
 1100 CONTINUE
!
      DK=DKU*CON(N)
!
!-----------------------------------------------------------------------
!
 1200 IF(ALLOCATED(DWRK1))DEALLOCATE(DWRK1,DWRK2,DWRK3)
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
 1300 M00=-1
      GO TO 1200
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE RADBP1
!
!                             *******************
!
      SUBROUTINE RADBP2(BPRNT0)
!
!-----------------------------------------------------------------------
!
!  SR.RADBP2 CALCULATES THE TWO-BODY M1+BP RADIATIVE INTEGRALS
!
!  IT IS CALLED BY:
!    SR.DIAGFS
!
!  IT CALLS:
!    SR.DIFF
!    SR.WEDDLE
!    SR.YLAMK
!    SR.YLAMKR
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DMQSS3, ONLY: QSS                                      &
     &                        ,NL000=>NL,NL=>NL000
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
      USE COMMON_RELINT, ONLY: DRLP1,DNL
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD
      USE COMMON_NRBAL2, ONLY: MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBINT, ONLY: DRLI,DYY,IYY,NRLI,MENG,NREL,NLAG,NLAGP   &
     &                        ,BLAG,BBC2
      USE COMMON_NRBOLP, ONLY: OVLPGR,OVLPCF,IPAIR
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBVAL, ONLY: FACT,IVAL,NNEW,NNOLD,BJUMP,BJUMP2,BRAD
      use common_nrbtmp, only: rnorm
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      CHARACTER(LEN=4) MBLK
!
      ALLOCATABLE :: DPA(:),DP(:)
!
      DATA MBLK/'    '/
!
!-----------------------------------------------------------------------
!
! THE NAMES HERE ARE NOT NECESSARILY SIGNIFICANT THEY ARE COMMON LEGACY.
!
! LOCAL
      ALLOCATE(DPA(MAXRS),DP(MAXRS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RADBP2: ALLOCATION FAILS FOR DPA,DP'
        NF=0
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
      NN=NL000+1
!
      IF(BPRNT0)THEN
        IF(NN.EQ.1)THEN
          WRITE(MW6,10020)
        ELSE
          WRITE(MW6,10030)MBLK
        ENDIF
      ENDIF
!
      BREL2=ABS(IREL).EQ.2
!
      IF(BJUMP)THEN                        !JUST SCALE EXISTING
        DO L=NN,NL
          M=0
          DD=DONE
          DO I=1,4
            N=QSS(I,L)
            M=M+IVAL(N)
            DD=DD*FACT(N)
          ENDDO
          IF(M.GT.0)THEN
            IF(.NOT.BJUMP2)DNL(L)=DZERO
            DNL(L)=DNL(L)*DD
          ENDIF
          IF(BJUMP2.AND.BPRNT0)WRITE(MW6,10010)L,(QSS(I,L),I=1,5),DNL(L)
        ENDDO
        IF(.NOT.BJUMP2)GO TO 100
        GO TO 300                                                !RETURN
      ENDIF
!
      DO L=NN,NL
        DNL(L)=DZERO
      ENDDO
!
  100 K=0
!
      DO J=NN,NL                     !START MAGNETIC TWO-BODY OUTER LOOP
!                                    !OVER INNER ORBITAL PAIR (YLAMK)
        IF(DNL(J).NE.DZERO)GO TO 200
!
        M=QSS(5,J)
        MM=(M+2)/100
        BAUX=MM.EQ.7
        BINT=MOD(MM,ITWO).EQ.0.OR.BAUX             !FALSE FOR 1,3,5
!
        M1=(M-100*MM)/2
        IF(M1.GT.MAXLAM)GO TO 200
!
        MJ0=0
        IF(MM.GT.4)THEN
          K=1
          MJ0=3
        else
          k=0
        ENDIF
!
        N1=QSS(K+1,J)
        N2=QSS(K+3,J)
        IF(MODE.LT.3)THEN
          IMT=0
          IF(IYY(N1).GT.0)IMT=IMT+1
          IF(IYY(N2).GT.0)IMT=IMT+1
          IF(IMT.GT.1)GO TO 200
        ENDIF
!
        M2=(QL(N1)+QL(N2))/2+2
        IF((MM+1)/2.EQ.2)THEN         !3,4
          M2=M2+1
          DO I=1,MAXRS
            DPA(I)=DPNL(I,N2)*DX(I)
          ENDDO
        ELSEIF(.NOT.BINT)THEN         !1,5
          DO I=1,MAXRS
            DPA(I)=DPNL(I,N2)/DX(I)
          ENDDO
        ELSE       !IF(MM.NE.4)THEN   !0,2,6,7
          DO I=1,MAXRS
            DPA(I)=DPNL(I,N2)*DPNL(I,N1)
          ENDDO
!        ELSE
!          DO I=1,MAXRS
!            DPA(I)=DPNL(I,N2)*DPNL(I,N1)/DX(I)
!          ENDDO
        ENDIF
!
        IF(.NOT.BINT)THEN
          IF(QL(N2).GT.0)M2=M2-1
!
          CALL DIFF(DPA,DP,MNH,DHNS,MJH)
!
          DO I=1,MAXRS
            DPA(I)=DPNL(I,N1)*DP(I)*DX(I)
          ENDDO
        ENDIF
!
        IF(BREL)THEN
          IN1=ICOL(N1,N1,IZERO)
          IN2=ICOL(N2,N2,IZERO)
          DE1=DEY(N1)-DUY(IN1)
          DE2=DEY(N2)-DUY(IN2)
          DEL=DE1-DE2                                   ! A.U.
          T=DALF4*DTWO
          DZ=NZION
          IF(BREL2)THEN
            DO I=1,MAXRS
              DD1=DONE+T*(DE1+DZ/DX(I))
              DD2=DONE+T*(DE2+DZ/DX(I))
!              DD1=DONE+T*(DE1+POT(I,1))
!              DD2=DONE+T*(DE2+POT(I,1))
              D12=DD1*DD2
              d12=abs(d12)
              DPA(I)=DPA(I)/SQRT(D12)
            ENDDO
          ELSE
            dd=rnorm(n1)*rnorm(n2)
            DO I=1,MAXRS
              DD1=DALF4*(DQNL(I,N1)/DPNL(I,N1)+DTWO*DZ/DX(I))
              IF(DD1.GT.-DONE)DD1=DONE+DD1         !HIGH-Z POINT NUCL.
              DD2=DALF4*(DQNL(I,N2)/DPNL(I,N2)+DTWO*DZ/DX(I))
              IF(DD2.GT.-DONE)DD2=DONE+DD2         !HIGH-Z POINT NUCL.
!              dd1=done+t*(de1+dz/dx(i))           !alt
!              dd2=done+t*(de2+dz/dx(i))           !alt
              D12=DD1*DD2
              d12=abs(d12)
              DPA(I)=DPA(I)*dd/SQRT(D12)
            ENDDO
          ENDIF
          CALL YLAMKR(M1,M2,DEL,DPA,DP,DD1,DD2,MNH,DHNS,MJH,MJ0)
        ELSE
          CALL YLAMK(M1,M2,DPA,DP,DD1,DD2,MNH,DHNS,MJH,MJ0)
        ENDIF
!
        KX=QSS(4-K,J)
        IF(MM.EQ.1.OR.MM.EQ.2)THEN
          WRITE(MW6,*)'RADBP2 ERROR: KX=',KX
          WRITE(MW0,*)'RADBP2 KX ERROR'
          NF=-1
          GO TO 300                                              !RETURN
        ELSEIF(MM.EQ.0)THEN
! SKIP
        ELSEIF(MM.EQ.3.OR.MM.EQ.4)THEN
          DO I=1,MAXRS
            DP(I)=DP(I)/DX(I)
          ENDDO
        ELSEIF(MM.EQ.6)THEN
          DO I=1,MAXRS
            DP(I)=DP(I)*DX(I)*DX(I)
          ENDDO
        ELSE                     !MM=5,7
          IF(BAUX)THEN           !MM=7 ONLY
            DO I=1,MAXRS
              DPA(I)=-DPNL(I,KX)*DP(I)*DX(I)**4
            ENDDO
          ENDIF
          DO I=1,MAXRS
            DP(I)=DP(I)*DX(I)**3
          ENDDO
        ENDIF
!
        IF(BAUX)CALL DIFF(DPA,DP,MNH,DHNS,MJH)
!
        DO L=J,NL                             !START INNER MAGNETIC LOOP
!                                             !OVER OUTER ORBITAL PAIR
          IF(QSS(5,L).NE.M)GO TO 150
          IF(QSS(K+1,L).NE.N1.OR.QSS(K+3,L).NE.N2)GO TO 150
          IF(BAUX.AND.QSS(4-K,L).NE.KX)GO TO 150
!
          L1=QSS(2-K,L)
          L2=QSS(4-K,L)
          JMT=0
          IF(MODE.LT.3)THEN
            IF(IYY(L1).GT.0)JMT=JMT+1
            IF(IYY(L2).GT.0)JMT=JMT+1
            IF(IMT+JMT.GT.1)GO TO 150
          ENDIF
!
          IF(BAUX)THEN
            DO I=1,MAXRS
              DPA(I)=DPNL(I,L1)*DP(I)/DX(I)
            ENDDO
          ELSE
            DO I=1,MAXRS
              DPA(I)=DPNL(I,L1)*DP(I)*DPNL(I,L2)
            ENDDO
          ENDIF
!
          IF(BREL)THEN
            IL1=ICOL(L1,L1,IZERO)
            IL2=ICOL(L2,L2,IZERO)
            DE1=DEY(L1)-DUY(IL1)
            DE2=DEY(L2)-DUY(IL2)
!            DEL=DE1-DE2                                   ! A.U.
            T=DALF4*DTWO
            DZ=NZION
            IF(BREL2)THEN
              DO I=1,MAXRS
                DD1=DONE+T*(DE1+DZ/DX(I))
                DD2=DONE+T*(DE2+DZ/DX(I))
!                DD1=DONE+T*(DE1+POT(I,1))
!                DD2=DONE+T*(DE2+POT(I,1))
                D12=DD1*DD2
                d12=abs(d12)
                DPA(I)=DPA(I)/SQRT(D12)
              ENDDO
            ELSE
              dd=rnorm(l1)*rnorm(l2)
              DO I=1,MAXRS
                DD1=DALF4*(DQNL(I,L1)/DPNL(I,L1)+DTWO*DZ/DX(I))
                IF(DD1.GT.-DONE)DD1=DONE+DD1         !HIGH-Z POINT NUCL.
                DD2=DALF4*(DQNL(I,L2)/DPNL(I,L2)+DTWO*DZ/DX(I))
                IF(DD2.GT.-DONE)DD2=DONE+DD2         !HIGH-Z POINT NUCL.
!                dd1=done+t*(de1+dz/dx(i))           !alt
!                dd2=done+t*(de2+dz/dx(i))           !alt
                D12=DD1*DD2
                d12=abs(d12)
                DPA(I)=DPA(I)*dd/SQRT(D12)
              ENDDO
            ENDIF
          ENDIF
!
          CALL WEDDLE(DZERO,DPA,DD,MNH,DHNS,MJH,MAXRS)
!
          OVL=DONE
          IF(IRLX.EQ.2)THEN        !OVERLAPS
            KF=IGRCF(N1)
            KG=IGRCF(N2)
            IF(KG.EQ.0)KG=IGRCF(L1)
            IF(KF.NE.KG.AND.KG.GT.0)THEN
              K1=MIN(KF,KG)
              K2=MAX(KF,KG)
              KK=((K2-1)*(K2-2))/2+K1
              OVL=OVLPCF(KK)
              IF(IPAIR(KK).EQ.1)THEN
                                    !SURELY THIS CAN BE SIMPLIFIED...
                IF(IEQ(N1).EQ.IEQ(N2))THEN
                  K1=MIN(N1,N2)
                  K2=MAX(N1,N2)
                ELSEIF(IEQ(L1).EQ.IEQ(L2))THEN
                  IF(IGRCF(L1).EQ.0)GO TO 120
                  K1=MIN(L1,L2)
                  K2=MAX(L1,L2)
                ELSEIF(KF.NE.IGRCF(L1))THEN
                  IF(IEQ(N1).EQ.IEQ(L1))THEN
                    K1=MIN(N1,L1)
                    K2=MAX(N1,L1)
                  ELSEIF(IEQ(L2).EQ.IEQ(N2))THEN
                    IF(IGRCF(L2).EQ.0)GO TO 120
                    K1=MIN(L2,N2)
                    K2=MAX(L2,N2)
                  else
                    write(mw6,*)'radbp2: why are we here?',kf,kg,n1,l1, &
     &                          n2,l2
                    write(mw0,*)'radbp2: why are we here?'
                    nf=-1
                    go to 300                                    !return
                  ENDIF
                ELSE
                  IF(IEQ(N1).EQ.IEQ(L2))THEN
                    K1=MIN(N1,L2)
                    K2=MAX(N1,L2)
                  ELSEIF(IEQ(L1).EQ.IEQ(N2))THEN
                    K1=MIN(L1,N2)
                    K2=MAX(L1,N2)
                  else
                    write(mw6,*)'radbp2: why are we here?',kf,kg,n1,l1, &
     &                          n2,l2
                    write(mw0,*)'radbp2: why are we here?'
                    nf=-1
                    go to 300                                    !return
                  ENDIF
                ENDIF
                KK=((K2-1)*(K2-2))/2+K1
                OVL=OVL/OVLPGR(KK)
              ENDIF
            ENDIF
          ENDIF
!
  120     DNL(L)=DD*DALF4*OVL
!
  150   ENDDO                                            !END INNER LOOP
!
  200   IF(BPRNT0)WRITE(MW6,10010)J,(QSS(I,J),I=1,5),DNL(J)
!
      ENDDO                                              !END OUTER LOOP
!
!-----------------------------------------------------------------------
!
  300 CONTINUE
!
! LOCAL
      DEALLOCATE(DPA,DP,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RADBP2: DE-ALLOCATION FAILS FOR DPA,DP'
        IF(NF.GT.0)NF=0
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(I5,3X,2(I5,I4),I6,F14.8)
10020 FORMAT(//5X,"N&V(   A   B    C   D  2LBD') = MAGNETIC INTEGRALS")
10030 FORMAT(A4,26X,4I4,2X,7F9.4)
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE RADBP2
!
!                             *******************
!
      SUBROUTINE RADCN0(MYMO,MYNO,MPO,DHNSX)
!
!-----------------------------------------------------------------------
!
!  SR.RADCN0 READS USER INPUT FOR RADCON BRANCH AND SETS-UP AN
!  ENERGY MESH ACCORDINGLY.
!
!  IT IS CALLED BY:
!    SR.MINIM
!    SR.RADCON
!
!  IT CALLS:
!    SR.DIMUSE
!    SR.RE_ALLOC
!    FN.TQDT
!
!-----------------------------------------------------------------------
!
      USE COMMON_ALGEB,  ONLY: BFOT
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_CMESH,  ONLY: MHF,MRAD,MSTEP,IXTRA,xmax
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR
      USE COMMON_MINIM,  ONLY: ECOR1,ECOR2,ECORR,ECORRJ,ESKPL,ESKPH     &
     &                        ,BECOR
      USE COMMON_MISC,   ONLY: NF0,BNAME
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
!                              DRLI,    IYY,NRLI,
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,VSC,XC1,XC2,NPITER
      USE COMMON_NRBDR,  ONLY: IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR
      USE COMMON_NRBDR,  ONLY: LNEW,LCON,LSUM,LMAX,lcmin,BLOOP
      USE COMMON_NRBINT, ONLY:      DYY,         MENG,NREL,NLAG,NLAGP   &
     &                        ,BLAG,BBC2
      USE COMMON_NRBPOT, ONLY: CPOT,XPOT,IPOT,NPOT
      USE COMMON_NRBSHF, ONLY: DSHIFT,MSHIFT,KSHIFT,MKMAX,MXEP
      USE COMMON_NRBTAR, ONLY: ETAR,ISTAR,LTAR,JTAR,NTAR,IGAPE
      USE COMMON_NRBTS1, ONLY: PMIN,IPIG,IGAG
      USE COMMON_NRBVAL, ONLY: FACT,IVAL,NNEW,NNOLD,BJUMP,BJUMP2,BRAD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (MXTABF=41)        !NO OF FINE PRE-TAB'D ENERGIES FOR PI
      PARAMETER (MXTABC=25)      !NO OF COARSE PRE-TAB'D ENERGIES FOR PI
      PARAMETER (MXFOTE=2*MXTABF)          !BUFFER SPACE FOR PI ENERGIES
!
      CHARACTER(LEN=3) PIG
!
      LOGICAL BEX                         !INQUIRE REQUIRES DEFAULT KIND
!
      DIMENSION EFOT(MXFOTE),EDUMF(MXTABF),EDUMC(MXTABC)
!
      SAVE MYM,MYN,MP
!MOD      SAVE MOD,MDUM
!
!-----------------------------------------------------------------------
!
      NAMELIST/SRADCON/                                                 &
     & ACE,                                                             &
     & DLAMX,DLAMDX,DLAMQX,SCALERX,MCFSTOX,                             &
     & ECOR1,ECOR2,ECORCA,ECORIC,ECORLS,EMIN,EMAX,MIONQ,                &
     & KSHIFT,MKMAX,MXEP,                                               &
     & MDECP,MENG,MENGP,MP,MYN,MYM,                                     &
     & NLAG,NREL,NLAGP,                                                 &
     & NPOT,                                                            &
     & PIG,PMIN,                                                        &
     & DELTAX,DEMIN,DEMAX,NDE,NIDX,                                     &
     & EMINI,EMAXI,MENGI,                                               &
     & TEAPOT,TOLDE                                                     &
     &,ilog,nbund,nskpi,tolp,bnointerp
!MOD    X  ,MOD,MDUM
!
! NOT ALL VARIABLES USED BY RADCN0, BUT PRESENT FOR RADCX0 COMPATIBILITY
!
! VIZ.    DLAMX,DLAMDX,DLAMQX,SCALERX,MCFSTOX,
!         DELTAX,DEMIN,DEMAX,NDE,NIDX,
!         TEAPOT,TOLDE
!         ilog,nbund,nskpi,tolp,bnointerp
!
!-----------------------------------------------------------------------
!
! DEFAULT MESH MXTABC=25
!
      DATA EDUMC                                                        &
     &    /0.0E+0_WP,2.1E-6_WP,4.6E-6_WP,1.0E-5_WP,2.1E-5_WP,4.6E-5_WP, &
     &     1.0E-4_WP,2.1E-4_WP,4.6E-4_WP,1.0E-3_WP,2.1E-3_WP,4.6E-3_WP, &
     &     1.0E-2_WP,2.1E-2_WP,4.6E-2_WP,1.0E-1_WP,2.1E-1_WP,4.6E-1_WP, &
     &     1.0E+0_WP,2.1E+0_WP,4.6E+0_WP,1.0E+1_WP,2.1E+1_WP,4.6E+1_WP, &
     &     1.0E+2_WP/
!
! TEST FINE MESH MXTABF=41 (OR 45)
!
      DATA EDUMF/0.0E+0_WP,1.6E-6_WP,2.5E-6_WP,4.0E-6_WP,6.3E-6_WP,     &
     &           1.0E-5_WP,1.6E-5_WP,2.5E-5_WP,4.0E-5_WP,6.3E-5_WP,     &
     &           1.0E-4_WP,1.6E-4_WP,2.5E-4_WP,4.0E-4_WP,6.3E-4_WP,     &
     &           1.0E-3_WP,1.6E-3_WP,2.5E-3_WP,4.0E-3_WP,6.3E-3_WP,     &
     &           1.0E-2_WP,1.6E-2_WP,2.5E-2_WP,4.0E-2_WP,6.3E-2_WP,     &
     &           1.0E-1_WP,1.6E-1_WP,2.5E-1_WP,4.0E-1_WP,6.3E-1_WP,     &
     &           1.0E+0_WP,1.6E+0_WP,2.5E+0_WP,4.0E+0_WP,6.3E+0_WP,     &
     &           1.0E+1_WP,1.6E+1_WP,2.5E+1_WP,4.0E+1_WP,6.3E+1_WP,     &
     &           1.0E+2_WP/
!     &                    ,1.6E+2_WP,2.5E+2_WP,4.0E+2_WP,6.3E+2/
!
! EDUMC/F ARE Z-SCALED RYD.
!
!-----------------------------------------------------------------------
!
      PI=ACOS(-DONE)
!
      IF(DHNSX.GT.DZERO)GO TO 800                !AS ALREADY READ/SET-UP
!
      IXENG=MAX(MXENG,1000_SP)                   !INITIAL BUFFER
!
      ALLOCATE(DYY(IXENG),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RADCN0: ALLOCATION FAILS FOR DYY'
        NF=0
        GO TO 900
      ENDIF
!
! PRELIMINARY INITIALIZATIONS
!
      BDR=IDR.NE.0
!
      MION1=NW+NF                !TOTAL NUMBER OF ELECTRONS (=MION+MRED)
      NZA=MAX(NZION-MION1+1,IONE)
!      DZ=NZION
      DZA=MION1-NZION-1
      DZA2=NZA*NZA                   !=DZA*DZA EXCEPT CASE DZA=0, THEN 1
      TQD=DZERO
!
! NAMELIST INITIALIZATIONS
!
! ********** ALL INPUT ENERGIES MUST BE IN RYDBERGS ***********
!
      NPOT=0                              !R-MATRIX PARAMETRIC POTENTIAL
!
      MIONQ=44                                       !MAX MION1 FOR BTWO
      DYY(1)=DZERO
      EMIN=-1
      EMAX=-2
      EMINI=EMIN                                     !ALTERNATE
      EMAXI=EMAX                                     !ALTERNATE
      IF(BFOT)THEN                                   !OLD DEFAULT
        IPIG=1                                       !LENGTH
        PMIN=-DONE
      ENDIF
!
      ECOR1=DZERO
      ECOR2=DZERO
      ECORCA=DZERO
      ECORLS=DZERO
      ECORIC=DZERO
      MENG=-1984
      MENGI=-999
      MENGP=0
      NREL=0
      ACE=DZERO
      MYN=0
      MYM=0
      MP=0
      NLAG=-1
      NLAGP=-1
      PIG='   '                                      !NEW DEFAULT
      PMIN=D1M24                                     !VARIABLE GAUGE
      MDECP=0
      KSHIFT=-999              !<0 FOR DOWN,>0 FOR UP,=0 MIXED RYD SCALE
      MKMAX=-999               !MAX PI MULTIPOLE FOR DOWNSCALING
      MXEP=-1                  !SWITCH-OVER FROM DOWN TO UP, KSHIFT=0
!
!MOD    MDUM=0
!MOD    MOD=0
!
      IF(BNAME)THEN
!
        REWIND(MR5)                    !CASE USER NAMELISTS OUT OF ORDER
!
        READ(MR5,SRADCON,END=1000,ERR=1000)   ! <-------------- NAMELIST
!
        PIG=STRUPCASE(PIG)
!
        IF(EMIN.LT.DZERO)EMIN=EMINI
        IF(EMAX.LT.DZERO)EMAX=EMAXI
!
      ELSE                                        !HISTORIC FIXED FORMAT
!
        READ(MR5,10040)ECOR1,ECOR2,MENG,NREL,ACE,MYN,MYM,MP
!MOD     X,MDUM,MOD                               !COULD ADD/ADJUST
!
      ENDIF
!
      IF(MENG.EQ.-1984)MENG=MAX(MENGI,IZERO)
!
      IF(BDR.AND.KSHIFT.EQ.-999)KSHIFT=0
      IF(KSHIFT.GT.0)MKMAX=0                     !SAVE USER JOE..
!
      BZSCLE=MENGP.NE.0
!
      IF(BFOT)THEN
!
        IF(BZSCLE)THEN
          IF(MENG.NE.0)THEN
            WRITE(MW6,*)' *** SR.RADCN0: MENGP.NE.0 OVERRIDES MENG...'
            WRITE(MW0,*)' *** SR.RADCN0: MENGP.NE.0 OVERRIDES MENG...'
          ENDIF
          MENG=MENGP
        ENDIF
!
        IF(MKMAX.LT.0)THEN     !SET MAX K-POLE FOR DOWNSCALING FROM CONT
          IF(KSHIFT.EQ.0)THEN                    !DOWN TO MKMAX, THEN UP
            MKMAX=1
          ELSEIF(KSHIFT.LT.0)THEN                        !ALL DOWNSCALED
            MKMAX=999
          ELSE                                             !ALL UPSCALED
            MKMAX=0
          ENDIF
        ENDIF
!
        IF(PMIN.LE.DZERO.OR.PIG.NE.'   '.AND.PIG.NE.'VAR')THEN
                                                     !USE FIXED PI GAUGE
          PMIN=-DONE
          IF(PIG.EQ.'LEN')THEN
            IPIG=1
          ELSEIF(PIG.EQ.'VEL')THEN
            IPIG=0
          ELSEIF(PIG.EQ.'ACC')THEN
            IPIG=-2
          ELSE
            WRITE(MW0,10090)PIG
            WRITE(MW6,10090)PIG
            NF=-1
            GO TO 900
          ENDIF
        ELSE                                      !USE VARIABLE PI GAUGE
          PMIN=D1P18*PMIN/DZA2
        ENDIF
!
        IF(MENG.LE.-10000)THEN
          MDECP=MAX(MDECP,-MENG/10000,7_SP)
          MENG=-10000
        ENDIF
        IF(MENG.LE.-1000.OR.MENG.EQ.0)THEN
          IF(MDECP.GT.3)THEN
            MENG=-10000
          ELSE
            IF(MENG.NE.0)MENG=-1000
          ENDIF
        ENDIF
!
      ELSE
!
        IF(BZSCLE)THEN
          WRITE(MW6,*)                                                  &
     &         ' *** SR.RADCN0: MENGP.NE.0 FLAGS Z-SCALED MENG ENERGIES'
          WRITE(MW0,*)                                                  &
     &         ' *** SR.RADCN0: MENGP.NE.0 FLAGS Z-SCALED MENG ENERGIES'
        ENDIF
!
      ENDIF
!
      IF(BFOT)THEN
        NLAG0=2
      ELSE
        NLAG0=4
      ENDIF
      ISGN=1-2*mod(abs(NLAG),ITWO)              !(-1)**NLAG
      IF(NLAG.LT.NLAG0.OR.NLAG.GT.10.OR.ISGN.LT.0)THEN
        IF(NSL0.LT.0)THEN                     !CA INTERP MORE INACCURATE
          NLAG=4
        ELSE
          NLAG=6
        ENDIF
      ENDIF
      ISGNP=1-2*mod(abs(NLAGP),ITWO)             !(-1)**NLAGP
      IF(NLAGP.LT.NLAG0.OR.NLAGP.GT.10.OR.ISGNP.LT.0)NLAGP=NLAG
      IF(.NOT.BFOT.AND.MENG.EQ.0)MENG=-2*NLAG
!
      IF(ECORCA.NE.DZERO)ECOR1=ECORCA
      IF(ECORLS.NE.DZERO)ECOR1=ECORLS
      IF(ECORIC.NE.DZERO)ECOR2=ECORIC
!
!
!MOD      IF(MOD.GT.0)MODE=MOD
!
! CORRECTION TO ABSOLUTE POSITION OF CONTINUUM (MODE=2) IN DIAGON AND
! DELEN APPLIES RELATIVE TERM CORRECTION TO TARGET (SEE SR.MINIM) IN AU.
!
      ECOR1=ECOR1/DTWO                                      !RYD TO A.U.
      ECOR2=ECOR2/DTWO                                      !RYD TO A.U.
      IF(ABS(ECOR1).GT.D1P2)ECOR1=ECOR1/DKCM
      IF(ABS(ECOR2).GT.D1P2)ECOR2=ECOR2/DKCM
!
      IF(MODE.LT.1.OR.MODE.GT.4)THEN
        WRITE(MW6,10050)MODE
        NF=-1
      ENDIF
!
! MYN, MYM CONTROL PRINT OPTION FOR ORBITALS ]MYN] TO MYM.
! MYN .LT.-10 CHECKS ORTHOGONALITY OF SUPPOSEDLY ORTHOG ORBITALS
! AND PRINTS OUT DETAILS OF CONTINUUM ORBITALS AT EACH ENERGY.
!
      IF(MYN.EQ.0)MYN=1
      IF(MYM.EQ.0)MYM=-1
!
      IF(ACE.LT.D1M10)ACE=D1P9               !CAN RESTRICT EXTRAPOLATION
      ACE=ACE/DTWO                                          !RYD TO A.U.
!
! SAME MENG INTERPOLATION POINTS ARE USED IN DIAGON AND DIAGFS.
!
      MRDE=MENG
      MRDE0=mod(MRDE,I1000)
      IF(MRDE.LT.0)MENG=-MIN(-NLAG,MRDE0)
!
      CALL DIMUSE('MXENG',MENG)
!
      IF(MENG.GT.IXENG)THEN    !INITIAL BUFFER TOO SMALL - SHOULD NOT BE
        WRITE(MW6,10020)IXENG,MENG
        WRITE(MW0,*)                                                    &
     &            '***NUMBER OF INTERPOLATION ENERGIES HAS BEEN REDUCED'
        WRITE(MW0,*)                                                    &
     &            '***INCREASE IXENG BUFFER TO RETAIN ALL, CONTINUING..'
        MENG=IXENG
      ENDIF
!
      IF(MRDE.GT.0)GO TO 500
!
!
      IF(MRDE0.LT.0.AND.EMAX.LT.EMIN)THEN
!
        READ(MR5,*,END=100,ERR=100)EMIN0,EMAX0
!
        EMIN=EMIN0
        EMAX=EMAX0
!
      ENDIF
!
      IF(EMAX.GT.EMIN.AND.EMIN.LT.DZERO)EMIN=DZERO           !ALLOW EMAX
!
      IF(BZSCLE)THEN
        EMIN=EMIN*DZA2
        EMAX=EMAX*DZA2
      ENDIF
!
  100 IF(NF.LE.0)GO TO 900
!
      BBC2=.FALSE.
!
!
! MENG.LE.0   : USE INTERNAL ENERGIES FOR "PHOTOIONIZATION" (PREFERABLY)
!               REALLY INTENDED FOR RADIATIVE RECOMBINATION RATE COEFFS.
!               CRUDE FOR INTERPOLATION OF PARTIAL PI TO DELIVER TOTALS.
!
!     .EQ.     0 USES COARSE DEFAULT ENERGY MESH
!     .EQ. -1000 USES FINE DEFAULT ENERGY MESH
!     .EQ.-10000 USES MAX(MDECP,-MEMG/10000,7) POINTS PER ENERGY DECADE
!                OVER EMIN, EMAX
!
      IF(BFOT.AND.MRDE0.eq.0)THEN
        EMIN=EMIN/DZA2                        !PI ONLY
        EMAX=EMAX/DZA2
        MFOT=MXFOTE
        IF(MRDE.GT.-1000)THEN                 !USE COARSE PI ENERGY MESH
          IF(MFOT.LT.MXTABC)THEN
            T=EDUMC(MFOT)*DZA2
            WRITE(MW6,10030)T,MXTABC
          ELSE
            MFOT=MXTABC
          ENDIF
          DO I=1,MFOT
            EFOT(I)=EDUMC(I)
          ENDDO
        ELSEIF(MRDE.GT.-10000)THEN              !USE FINE PI ENERGY MESH
          IF(MFOT.LT.MXTABF)THEN
            T=EDUMF(MFOT)*DZA2
            WRITE(MW6,10030)T,MXTABF
          ELSE
            MFOT=MXTABF
          ENDIF
          DO I=1,MFOT
            EFOT(I)=EDUMF(I)
          ENDDO
        ELSE
          DT=DONE/MDECP
          IF(EMIN.GT.DZERO)THEN
            EFOT(1)=EMIN
            T=LOG10(EMIN)
          ELSE
            IF(EMAX.GT.DZERO)THEN
              TT=LOG10(EMAX)
              T=TT-(MXFOTE/2-1)*DT                    !MXENG -> MXFOTE/2
            ELSE
              T=-DSIX
            ENDIF
            EFOT(1)=DZERO
          ENDIF
          IF(EMAX.GT.DZERO)THEN
            TT=LOG10(EMAX)
            TT=(TT-T)/DT
            M=INT(TT,SP)
            MFOT=MIN(M+2,MFOT)
          ENDIF
          DO I=2,MFOT
            T=T+DT
            EFOT(I)=DTEN**T
          ENDDO
        ENDIF
!
        IF(EMIN.GT.DZERO.AND.EMAX.LT.DZERO)EMAX=EFOT(MFOT)   !ALLOW EMIN
!
!        MFOT=MAX(MRDE0,-MFOT)          !RESTRICTION NOT IMPOSED
!
        I0=1
        I1=MFOT
        IF(EMAX.GT.EMIN.AND.EMIN.GE.DZERO)THEN
          DO I=1,MFOT
            IF(EFOT(I).LE.EMIN)I0=I
            IF(EFOT(I).LT.EMAX)I1=I+1
          ENDDO
          IF(I1.GT.MFOT)THEN
            IF(EFOT(MFOT).LT.EMAX*D0PT9)THEN         !CATCH EXTREME CASE
              WRITE(MW6,10100)EFOT(MFOT)*DZA2
              WRITE(MW0,*)'***SR.RADCN0:EMAX TOO LARGE FOR BUFFER IXENG'
              NF=-1
              GO TO 900
            ELSE                               !CLOSE ENOUGH
              I1=MFOT
            ENDIF
          ENDIF
        ENDIF
        MFOT=I1-I0+1
!
        CALL DIMUSE('MXENG',MFOT)
!
        IF(MFOT.GT.IXENG)THEN             !SHOULD NOT HAPPEN NOW
          I1=I0+IXENG-1
          T=EFOT(I1)*DZA2
          WRITE(MW6,10030)T,MFOT
          WRITE(MW0,*)                                                  &
     &    '*** WARNING SR.RADCN0: INTERNAL PI ENERGY MESH TRUNCATED ***'
        ENDIF
!
        M=0
        DO I=I0,I1
          M=M+1
          DYY(M)=EFOT(I)*DZA2
        ENDDO
        MENG=M
        GO TO 700
      ENDIF
!
! SET-UP INTERPOLATION ENERGIES FOR AUTOIONIZATION (PREFERABLY).
!
      IF(MENG.EQ.0)THEN
        WRITE(MW6,10080)
        WRITE(MW0,*)                                                    &
     &            '***ERROR, MUST SPECIFY NON-ZERO MENG ENERGIES FOR DR'
        NF=-1
        GO TO 900
      ENDIF
!
      BTWO=.FALSE.
      IF(EMAX.LT.DZERO.OR.EMIN.LT.DZERO)THEN           !GET TARGET INFO
        IF(NJO.LE.0)THEN
          IF(NSL0.LT.0)THEN                                    !CA
            INQUIRE(FILE='CAVES',EXIST=BEX)
            IF(.NOT.BEX)GO TO 400
            ITAR=IAXCF
          ELSE                                                 !LS
            INQUIRE(FILE='TERMS',EXIST=BEX)
            IF(.NOT.BEX)GO TO 400
            ITAR=IAXTM
          ENDIF
          IRDE=MRW14
        ELSE                                                   !IC
          INQUIRE(FILE='LEVELS',EXIST=BEX)
          IF(.NOT.BEX)GO TO 400
          ITAR=IAXLV
          IRDE=MRW15
        ENDIF
!
        IUNIT(IRDE)=1
!
! EX-COMMON/NRBTAR/ - CURRENTLY, LOCAL
        ALLOCATE(ETAR(ITAR),ISTAR(ITAR),LTAR(ITAR),JTAR(ITAR),STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'RADCN0: ALLOCATION FAILS FOR ETAR ETC'
          NF=0
          GO TO 900
        ENDIF
!
        IF(NJO.LE.0)THEN
          IF(NSL0.LT.0)THEN                                    !CA
            OPEN(IRDE,FILE='CAVES',STATUS='OLD')
            READ(IRDE,*,END=400)
            DO I=1,ITAR
              READ(IRDE,10160,END=150)ISTAR(I),IP,ICF,ETAR(I)  !*->990
              IF(ICF.EQ.0)GO TO 150
              LTAR(I)=0                      !SO W=ISTAR*(2LTAR+1) AS LS
              ISTAR(I)=(1-2*MOD(IP,ITWO))*ISTAR(I)
              EMXX=ETAR(I)
            ENDDO
            WRITE(MW6,*)'**ERROR: TOO MANY CFGS, INCREASE BUFFER IAXCF'
            WRITE(MW0,*)'**ERROR: TOO MANY CFGS, INCREASE BUFFER IAXCF'
            NF=-1
            GO TO 900
          ELSE                                                 !LS
            OPEN(IRDE,FILE='TERMS',STATUS='OLD')
            READ(IRDE,*,END=400)
            DO I=1,IAXTM                                       !*->991
              READ(IRDE,10170,END=150)ISTAR(I),LTAR(I),IP,ICF,NDUM,     &
     &                                ETAR(I)
              IF(ICF.EQ.0)GO TO 150
              ISTAR(I)=(1-2*MOD(IP,ITWO))*ISTAR(I)
              EMXX=ETAR(I)
            ENDDO
            WRITE(MW6,*)'**ERROR: TOO MANY TERMS, INCREASE BUFFER IAXTM'
            WRITE(MW0,*)'**ERROR: TOO MANY TERMS, INCREASE BUFFER IAXTM'
            NF=-1
            GO TO 900
          ENDIF
        ELSE                                                   !IC
          OPEN(IRDE,FILE='LEVELS',STATUS='OLD')
          READ(IRDE,*,END=400)
          DO I=1,IAXLV                                         !*->992
            READ(IRDE,10180,END=150)JTAR(I),IP,ISTAR(I),LTAR(I),ICF,    &
     &                              NDUM,ETAR(I)
            IF(ICF.EQ.0)GO TO 150
            EMXX=ETAR(I)
          ENDDO
          WRITE(MW6,*)'**ERROR: TOO MANY LEVELS, INCREASE BUFFER IAXLV'
          WRITE(MW0,*)'**ERROR: TOO MANY LEVELS, INCREASE BUFFER IAXLV'
          NF=-1
          GO TO 900
        ENDIF
!
! DETERMINE ENERGY RANGE(S) FOR AUTOIONIZATION
!
  150   NTAR=I-1
        IF(NTAR.LT.2)GO TO 400
!
        CLOSE(IRDE)
        IUNIT(IRDE)=-1
!
        IF(BDR)THEN             !FIRST CHECK FOR ANY CORE RE-ARRANGEMENT
          DO K=1,KMAX
            M=QCG(NF,K)
            IF(QN(M).GE.90)THEN          !CONT: NORMALLY N=99 FOR   "  "
              M=QCG(NF-1,K)
              IF(IVAL(M).GT.0)THEN                              !RYDBERG
                IF(EMIN.LT.DZERO)EMIN=DZERO
                IF(EMAX.LT.DZERO)EMAX=EMXX
                GO TO 200                                   !WE ARE DONE
              ENDIF
            ENDIF
          ENDDO
        ENDIF
!
        IF(MION1-1.GT.MIONQ)THEN             !TOO MANY ELEC FOR BTWO=.T.
          IF(EMIN.LT.DZERO)EMIN=DZERO
          IF(EMAX.LT.DZERO)EMAX=EMXX
        ENDIF
!
  200   IGAPE=0
!
        IF(EMAX.LT.DZERO.AND.EMIN.LE.DZERO.AND.MENG.GE.2*NLAG)THEN !TWO,
          DE=DZERO                                               ! MAYBE
          IE=0
          DO I=2,NTAR
            IF(ETAR(I)-ETAR(I-1).GT.DE)THEN
              IE=I
              DE=ETAR(I)-ETAR(I-1)
            ENDIF
          ENDDO                     !2*
          BTWO=IE.GT.2.AND.DE.GT.D1PT5*(ETAR(NTAR)-ETAR(IE)).AND.       &
     &         DE.GT.2*ETAR(IE-1)                              !how big?
          if(btwo.and.emin.eq.dzero)emin=-d1m10
        ELSE                                                        !ONE
          BTWO=.FALSE.
        ENDIF
        IF(EMAX.LT.DZERO)THEN
          IF(BDR)THEN
            NXX=NMAX
            IF(JND.GT.0)NXX=NDR(JND)
          ELSE
            NXX=NNEW
          ENDIF
          TN=DZA/NXX
          TN=TN*TN
          EMXX=EMXX-TN
          EMXX=EMXX*D1PT05
          IF(EMXX.LE.DZERO)THEN
            WRITE(MW6,*)                                                &
     &         '*** SR.RADCN0 WARNING: CHECK/SET INTERPOLATION ENERGIES'
            WRITE(MW6,*)                                                &
     &          '*** PROBABLE INACCURACY, OR NO AUTOIONIZATION POSSIBLE'
            WRITE(MW0,*)                                                &
     &         '*** SR.RADCN0 WARNING: CHECK/SET INTERPOLATION ENERGIES'
            WRITE(MW0,*)                                                &
     &          '*** PROBABLE INACCURACY, OR NO AUTOIONIZATION POSSIBLE'
            EMXX=-TN
            IF(NXX.GT.1)TN=DZA/(NXX-1)
            TN=TN*TN
            EMXX=EMXX+TN
            EMXX=EMXX*D0PT85
          ENDIF
          EMAX=EMXX
        ENDIF
        IF(EMIN.LT.DZERO)THEN
          NEQ=0
          IF(LNEW.LT.0)THEN
            IF(NNEW.EQ.2)NEQ=MION1-2
            IF(NNEW.EQ.3)NEQ=MION1-10
            IF(NNEW.EQ.4)NEQ=MION1-28
            IF(NEQ.LT.0)NEQ=0
          ENDIF
          DZM=DZA-NEQ
          DUM=TQDT(TQD,NZION,MION1-NEQ,NNEW,MAX(IZERO,LNEW))
!          write(mw0,*)'qd=',tqd
          N00=0
          IF(MB.EQ.0.AND.MION1.GT.10)N00=2                          !MB0
          IF(MB.LE.1.AND.MION1.GT.28)N00=3                          !MB0
          IF(N00.EQ.0)THEN
            IF(BDR)THEN
              N00=NMIN
            ELSE
              n00=0
              if(mb.gt.0)n00=qn(mb)
              N00=min(n00+2,NNEW)      !case promo all n, mb+1,+2,..nnew
            ENDIF
          ENDIF
          IF(BTWO)THEN
            TM=DZM/(N00-TQD)
            TM=TM*TM
            EMAX2=EMAX
            EMIN=ETAR(IE)-ETAR(IE-1)-TM
            EMAX1=MAX(ETAR(IE-1),ETAR(NTAR)-ETAR(IE))
            EMAX1=EMAX1-TN
            IF(EMAX1.LT.D1M2*DZA2)EMAX1=D1M2*DZA2
            EMAX1=EMAX1*D1PT05
            EMIN1=DZERO
          ELSE
            IF(BDR)THEN
              NLOOP=NMAX
              IF(JND.GT.0)NLOOP=NLOOP+JND
            ELSE
              NLOOP=NNEW               !N00->NNEW now N00.le.NNEW
            ENDIF
            EMIN=EMAX/D1PT05
            DO N=N00,NLOOP
              NXX=N
              IF(BDR.AND.N.GT.NMAX)NXX=NDR(NXX-NMAX)
              TM=DZM/(NXX-TQD)
              TM=TM*TM
              TN=DZA/NXX
              TN=TN*TN
              DO I=NTAR,2,-1
                DO J=I-1,1,-1
                  IF(ETAR(I)-ETAR(J)-TN*D0PT9.GE.DZERO)THEN
                    EMIN=MIN(EMIN,ETAR(I)-ETAR(J)-TM)
!                    write(mw0,*)n,i,j,emin
                    GO TO 205
                  ENDIF
                ENDDO
  205         ENDDO
            ENDDO
          ENDIF
!
          EMIN=EMIN*D0PT9
!          IF(LNEW.LT.0)EMIN=EMIN*D0PT9
          IF(EMIN.LT.D1M2*DZA2)EMIN=DZERO
        ENDIF
        IF((EMAX-EMIN).LT.D1M5)GO TO 400
      ENDIF
!
! SET UP ENERGY GRID FOR INTERPOLATION
!
      IF(.NOT.BTWO)GO TO 300
      BBC2=.TRUE.
      EMIN2=EMIN                            !TWO RANGES
      IF(EMAX2-EMIN2.LT.D1M5)THEN
        EMAX=EMAX2
        EMIN=EMIN2
        GO TO 400
      ENDIF
      IF(EMAX1-EMIN1.LT.D1M5)THEN
        EMAX=EMAX1
        EMIN=EMIN1
        GO TO 400
      ENDIF
      IF(EMIN2-EMAX1.LT.D1M5)THEN
        EMAX=EMAX2
        EMIN=EMIN1
        BTWO=.FALSE.
        GO TO 300
      ENDIF
!      write(mw6,*)'emin,emax1,2=',emin1,emax1,emin2,emax2
      MN2=MENG/2
      DD=MN2-1
      EMAX=EMAX1+DONE
      EMIN=EMIN1+DONE
      DO M=1,MN2
        DM=M-1
        T=EMAX/EMIN
        T=T**(DM/DD)
        DYY(M)=EMIN*T-DONE
      ENDDO
      IGAPE=MN2+1
      MN1=MN2
      MN2=MENG-MN2
      DD=MN2-1
      EMAX=EMAX2+DONE
      EMIN=EMIN2+DONE
      DO M=1,MN2
        DM=M-1
        T=EMAX/EMIN
        T=T**(DM/DD)
        DYY(MN1+M)=EMIN*T-DONE
      ENDDO
!
      GO TO 700
!
  300 CONTINUE                              !ONE RANGE (ALSO OPT. PI)
!
      IF(EMAX.LT.EMIN)GO TO 400
!
      IF(MENG.LE.1)THEN
        WRITE(MW6,10070)-MENG
        WRITE(MW0,*)'****ERROR IN SR.RADCN0, REQUIRE AT LEAST TWO',     &
     &              ' INTERPOLATION ENERGIES'
        NF=-1
        GO TO 900
      ENDIF
      DD=MENG-1
      EMAX=EMAX+DONE
      EMIN=EMIN+DONE
      DO M=1,MENG
        DM=M-1
        T=EMAX/EMIN
        T=T**(DM/DD)
        DYY(M)=EMIN*T-DONE
      ENDDO
!
      GO TO 700
!
  400 WRITE(MW6,10060)EMIN,EMAX
      WRITE(MW0,*)'****ERROR IN SR.RADCN0, UNSUITABLE ENERGY RANGE'
      NF=-1
      GO TO 900
!
! READ USER SUPPLIED INTERPOLATION ENERGIES (RYD)
!
!
  500 READ(MR5,*)(DYY(I),I=1,MENG)
!
!
      IF(NF.LE.0)GO TO 900
!
      IF(BZSCLE)THEN
        DO I=1,MENG
          DYY(I)=DYY(I)*DZA2
        ENDDO
      ENDIF
!
      BBC2=.TRUE.
      IF(MENG.EQ.1)GO TO 700
!
! RE-ORDER INTO ASCENDING ENERGIES
!
      DO I=2,MENG
        IM=I-1
        IF(DYY(I).GT.DYY(IM))GO TO 600
        T=DYY(I)
        DYY(I)=DYY(IM)
        DYY(IM)=T
        IT=NREL
        IF(NREL.EQ.I)NREL=IM
        IF(IT.EQ.IM)NREL=I
        IF(IM.EQ.1)GO TO 600
!
        DO J=2,IM
          JM=I-J
          JJ=JM+1
          IF(DYY(JJ).GT.DYY(JM))GO TO 600
          T=DYY(JJ)
          DYY(JJ)=DYY(JM)
          DYY(JM)=T
          IT=NREL
          IF(NREL.EQ.JJ)NREL=JM
          IF(IT.EQ.JM)NREL=JJ
        ENDDO
  600 ENDDO
!
! DISCARD EQUAL ENERGY ENERGIES
!
      MX=MENG
      DO I=2,MX
        IF(I.GT.MENG)GO TO 700
        T=ABS(DYY(I)-DYY(I-1))
        IF(T.LT.D1M10)THEN
          IP=I+1
          DO J=IP,MENG
            DYY(J-1)=DYY(J)
          ENDDO
          MENG=MENG-1
          IF(NREL.GE.I)NREL=NREL-1
        ENDIF
      ENDDO
!
  700 IF((MION1-NZION.EQ.1.OR.MDEN.GT.0).AND.DYY(1).LT.D1M2)THEN
        IF(MION1-NZION.EQ.1)THEN
          WRITE(MW0,*)'*** RE-SETTING E=0 TO 1.D-2 FOR NEUTRALS...'
          WRITE(MW6,*)'*** RE-SETTING E=0 TO 1.D-2 FOR NEUTRALS...'
        ENDIF
        IF(MDEN.GT.0)THEN
          WRITE(MW0,*)'*** RE-SETTING E=0 TO 1.D-2 FOR NEUTRALIZATION..'
          WRITE(MW6,*)'*** RE-SETTING E=0 TO 1.D-2 FOR NEUTRALIZATION..'
        ENDIF
        DYY(1)=D1M2
      ENDIF
      IF(NREL.LT.1.OR.NREL.GT.MENG)THEN
        NREL=1
        IF(.NOT.BFOT)NREL=NREL+MENG/2
      ENDIF
!
      IF(DYY(1).EQ.DZERO.AND.MENG.EQ.NLAG)THEN          !WARNING
        WRITE(MW0,*)'***WARNING SR.RADCN0: CHECK INTERPOLATION ACCURACY'
        WRITE(MW6,10010)MENG,NLAG
      ENDIF
!
! SET SWITCH-OVER POINT FROM DOWN TO UPSCALING FOR RYD.
!
      IF(BFOT.AND.BDR)THEN
        IF(MXEP.GT.MENG)THEN
          MXEP=MENG
        ELSEIF(MXEP.LT.0)THEN
          ETEST=50*(DZA/(NSW-1))**2
          DO I=1,MENG
            IF(DYY(I).GT.ETEST)GO TO 720
          ENDDO
          I=MENG
  720     MXEP=I
        ENDIF
      ENDIF
!
! CONVERT FROM RYDBERGS TO ATOMIC UNITS FOR STRUCTURE BRANCH.
!
      DO I=1,MENG
        DYY(I)=DYY(I)/DTWO
      ENDDO
!
! SET-UP R-MATRIX CONTINUUM BASIS PARAMETRIC POTENTIAL
! (NOTE DIFFERENT NPOT FLAGS FROM STG1 - JUST USE ACTUAL TFDAPO,
!                                        CASE NPOT(RM)<0)
!
      IF(NPOT.GT.0)THEN                                        !STO-FORM
        IF(NPOT.GT.6)THEN
          WRITE(MW0,10120)NPOT
          WRITE(MW6,10120)NPOT
          NF=-1
          GO TO 900
        ENDIF
        READ(MR5,*)(IPOT(I),I=1,NPOT)
        READ(MR5,*)(CPOT(I),I=1,NPOT)
        READ(MR5,*)(XPOT(I),I=1,NPOT)
      ELSEIF(NPOT.LT.0)THEN              !NUMERICAL, *NOT* SCALED TFDAPO
        NELCOR=MION1-1
        NPOT=1
        CPOT(1)=2*NELCOR
        XPOT(1)=NZION
        XPOT(1)=XPOT(1)**D1THRD
        IPOT(1)=-1
        IF(NZION.GT.NELCOR)THEN
          NPOT=2
          CPOT(2)=(NZION-NELCOR)*2
          XPOT(2)=DZERO
          IPOT(2)=-1
        ENDIF
      ENDIF
      IF(NPOT.GT.0)THEN
        WRITE(MW6,10110)NPOT
        WRITE(MW6,10130)(IPOT(I),I=1,NPOT)
        WRITE(MW6,10140)(CPOT(I),I=1,NPOT)
        WRITE(MW6,10150)(XPOT(I),I=1,NPOT)
      ENDIF
!
      CALL RE_ALLOC(DYY,IONE,IXENG,MENG,IERR)         !REDUCE
      IXENG=MENG                                      !SYNC
!
      IF(DHNSX.LT.DZERO)GO TO 900                 !NOT YET SET SO RETURN
!
!-----------------------------------------------------------------------
!
! RE-ENTRY POINT
!
  800 CONTINUE
!
! TEST RADIAL MESH FOR INTEGRALS INVOLVING CONTINUUM FUNCTIONS
!
      DRY=2*DYY(MENG)                                !AS DYY IN A.U. NOW
      T=SQRT(DRY)
      IF(T.NE.DZERO)THEN
        T=PI/T
        T=T/DHNSX
        IF(T.LT.DTWELV)THEN
          IF(T.LT.DSIX)THEN
            M0=MSTEP+1
            WRITE(MW6,10190)DRY,M0
            WRITE(MW0,*)'RADIAL MESH TOO COARSE'
            NF=-1
            GO TO 900
          ELSE
            IF(BFOT)THEN
              M0=MSTEP+1
              WRITE(MW6,10200)DRY,M0
              IF(DRY.GT.DFOUR*DZA2)THEN
                WRITE(MW0,*)'RADIAL MESH TOO COARSE'
                NF=-1
                GO TO 900
              ENDIF
            ENDIF
          ENDIF
        ENDIF
      ENDIF
!
      IF(BFOT)THEN        !INITIALIZE FOR GAUGE
        DO I=1,MENG
          IGAG(I)=1
        ENDDO
      ENDIF
!
      MYMO=MYM            !FOR ANNOYING COMPILERS
      MYNO=MYN
      MPO=MP
!
      DUM=NDUM*DUM        !SUPRESS WARNINGS ABOUT UNUSED DUMMY VARIABLES
!
!-----------------------------------------------------------------------
!
  900 CONTINUE
!
! N.B. CAN DE-ALLOCATE SINCE CURRENTLY ONLY USED LOCALLY, SO STRICTLY
! DOES NOT NEED TO BE IN MODULE COMMON_NRBTAR. BUT WAS HISTORICALLY HELD
! IN COMMON/NRBTAR/ FOR POSSIBLE FUTURE APPLICATION. SO, RETAIN FOR NOW.
! HOWEVER IGAPE IS USED IN SR.CARATE,DIAGFS,DIAGON AND SO MUST BE PASSED
! STILL SOMEWHERE. IF NOT DE-ALLOCATED HERE THEN SHOULD BE RE-ALLOCATED
! TO USE ACTUAL NTAR.
!
      IF(ALLOCATED(ETAR))THEN
        DEALLOCATE(ETAR,ISTAR,LTAR,JTAR,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'*** SR.RADCN0: DE-ALLOCATION FAILS FOR ETAR ETC'
          NF=MIN(NF,IZERO)
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
 1000 WRITE(MW6,10210)
      WRITE(MW0,*)'*** SR.RADCN0: ERROR READING NAMELIST SRADCON!'
                                                                  !FATAL
      NF=-1
      GO TO 900
!
!-----------------------------------------------------------------------
!
10010 FORMAT(//'*** WARNING SR.RADCN0: CHECK INTERPOLATION ACCURACY ***'&
     &       /4X,'THE NUMBER OF INTERPOLATIONS ENERGIES (MENG=',I3,     &
     &       ') IS',' LIKELY TOO SMALL FOR THE LAGRANGE ORDER (NLAG=',  &
     &       I2,')'//)
10020 FORMAT(/' THE NUMBER OF INTERPOLATION ENERGIES HAS BEEN REDUCED'/ &
     &       ' FROM',I5,' TO',I5/' INCREASE IXENG BUFFER TO RETAIN ALL,'&
     &       ,' CONTINUING...'/)
10030 FORMAT('*** WARNING SR.RADCN0: INTERNAL PI ENERGY MESH TRUNCATED'/&
     &       4X,'EMAX=',1PD12.2,' INCREASE IXENG BUFFER TO:',I4,        &
     &       ' TO OBTAIN FULL ENERGY MESH, E.G. FOR RATE COEFFICIENTS')
10040 FORMAT(2F10.1,2I5,F10.4,5I5)
! 591 FORMAT(7F10.4)
10050 FORMAT('  YOUR VALUE OF',I3,                                      &
     &       ' FOR MODE IN SR.RADCN0 IS NOT WITHIN',                    &
     &       ' THE CURRENT VALID RANGE')
10060 FORMAT(/' ****ERROR IN SR.RADCN0, UNSUITABLE ENERGY RANGE FOR ',  &
     &       'INTERPOLATION, EMIN=',F10.4,3X,'EMAX=',F10.4/)
10070 FORMAT('****ERROR IN SR.RADCN0, REQUIRE AT LEAST TWO',            &
     &       ' INTERPOLATION ENERGIES BUT MENG=',I4)
10080 FORMAT(/' ***ERROR, MUST SPECIFY NON-ZERO MENG ENERGIES FOR DR')
10090 FORMAT(/'*** UNRECOGNIZED PI GAUGE: PIG=',A3)
10100 FORMAT('*** SR.RADCN0: REQUESTED MAX PI ENERGY TOO LARGE'/        &
     &       '*** EITHER REDUCE EMAX TO .LT.',                          &
     &       1PD11.2/'*** OR INCREASE BUFFER DIMENSION IXENG'/          &
     &       '*** OR INPUT  0 .LT. MENG .LE. IXENG  ENERGIES EXPLICITLY'&
     &       )
10110 FORMAT(/' SR.RADCN0: PARAMETRIC POTENTIAL NPOT =',I3)
10120 FORMAT(/' SR.RADCN0: NO. OF PARAMETRIC POT COEFFS MUST BE .LE. 6;'&
     &       ,' NPOT=',I3)
10130 FORMAT(' IPOT=',9I12)
10140 FORMAT(' CPOT=',9F12.7)
10150 FORMAT(' XPOT=',9F12.7)
10160 FORMAT(I9,I2,I5,F18.6,3X,A4)
10170 FORMAT(3I2,I5,I5,F18.6,3X,A4)
10180 FORMAT(2I2,1X,I3,I2,2I5,F18.8,3X,A4)
10190 FORMAT(/' SR.RADCN0: EMAX=',1PD9.2,' MESH TOO COARSE, BOUND-',    &
     &       'CONTINUUM INTEGRALS IN ERROR.'/                           &
     &       '*** REDUCE EMAX IN NAMELIST ',                            &
     &       'SRADCON OR INCREASE MSTEP TO',I3,' IN NAMELIST SMINIM')
10200 FORMAT(/' SR.RADCN0: WARNING, EMAX=',1PD9.2,' MESH MAYBE TOO ',   &
     &       'COARSE, BOUND-CONTINUUM INTEGRALS MAYBE IN ERROR.'/       &
     & ' *** TRY REDUCING EMAX IN NAMELIST SRADCON OR INCREASING MSTEP '&
     & ,'TO',I3,' IN NAMELIST SMINIM')
10210 FORMAT('*** SR.RADCN0: ERROR READING NAMELIST SRADCON!'/4X,       &
     &       'IF PRESENT, CHECK FOR ILLEGAL OR MISTYPED VARIABLE NAMES')
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE RADCN0
!
!                             *******************
!
      SUBROUTINE RADCNX(FRX,PSHFTX,PSHFT0,MDIM1,MDIM2,MDIM3,LNEW,LOLD   &
     &          ,LCDW,MPOSC0)
!
!-----------------------------------------------------------------------
!
!  SR.RADCNX CALCULATES/UPDATES THE DEIE DW CONTINUUM BASIS
!
!  IT IS CALLED BY:
!    SR.CADWX
!    SR.DWXBP_DAXPY
!    SR.DWXBP_DDOT
!    SR.DWXLS_DAXPY
!    SR.DWXLS_DDOT
!
!  IT CALLS:
!    SR.FCF4
!    SR.FCF6
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD,KORT
      USE COMMON_NRBDW1, ONLY: MXORB,ma0,mb0
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
      USE COMMON_NRBDW5, ONLY: DYY,MENG,NLAG
      USE COMMON_NRBDW6, ONLY: QPOS,QPOS0
      USE COMMON_NRBDWP, ONLY: DLAMX,DLAMDX,DLAMQX,JENDX,SCALERX
      USE COMMON_NRBPOT, ONLY: DPOT,TOL,MEND
      USE COMMON_NRBPOT, ONLY: ZS0,ZS,JZNM
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBREL, ONLY: DNUK0,DNUK1,DNUK2,DNUK
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION FRX(MDIM1,MDIM2,MDIM3),PSHFTX(MDIM2,MDIM3)              &
     &         ,PSHFT0(LVMIN:*)
!
      ALLOCATABLE :: GR(:)
!
!-----------------------------------------------------------------------
!
! THE NAMES HERE ARE NOT NECESSARILY SIGNIFICANT THEY ARE COMMON LEGACY.
!
! LOCAL
      ALLOCATE(GR(MAXRS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RADCNX: ALLOCATION FAILS FOR GR'
        NF=0
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
! INITIALIZE LOGICALS
!
      BPRNT0=JPRINT.GE.3                      !FOR DETAILED PRINTOUT
!      BPRNT0=JPRINT.NE.-3
!      BORT=MORT.LT.0                             !HISTORIC, USE KORT
      IORT=ABS(MORT)
      BREL2=ABS(IREL).EQ.2
      BTHRSH=LCDW.LT.0
      IF(BTHRSH)LCDW=-LCDW
!
! FOR TOTAL LNEW THERE ARE LCDW CONTINUUM ORBITAL ANGULAR MOMENTA
! OF LNEW-LCDW/2 THRU LNEW+LCDW/2.
! QPOS(L), L=1,LCDW GIVE THE LOCATION OF THE ASSOCIATED ANG. MOM.
! ORBITAL. THIS ENABLES US TO RE-USE ANY COMMON ORBITALS FROM LOLD.
! THUS, SHOULD GROUP ALL S,PI TOGETHER FOR A GIVEN LTOT AND LOOP
! OVER LTOT SEQUENTIALLY, AS IS DONE BY USE OF MINLT,MAXLT.
!
      MPOSC=ABS(MPOSC0)
      MPOSQ=(LCDW+1)/2-LNEW
!
      IF(LOLD.LT.0)THEN             !FIRST TIME
!
! EX-CXOMMON/NRBDW6/
        ALLOCATE(QPOS(LCDW),QPOS0(LCDW),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'RADCNX: ALLOCATION FAILS FOR QPOS'
          NF=0
          GO TO 100
        ENDIF
!
        DO L=1,LCDW
          I=MPOSC+L
          QPOS(L)=INT(L,QP)
          QN(I)=-90
!          IVAL(I)=0                !NOT USED
!          DORIG(I)=DZERO           !NOT USED
!          DUY(I,I)=DZERO           !NOT USED: DEY HOLDS ENERGY
          DEY(I)=DZERO
!          SCREEN(I)=DZERO          !NOT USED
        ENDDO
        IFLAG=0
!
      ELSE
!
        DO L=1,LCDW
          QPOS0(L)=ABS(QPOS(L))
          QPOS(L)=0
        ENDDO
        ML=-2*(MPOSQ-1)
        MU=2*(LNEW+LCDW/2)
        DO L=1,LCDW
          I=MPOSC+L
          IF(QL(I).GE.ML.AND.QL(I).LE.MU)THEN         !RE-USE
            K=MPOSQ+QL(I)/2
            QPOS(K)=-QPOS0(L)                         !FLAG OLD
          ELSE
            QPOS0(L)=-QPOS0(L)                        !NOT WANTED
          ENDIF
        ENDDO
        IFLAG=1
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      MYL2=-2*MPOSQ
!                                   !LABEL & FLAG EXISTENCE
      DO L=1,LCDW
        I=MPOSC+L
        MYL2=MYL2+2
        QL(I)=INT(MYL2,QP)
        IF(QPOS(L).EQ.0)THEN                          !NEW
          IFLAG=0
          DO K=1,LCDW                                 !LOOK FOR SPACE
            IF(QPOS0(K).LT.0)THEN
              QPOS(L)=-QPOS0(K)
              QPOS0(K)=0
              GO TO 50
            ENDIF
          ENDDO
          WRITE(MW6,*)' SR.RADCNX: QPOS INDEX ERROR...'
          WRITE(MW0,*)' SR.RADCNX: QPOS INDEX ERROR...'
          NF=-1
          GO TO 100
        ENDIF
   50   CONTINUE
!        write(mw0,*)i,l,qpos(l),ql(i),myl2             !debug print
      ENDDO
!
      IF(IFLAG.NE.0)GO TO 100                         !QUICK RETURN
!
!-----------------------------------------------------------------------
!
! NOW GENERATE UPDATED CONTINUUM BASIS FOR QPOS(L).GT.0, L=1,LCDW
!
!-----------------------------------------------------------------------
!
      IF(BPRNT0)THEN
        IF(MPOSC0.GT.0)THEN
          WRITE(MW6,10010)LNEW
        ELSE
          JNEW=2*LNEW+MOD(LCDW+1,ITWO)
          WRITE(MW6,10030)JNEW   !ASSUMES USER HASN'T RESTRICTED LCONDWJ
        ENDIF
      ENDIF
!
      NZA=NZION-MION
!      DZ=NZION
      DZ0=-NZION                              !CHARGES .LT. ZERO IN FCF6
      DZA=-NZA
      DD0=DZERO
!
!      MK=MXORB+1                              !NOMINAL ORBITAL POSITION
      DJ=DLAMX
      MEND=JENDX
      MZNM=5                            !MAX NON-REL ORB POTL PARAMETERS
!
      DO L=1,LCDW
!
        I=MPOSC+L
        MYL=QL(I)/2
!
        L0=QPOS(L)
!
        IF(L0.GT.0.AND.MYL.GE.0)THEN
!
          DO M=1,MENG
!
            DDY=DYY(M)
!
            IF(DJ.GT.DZERO.OR.IORT.EQ.2.OR.BREL)THEN    ! DW
!
              CALL FCF6(FRX(1,M,L0),DP0,TM,MYL,DDY,DZ0,DZA,DD0,DD0,DD0, &
     &                  ZS,MZNM,DPOT,MEND,MJH,MNH,DHNS,DX,GR,MAXRS)
!
              IF(MYL.LT.0)THEN
                WRITE(MW6,*)'*** FCF6 FAILURE...'
                WRITE(MW0,*)'*** FCF6 FAILURE...'
                NF=-1
                GO TO 100
              ENDIF
!
! test
!              do k=1,mxorb
!!
!                if(2*myl.ne.ql(k))go to 63
!                if(dorig(k).eq.dzero)go to 63
!!
!                if(brel2)then
!                  do i=1,maxrs
!                    da(i)=dpnl(i,k)*frx(i,m,l0)+dqnl(i,k)*gr(i)
!                  enddo
!                else
!                  do i=1,maxrs
!                    da(i)=dpnl(i,k)*frx(i,m,l0)
!                  enddo
!                endif
!!
!                call weddle(dzero,da,dd,mnh,dhns,mjh,maxrs)
!!
!                if(brel2)then
!                  do i=1,maxrs
!                    frx(i,m,l0)=frx(i,m,l0)-dd*dpnl(i,k)
!                    gr(i)=gr(i)-dd*dqnl(i,k)
!                  enddo
!                else
!                  do i=1,maxrs
!                    frx(i,m,l0)=frx(i,m,l0)-dd*dpnl(i,k)
!                  enddo
!                endif
!!
! 63           enddo
!
              IF(BREL2)THEN
                DO I=1,MAXRS
                  FRX(MAXRS+I,M,L0)=GR(I)
                ENDDO
              ENDIF
!
            ELSE                                        !COULOMBIC
!
              CALL FCF4(FRX(1,M,L0),DP0,DDY,DZA,MYL,MJH,MNH,DHNS,DX)
!
              TM=DZERO
!
            ENDIF
!
            PSHFTX(M,L0)=TM
!
            IF(BPRNT0)WRITE(MW6,10020)MYL,DDY,TM
!
          ENDDO
!
          IF(BTHRSH.AND.MYL.GE.LVMIN.AND.MYL.LE.LVMAX)THEN
            PSHFT0(MYL)=PSHFTX(1,L0)
          ENDIF
!
        ENDIF
!
      ENDDO
!
!-----------------------------------------------------------------------
!
  100 CONTINUE
!
! LOCAL
      DEALLOCATE(GR,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RADCNX: DE-ALLOCATION FAILS FOR GR'
        IF(NF.GT.0)NF=0
      ENDIF
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(//' *** UPDATING CONTINUUM ORBITAL BASIS FOR LTOT=',I3/1X, &
     &       49('-')/)
10020 FORMAT(' L=',I2,3X,'E=',F10.5,' RYD',3X,'DEL/PI=',F9.4)
10030 FORMAT(//' *** UPDATING CONTINUUM ORBITAL BASIS FOR 2*JTOT=',     &
     &       I3/1X,51('-')/)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE RADCNX
!
!                             *******************
!
      SUBROUTINE RADCON(MAXPS)
!
!-----------------------------------------------------------------------
!
!              N.R.BADNELL  D.A.M.T.P. CAMBRIDGE
!              *********************************
!
!  SR.RADCON DETERMINES A SET OF RADIAL CONTINUUM FUNCTIONS.
!
!  MODE=1, SUPERSTRUCTURE MODE.
!  MODE=2, SETS C-C INTERACTIONS TO ZERO, STORES B-C SEPARATELY AND
!            SETS THEM TO ZERO IN H BEFORE DIAGONALIZATION.
!  MODE=3, ALL B-B, B-C AND C-C INTERACTIONS EVALUATED AND PUT IN
!            H FOR DIAGONALIZATION.
!  MODE=4, NOT USED BY RADCON, RADIAL SHIFTS ENERGIES OF CERTAIN
!               BOUND ORBITALS TO SUPRESS MIXING.
!
!  IT IS CALLED BY:
!    SR.RADIAL
!
!  IT CALLS:
!    SR.DIFF
!    SR.DIMUSE
!    SR.FCF4
!    SR.FCF6
!    SR.FIT
!    SR.FSINTI
!    SR.POTF
!    SR.RADCN0
!    SR.RK4PI
!    SR.SLATRI
!    SR.STOPOT
!    SR.TFDAPO
!    SR.VMPOT
!    SR.WEDDLE
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_ALGEB,  ONLY: BFOT
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CADJ,   ONLY: DAJNEW
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS,MJH00
      USE COMMON_CMESH,  ONLY: MHF,MRAD,MSTEP,IXTRA,xmax
      USE COMMON_CMESH,  ONLY: TINORB,RZERO,MXBOX
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DMQSS3, ONLY: QSS                                      &
     &                        ,NL000=>NL,NL=>NL000
      USE COMMON_DXRL,   ONLY: QRL,IRL
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_GENINF, ONLY: SCALER
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR
      USE COMMON_MINIM,  ONLY: ECOR1,ECOR2,ECORR,ECORRJ,ESKPL,ESKPH     &
     &                        ,BECOR
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
      USE COMMON_REL,    ONLY: DMASS,DCD,D2LL
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD,KORT
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,VSC,XC1,XC2,NPITER
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBDR,  ONLY: IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR
      USE COMMON_NRBFSI, ONLY: DNLI,NLI
      USE COMMON_NRBINT, ONLY: DRLI,DYY,IYY,NRLI,MENG,NREL,NLAG,NLAGP   &
     &                        ,BLAG,BBC2
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBOLP, ONLY: OVLPGR,OVLPCF,IPAIR
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX                     &
     &                        ,MXBORB,MXVORB,MXFORB,NGRP
      USE COMMON_NRBPOT, ONLY: DL2=>DPOT,TOL,MEND
      USE COMMON_NRBPOT, ONLY: ZS0,ZS,JZNM
      USE COMMON_NRBPOT, ONLY: POT,JPOT1
      USE COMMON_NRBPOT, ONLY: POTHAM,MPSEUD
      USE COMMON_NRBPOT, ONLY: DERV
      USE COMMON_NRBPOT, ONLY: DERV1,DERV2
      USE COMMON_NRBPOT, ONLY: ALFD,RCUT,ALAV,RCAV,IPOLFN
      USE COMMON_NRBPOT, ONLY: CPOT,XPOT,IPOT,NPOT
      USE COMMON_NRBQED, ONLY: VPINT,SLFINT,QED
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBREL, ONLY: RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0
      USE COMMON_NRBREL, ONLY: DNUK0,DNUK1,DNUK2,DNUK
      USE COMMON_NRBSHF, ONLY: DSHIFT,MSHIFT,KSHIFT,MKMAX,MXEP
      USE COMMON_NRBSTO, ONLY: ALF,TEL,MSHELL,MCFSTO,MC,MCFMX,MEXPOT    &
     &                        ,NOCC,IOCC,NLSTOE,BFIX,BSTO,MXSHLL,NGAPSTO
      USE COMMON_NRBTS1, ONLY: IXD24
      USE COMMON_NRBVAL, ONLY: FACT,IVAL,NNEW,NNOLD,BJUMP,BJUMP2,BRAD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (DTOL=D1M2)
!
      CHARACTER(LEN=4) MCF4,MCF6,MCF
      CHARACTER(LEN=14) F588
!
      ALLOCATABLE :: DORIGZ(:)
!
      ALLOCATABLE :: DA(:),DPA(:),FR(:),GR(:)
!
      DIMENSION MNH0(MJH00)
!
      SAVE MAXRS0                             !TEST
!
      DATA MCF6/'FCF6'/,MCF4/'FCF4'/,IDERV/0/
!
!-----------------------------------------------------------------------
!
      IF(NF.LE.0)GO TO 100
!
!-----------------------------------------------------------------------
!
! LOCAL
      ALLOCATE(DORIGZ(MXORB),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RADCON: ALLOCATION FAILS FOR DORIGZ'
        NF=0
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
      BMVDR=ALLOCATED(DCD)
      B2LL=ALLOCATED(D2LL)
!
!-----------------------------------------------------------------------
!
! SOME INITIALIZATIONS
!
      PI=ACOS(-DONE)
      PIH=PI/DTWO
!
      MION1=NW+NF                !TOTAL NUMBER OF ELECTRONS (=MION+MRED)
      NZA=MAX(NZION-MION1+1,IONE)       !CHARGES
      DZ=NZION
      DZ0=-NZION                        !CHARGES .LT. ZERO IN FCF6
      DZA=MION1-NZION-1
      DZA2=NZA*NZA                   !=DZA*DZA EXCEPT CASE DZA=0, THEN 1
      TOLR=D1M6/NZA
!
      MB0=MB
!p      IF(IEQ(0).LT.0)MXBORB=-IEQ(0)     !FOR NON-UNIQUE (RLX) BASIS
      IF(IEQ(0).GT.0)THEN               !UNPACK SRLX INFO
        IF(IRLX.LT.0)MB0=0                  !IRLX.LT.0 MEANS IEQ(0).GT.0
!p        ID=IEQ(0)-MXORB
!p        NGRP=ID/100000
!p        ID=ID-100000*NGRP
!p        MXFORB=ID/10000
!p        ID=ID-10000*MXFORB
!p        MXVORB=ID/1000
!p        ID=ID-1000*MXVORB
!p        MXBORB=ID
!pc       write(mw0,*)ngrp,mxborb,mxvorb,mxforb
      ENDIF
!
      BDR=IDR.NE.0                      !LOGICALS
      BCONT=MODE.EQ.2.OR.MODE.EQ.3
      BHF=MHF.GT.0
      IF(BJUMPR)BREL=.FALSE.            !BJUMPR=.FALSE. FIXED IN RADIAL
      BREL2=ABS(IREL).EQ.2
      BORT=MORT.LT.0
      IORT=ABS(MORT)
      BKUTOO=KUTOO.NE.0
      BXTRP=.FALSE.
      BPRNT0=JPRINT.NE.-3
!
      MYN=1                             !MESH PRINTOUT
      MYM=-1
      II=1
      MP=-1
!
      MZNM=5                            !POTENTIAL PARAMETERS
!TEST     MEND=0
      JPOT=-1
      DJ=DZERO
      TOL=DONE/10**ITOL
      INUKP=INUK+1                      !FOR FINITE NUCLEUS
      NP0=0
      IF(IPOLFN.LT.0)NP0=-IPOLFN
!      NPARM3=(NP0+1)*NPARAM
      IDERV=0
!
      MPP=1                             !PLASMA POTENTIAL
      IF(MDEN.LT.0)MPP=2
!      MDEN10=MOD(MDEN,ITEN)            !ONLY IF I-S HAS 2-BOFY
      ZNP0=-D99
!
      TM=DONE                           !OLD PHASE - NEEDED?
      MINK=0                            !OLD E SHIFT - COULD REMOVE USE
      MSHIFT=10000
!
      KK=0                              !INTERPOLATION COUNTERS
      KFS=0
      M8=0
!
! SEE WHICH ORBITALS TO COMPUTE
!
      K0=-1
      KSTORE=0
      MAXL=0
      IVM=10000000
      IVP=0
!
      DO K=1,MXORB
        DORIGZ(K)=DZERO
        IF(DEY(K).NE.DZERO)THEN
          IF(IVAL(K).GT.0)THEN
            IF(K.GT.IVP)IVP=K
            IF(K.LT.IVM)IVM=K
          ENDIF
          IF(SCREEN(K).LT.5999)THEN     !BOUND (CORE)
            DORIGZ(K)=DORIG(K)*DZ
          ELSE
            IF(K0.LT.0)K0=K
            IF(SCREEN(K).LT.7999)THEN   !RYDBERG
              BXTRP=.TRUE.
              KSTORE=K                  !NSTORE=QN(K)
              IF(QL(K).GT.MAXL)MAXL=QL(K)
            ENDIF
          ENDIF
        ENDIF
      ENDDO
!
!-----------------------------------------------------------------------
      IF(K0.LT.0)GO TO 2000  !NO NEW ORBITALS TO CALC, RECOVER FROM FILE
!-----------------------------------------------------------------------
!
      MAXL=1+MAXL/2
!
      IF(BJUMP.OR.MODE.EQ.1)GO TO 200       !NOT FIRST TIME, SKIP SET-UP
!
! READ USER INPUT AND SET-UP ENERGY MESH BASED-ON THIS, OR BEST GUESS
!
  100 CALL RADCN0(MYM,MYN,MP,DHNS(MJH))
!
      IF(NF.LE.0)GO TO 3400                                      !RETURN
!
      BLAG=MENG.GT.1
!
! INITIALIZE CONTUNUUM INTERPOLATION INTEGRAL ARRAYS
!
! *** SLATER (2-BODY NON-FINE STRUCTURE USE SLATER SWITCH SO NOT NECESS)
!
      DO J=1,IXFSL
        DO I=1,MENG
          DRLI(I,J)=DZERO
        ENDDO
      ENDDO
!
! *** 2-BODY FINE-STRUCTURE
!
      IF(NL000.GT.0)THEN
        DO J=1,IXFSS
          DO I=1,MENG
            DNLI(I,J)=DZERO
          ENDDO
        ENDDO
      ENDIF
!
! RE-ALIGN FINITE NUCLEUS FOR FCF6
!
      DO I=1,INUK
        DNUK(I)=DTWO*(DNUK0(I)-DZ/DX(I))
      ENDDO
!
      ZS(0)=DTWO*ZS0(0)
      IF(BREL)THEN
        DO J=1,JZNM                         !JZNM.LT.MZMN
          ZS(J)=DTWO*ZS0(J)
        ENDDO
      ENDIF
!
!-----------------------------------------------------------------------
!
! FOR CONTINUUM WAVEFUNCTION WE DROP ALL POINTS PAST INPUT MAXPS
! SINCE ALL INTEGRALS P*F, P*P SHOULD HAVE CONVERGED BY THEN.
!
! HOWEVER, IF BXTRP=TRUE (RYDBERG APPROX BY A CONTINUUM) THEN NEED TO
! EVALUATE OUT TO POINT WHERE  AMP. PHASE CAN BE USED, FOR WORST CASE
! E=0, L=MAXL, AND RESET MAXPS ACCORDINGLY.
!
! ALSO, IF BDR=TRUE THEN MUST EVALUATE ALL ORBITALS OUT TO X(MAXRS0)
! WITH ORIGINAL GRID MJH->MJH0, MNH->MNH0, MAXRS->MAXRS0.
! N.B. MJH0/MNH0 HERE DIFFERS FROM /CMESH/ MJH0/MNH0 BY ANY IXTRA.
!
! HOWEVER, INTEGRALS STILL NEED ONLY BE EVALUATED OUT TO MAXPS.
! N.B. WE NEED TO ALIGN MAXPS->MAXRS WITH MJH, MNH SINCE WE HAVE
! 2-BODY INTEGRALS (SR.YLAMK), UNLIKE RADIAL WHERE WE ONLY USE WEDDLE.
! SO WE BACK-UP AND TRUNCATE THE GRID MJH, MNH AT THIS POINT, RATHER
! THAN AT THE END WHEN WE NO LONGER NEED ORIGINAL (HENCE SET MJH0, MNH0)
! SR.RADIAL THEN RE-INSTATES THE ORIGINAL MJH, MNH ON THE NEXT N-LOOP.
!
  200 IF(BXTRP)THEN
        DTH=3*MAXL*(MAXL+1)+60
        DD0=DTH/(DTWO*SQRT(DZA2))
        dd0=max(dd0,rzero)
!
        DO I=1,MAXRS
          IF(DX(I).GT.DD0)THEN
            IF(I.GT.MAXPS)MAXPS=I
            GO TO 300
          ENDIF
        ENDDO
        MAXPS=MAXRS
      ENDIF
!
  300 DHNS0=DHNS(1)                              !BACK-UP ORIGINAL
      MAXTS=MAXPS                      !MAX BOUND ORB EXTENT FROM RADIAL
      IF(BDR)THEN
        IF(.NOT.BJUMP)THEN
          MAXTS=MAXRS
        ELSE
          IF(BREL)MAXTS=MAXRS                    !AS NO DARWIN IN WHITEX
        ENDIF
      ENDIF
      IF(DENE.GT.DZERO)MAXTS=MAXRS               !PLASMA POT MAY EXPAND
      MAXRS0=0
!
! SEE IF WE CAN TRIM INPUT MESH (MJH0<-MJH, MNH0<-MNH, MAXRS0<-MAXRS)
!
      DO I=1,MJH
        MNH0(I)=MNH(I)                           !BACK-UP ORIGINAL
        MAXRS0=MNH0(I)+MAXRS0
        MJH0=I
        IF(MAXRS0.EQ.MAXTS)GO TO 400             !MAXIMAL MESH FOR CONT.
        IF(MAXRS0.GT.MAXTS)THEN
          MAXRS0=MAXRS0-MNH0(I)
          nxtra=9
!          if(.not.bsto)nxtra=max(nxtra,2*mnh(i-1))                !test
          MNH0(I)=MAX(MAXTS-MAXRS0,nxtra)
          MAXRS0=MAXRS0+MNH0(I)
          GO TO 400
        ENDIF
      ENDDO
!
! SET-UP MESH FOR INTEGRALS (FINAL TRUNCATION OF MJH, MNH, MAXRS)
!
  400 MAXTS=MAXPS
      MAXPS=0
      DO I=1,MJH0
        MAXPS=MNH(I)+MAXPS
        MJH=I
        IF(MAXPS.EQ.MAXTS)GO TO 500            !MAX NEEDED FOR INTEGRALS
        IF(MAXPS.GT.MAXTS)THEN
          MAXPS=MAXPS-MNH(I)
          MNH(I)=MAX(MAXTS-MAXPS,ININE)       !since for integrals only
          MAXPS=MAXPS+MNH(I)
          GO TO 500
        ENDIF
      ENDDO
!
  500 MAXRS=MAXPS                              !TRUNCATE
!
      IF(MYN.LT.0)WRITE(MW6,10020)MAXRS,MAXRS0
!
!-----------------------------------------------------------------------
!
! THE NAMES HERE ARE NOT NECESSARILY SIGNIFICANT THEY ARE COMMON LEGACY.
!
! LOCAL
      ALLOCATE(DA(MAXRS0),DPA(MAXRS0),FR(MAXRS0),GR(MAXRS0),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RADCON: ALLOCATION FAILS FOR DA,DPA,FR,GR'
        NF=0
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
! START LOOP TO EVALUATE ALL CONTINUUM ORBITALS
!
  600 DO K=K0,MXORB
        IF(DORIGZ(K).EQ.DZERO.AND.DEY(K).NE.DZERO)THEN
          N=K
          MI=QN(N)
          QN(N)=-INT(ABS(MI),QP)
          MYL=QL(N)/2
          MNN=-QN(N)
          DDY=DZERO
          INN=ICOL(N,N,IZERO)
          IF(SCREEN(N).LT.7999)GO TO 800
! WE USE IMPLICIT DSHIFT VIA INTERPOLATION TO AVOID RECOMPUTING CONT.
! TEST EXPLICIT DSHIFT (FOR FIRST N ONLY!) BY COMMENTING-OUT IF(BDR).
          IF(BDR)GO TO 700
          IF(BXTRP)THEN                   !EXPLICIT ON CONTINUUM N
            if(kstore.eq.0)stop 'kstore=0...'
            if(irlx.ne.0)stop 'cannot test explicit shift on relaxed'
            DDY=2*QN(KSTORE)*QN(KSTORE)
            DSHIFT(N)=DZA*DZA/DDY         !A.U. (HYDROGENIC)
            write(mw0,*)'explicit shift: ',n,dshift(n),k,dshift(kstore)
            DSHIFT(KSTORE)=DZERO          !ZERO-OUT RYD IMPLICIT
          ENDIF
          GO TO 700
        ENDIF
      ENDDO
!
      IF(BJUMP)GO TO 2000
      GO TO 2600                          !NO CONTINUUM TO CALCULATE
!
  700 IYY(N)=1
      IYY(IEQ(N))=1                       !IEQ(0).GT.0 NOT IN GROUP 1
!
      DDY=2*DYY(NREL)                     !A.U. TO RYD
      IF(DDY.LE.DZERO)THEN                !CHECK FOR NON-NEGATIVE ENERGY
        IF(DDY.LT.-D1M40)THEN
          WRITE(MW6,10070)N,DDY
          IF(N.EQ.MXORB)GO TO 2600
          GO TO 600
        ENDIF
        DDY=D1M50
      ENDIF
!
      DDY=DDY+DTWO*DSHIFT(N)
!
  800 K0=N+1
      IF(K0.GT.MXORB)K0=N
!
      IF(.NOT.BORT)THEN                       !HISTORIC L-DEPENDENT POTS
        JOLD=JPOT
        JPOT=MYL+1
        IF(JPOT.GT.IXPOT)JPOT=IXPOT
        IF(JPOT.EQ.JOLD)GO TO 1100
        DJ=DAJNEW(JPOT)
        MEND=JEND(JPOT)
        GO TO 1000
      ENDIF
!
      DADJUS(N)=DAJNEW(N)
      JEND(N)=MEND                      !CASE RYD LAMBDA NL.NE.CONTINUUM
      IF(NP0.GT.0)DADJUS(NPARAM+N)=DAJNEW(NPARAM+N)
      IF(NP0.EQ.2)DADJUS(2*NPARAM+N)=DAJNEW(2*NPARAM+N)
      MK=N
!
      IF(BDR.and.ieq(0).eq.0)THEN
        IF(.NOT.BSTO.OR.DDY.LE.DZERO)THEN
          IF(DAJNEW(N).EQ.DJ)GO TO 1100
          IF(JPOT1.GT.0)THEN
            IF(ABS(DX(MAXRS0)*POT(MAXRS0,IONE)+DZA).LT.D1M2.AND.        &
     &         DAJNEW(N).EQ.DAJNEW(JPOT1))THEN   !WE HAVE AN NL- POTL
              JPOT=1
              DJ=DAJNEW(N)
              MEND=JEND(N)
              IF(.NOT.BSTO)THEN
                DJ1=DONE
                DJ2=DONE
                IF(NP0.GT.0)DJ1=DAJNEW(NPARAM+N)
                IF(NP0.EQ.2)DJ2=DAJNEW(2*NPARAM+N)
              ENDIF
              GO TO 1000
            ENDIF
          ENDIF
        ENDIF
      ENDIF
!                                                     .and.mden.le.0
      IF(.NOT.BSTO.AND.DAJNEW(N).EQ.DJ.AND.IPOLFN.EQ.0)GO TO 1100
      IF(BSTO.AND.DJ.NE.DZERO.AND.(N*MCFMX.GT.MCFMX**2.OR.nocc.GT.0))   &
     &   GO TO 1100
!
      DJ=DAJNEW(N)
      DJ0=DJ
      IF(.NOT.BSTO)THEN
        DJ1=DONE
        DJ2=DONE
        IF(NP0.GT.0)DJ1=DAJNEW(NPARAM+N)
        IF(NP0.EQ.2)DJ2=DAJNEW(2*NPARAM+N)
      ENDIF
!
! we pass unique fac potential from sr.radial, saves recomputing and we
! don't need to worry about radial truncating radial mesh.
! (we would get an extra iteration on the potential, but it should be
!  converged. if not, then bound are "wrong" anyway.)
!
      if((nocc.gt.0.or.mhf.eq.2).and.jpot1.eq.1)then
        jpot=1
        go to 1000
      endif
!
      JPOT=2
      CALL DIMUSE('MXPOT',JPOT)
!
      IF(NPOT.GT.0)THEN               !USE R-MATRIX PARAMETRIC POTENTIAL
        CALL POTF(-DZA,MAXRS0,DX,POT(1,JPOT),DTOL,MEND)
        JEND(N)=MEND
        WRITE(MW6,10280)QN(N),MYL,DONE,MEND,DX(MEND)
        GO TO 1000
      ENDIF
!
      MMM=MION1
      DS=DZ
      IF(DJ.GT.DZERO)GO TO 900
      IF(IORT.EQ.2)GO TO 900
      IF(BREL)GO TO 900
!
! FOR HYDROGENIC WAVE FUNCTIONS:  USE FOLLOWING POTENTIAL CALL:
!
! THIS IS NOT SAFE AS USER MAY SET A CORRELATION ORBITAL...
!      DS=DJ*DZA                                 !AS DZA.LT.0
! THIS IS SAFE, BUT USER CANNOT CHANGE ASYMPTOTIC SCREENING...
      DS=-DZA                                    !AS DS.GT.0 HERE
!
      MMM=1
      DJ0=DONE
!
  900 IF(.NOT.BSTO)CALL TFDAPO(DS,MMM,MK,DJ0,DJ1,DJ2,DHNS0,MAXRS0,MJH0, &
     &                         MNH0,DX,POT(1,JPOT),TOL,MEND,CRRCT1,     &
     &                         CRRCT2)                            !,DHNS
!
      IF(BSTO)CALL STOPOT(DS,MMM,MK,DJ0,DHNS0,MAXRS0,MJH0,MNH0,DHNS,DX, &
     &                    POT(1,JPOT),DTOL,MEND,MPP)
!
      IF(NF.LE.0)GO TO 3400                                    !RETURN
!
      IF(DHNS(1).NE.DHNS0)THEN
        WRITE(MW6,10220)MSTEP+1
        GO TO 3500
      ENDIF
!
      JEND(N)=MEND
      IF(BPRNT0)THEN
        IF(BHF)WRITE(MW6,10230)QN(N),MYL,MHF,MEND,DX(MEND)
        IF(.NOT.BSTO.AND..NOT.BHF)THEN
          IF(IEQ(0).EQ.0)THEN
            WRITE(MW6,10240)QN(N),MYL,DJ,MEND,DX(MEND)
            IF(NP0.GT.0)WRITE(MW6,10250)1,DJ1-DONE,CRRCT1           !DJ1
            IF(NP0.EQ.2)WRITE(MW6,10250)2,DJ2-DONE,CRRCT2           !DJ2
          ELSE
            WRITE(MW6,10260)N,IGRCF(N),QN(N),MYL,DJ,MEND,DX(MEND)
          ENDIF
        ENDIF
        NP=N
!        IF(MCFMX.GT.0)NP=MIN(N,MCFMX)
        IF(BSTO.AND..NOT.BHF)WRITE(MW6,10270)QN(N),MYL,MCFSTO(NP),DJ,   &
     &                             MEND,DX(MEND)
      ENDIF
!
! RE-ENTRY POINT IF USING A (DIFFERENT) PRE-EXISTING POTENTIAL
!
 1000 CONTINUE
!
      DO I=1,MAXRS0
        DL2(I)=POT(I,JPOT)
      ENDDO
!
! ADD-IN ANY MODEL POTENTIAL (PLASMA, POLARIZATION, C60 ETC)
!
      ZNP=DX(MAXRS0)*DL2(MAXRS0)
!      write(*,*)dza,znp
!      znp=-dza
!
      MML=MYL
!ORE              IF(BORT.AND.IEQ(MK).GE.MA.AND.IEQ(MK).LE.MB)MML=-MML
      IF(MDEN.GT.2.AND.MPP.GT.1)ZNP0=ZNP
!
      CALL VMPOT(ZNP,MML,MAXRS0,DX,DZ,MAXRS,MPP,-MK,MXORB)
!
      IF(NF.LE.0)GO TO 3400                                     !FAILURE
!
      IF(MDEN.GT.2)MPP=MPP+1
!
      IF(BFOT)THEN
        IF(IDERV.EQ.0)THEN
          IDERV=1
          CALL DIFF(POT(1,JPOT),DERV,MNH0,DHNS,MJH0)
        ENDIF
      ENDIF
!
! NOTE DIFFERENCE OF /COM1/DL2 POTENTIAL TO SR.RADIAL/RADWAV USE.
! (SR.VMPOT ABOVE USES THE SR.RADIAL/RADWAV FORM.)
!
      DO I=1,MAXRS0
        DL2(I)=DL2(I)-DZ/DX(I)                           !SUBTRACT POINT
        DL2(I)=DL2(I)+DL2(I)                             !X2
      ENDDO
!
      IF(BREL)THEN
!
        DO I=1,MAXRS0
          DA(I)=DL2(I)
          DA(I)=DA(I)+DTWO*VSC(I)                        !+PLASMA POT
        ENDDO
!
! SET-UP POTENTIAL DERIVATIVES FOR DARWIN
!
        CALL DIFF(DA,DERV1,MNH0,DHNS,MJH0)
        CALL DIFF(DERV1,DERV2,MNH0,DHNS,MJH0)
!
        DO I=INUKP,MAXRS0                                !ADD POINT BACK
          T=DX(I)**2
          DERV1(I)=DHALF*DERV1(I)-DZ/T
          DERV2(I)=DHALF*DERV2(I)+DTWO*DZ/(T*DX(I))
        ENDDO
!
! ADD-IN FINITE NUCLEUS
!
        DO I=1,INUK
          DERV1(I)=DHALF*DERV1(I)+DNUK1(I)
          DERV2(I)=DHALF*DERV2(I)+DNUK2(I)
!          write(mw6,*)i,dx(i),dnuk(i),derv1(i),derv2(i)
        ENDDO
!
      ELSE
!
        M1=0
        DD=DZERO
!
        CALL FIT(DD,M1,DHNS(1),DL2,ZS(1))
!
        IF(RNUK.GT.DZERO)THEN                 !ADD-IN FINITE NUCLEUS
          DO J=1,JZNM                         !JZNM.LT.MZMN
            ZS(J)=ZS(J)+DTWO*ZS0(J)
          ENDDO
        ENDIF
!
      ENDIF
!
! RE-ENTRY POINT IF POTENTIAL UNCHANGED FROM PREVIOUS CALL TO FCF6
!
 1100 IF(DJ.GT.DZERO.OR.IORT.EQ.2.OR.BREL)THEN     !DW
!
!        MEND=JEND(N)
        if(bort.and.mend.ne.jend(n))stop 'mend.ne.jend'
        if(mend.eq.0)stop 'sr.radcon: mend=0'
!
!
        CALL FCF6(FR,DP0,TM,MYL,DDY,DZ0,DZA,DZERO,DZERO,DZERO,ZS,MZNM,  &
     &            DL2,MEND,MJH0,MNH0,DHNS,DX,GR,MAXRS0)
!
!
        IF(MYL.LT.0)THEN
          WRITE(MW6,*)'*** FCF6 FAILURE...'
          WRITE(MW0,*)'*** FCF6 FAILURE...'
          GO TO 3500
        ENDIF
!
        if(mden.gt.0.and.ddy.eq.dzero)then         !Ryd approx in plasma
          if(bjump)then
            t=2*(duy(inn)-dey(n))
            t=-znp/sqrt(t)                         !dza->-znp
            tm=nnold+t
          else
            tm=dzero
          endif
        endif
!
      ELSE                                         !COULOMBIC
        TM=DZERO
! THIS IS NOT SAFE AS USER MAY SET A CORRELATION ORBITAL...
!        DS=-DJ*DZA                                 !AS DZA.LT.0
! THIS IS SAFE, BUT USER CANNOT CHANGE ASYMPTOTIC SCREENING...
        DS=-ZNP                                     !DZA
!
        CALL FCF4(FR,DP0,DDY,DS,MYL,MJH0,MNH0,DHNS,DX)  !AS DS.LT.0 HERE
!
      ENDIF
!
      IF(MYN.LT.0)WRITE(MW6,10360)MYL,DDY,TM
!
! NOTE DDY OMITTED FROM DQNL(K,I) FOR K=CONTINUUM (MODE.GT.2 ONLY)
! REMEMBER THIS WHEN LOOKING AT RELATIVISTIC INTEGRALS
!
      DD3=DZERO
      IF(DDY.LT.DZERO)DD3=DDY
      IF(BORT.AND.MODE.LE.2)DD3=DDY
!T      IF(BREL)DD3=DZERO
!
      IF(.NOT.BREL2)THEN
        DO I=1,MAXRS0
          GR(I)=(DL2(I)+VSC(I)+DD3)*FR(I)
        ENDDO
      ENDIF
!
      IF(RZERO.GT.DZERO)THEN                           !BOX STATE NORM=1
        IF(BREL2)THEN
          DO I=1,MAXRS0
            DA(I)=FR(I)*FR(I)+GR(I)*GR(I)
          ENDDO
        ELSE
          DO I=1,MAXRS0
            DA(I)=FR(I)*FR(I)
          ENDDO
        ENDIF
!
        CALL WEDDLE(DZERO,DA,DD,MNH0,DHNS,MJH0,MAXRS0) !BOX MAXRS=MAXRS0
!
        DD=SQRT(DD)
        DNORM=DONE/DD
!
        DO I=1,MAXRS0
          FR(I)=DNORM*FR(I)
          GR(I)=DNORM*GR(I)
        ENDDO
        DP0=DNORM*DP0
      ENDIF
!
      DO I=1,MAXRS0
        DPNL(I,N)=FR(I)
        DQNL(I,N)=GR(I)
      ENDDO
!
      IF(MP.GT.0)THEN
        DO I=1,MAXRS0
          WRITE(MW6,10370)I,DX(I),DPNL(I,N),DQNL(I,N)
        ENDDO
      ENDIF
!
      MCF=MCF6
      IF(DJ.LT.DZERO)MCF=MCF4
!
      DD3=DZERO
      IF(.NOT.BORT.AND.MYN.GE.-10.AND.MAUTO.GT.0)GO TO 1300
!
      IF(IRLX.NE.2)THEN
        IF(MORT.EQ.-3)GO TO 1300
!                    .OR..NOT.BSTO
!!cccc          IF(BREL)GO TO 1300
        IF(KORT.NE.0.AND.QN(N).LT.0)GO TO 1300  !NON-ORTHOG RYDBERG/CONT
      ENDIF
!
! ORTHOGONALIZE (USING SCHMIDT PROCEDURE)
! ONLY ATTEMPT TO ORTHOG TO FUNCTIONS K .LT. N
!
      K1=1                                   !LOWER ORB BOUND FOR ORTHOG
      K2=N                                   !UPPER ORB BOUND FOR ORTHOG
!
      if(ieq(0).ne.0.and.irlx.ne.2)then         !FIND ORB GROUP BOUNDARY
        ng=igrcf(n)
        k1=mxborb*(ng-1)+mb0+1
        k2=k1+mxborb-1
!       write(mw0,*)'orthog',ng,':',k1,k2,n
      endif
!
      DO K=1,N   !K2?
!
        IF(2*MYL.NE.QL(K))GO TO 1200
        IF(DORIGZ(K).EQ.DZERO)GO TO 1200
        IF(K.LT.K1.AND.K.GT.MB0)GO TO 1200             !CASE IEQ(0).GT.0
        IF(K.GT.K2.AND.K.LT.N)GO TO 1200               !CASE IEQ(0).GT.0
        IF(IRLX.EQ.2.AND.K.NE.N.AND.QN(K).EQ.QN(N))THEN
          KKK=((N-1)*(N-2))/2+K
          OVLPGR(KKK)=DONE
          GO TO 1200
        ENDIF
!
! AVOID TRYING TO ORTHOG TO CONTINUUM WAVEFUNCTION
!
        IF(QN(K).LT.0)GO TO 1200
!
! AVOID ORTHOG TO CORRELATION ORBITAL (except box orbitals)
!
        IF(BORT.and.DAJNEW(K).LT.DZERO.and.RZERO.LE.DZERO)GO TO 1200
!
! AVOID ORTHOG TO VALENCE ORBITAL DURING DR OPERATION
!
        IF(BDR.AND.IVAL(K).GT.0)GO TO 1200    !IVAL(K).GT.0 IMPLIES BDR?
!
        IF(BREL2)THEN
          DO I=1,MAXRS
            DA(I)=DPNL(I,K)*DPNL(I,N)+DQNL(I,K)*DQNL(I,N)
          ENDDO
        ELSE
          DO I=1,MAXRS
            DA(I)=DPNL(I,K)*DPNL(I,N)
          ENDDO
        ENDIF
!
        CALL WEDDLE(DZERO,DA,DD,MNH,DHNS,MJH,MAXRS)
!
        I=QL(K)/2
        IF(BPRNT0)WRITE(MW6,10310)QN(N),MYL,QN(K),I,DD
!        if(rzero.gt.0)go to 63
!
        IF(IRLX.EQ.2)THEN
          KKK=((N-1)*(N-2))/2+K
          OVLPGR(KKK)=DD
          GO TO 1200
        ENDIF
!
        DO I=1,MAXRS0
          DPNL(I,N)=DPNL(I,N)-DD*DPNL(I,K)
          DQNL(I,N)=DQNL(I,N)-DD*DQNL(I,K)
        ENDDO
!
        DP0=DP0-DD*DORIGZ(K)/DZ
!       DD3=DZERO FOR MODES 1&2,=SUM OVRLAP**2 FOR MODE GT 2 (CONTINUUM)
        IF(DDY.GE.DZERO.AND.MODE.GT.2)DD3=DD3+DD*DD
!
 1200 ENDDO
!
!
 1300 DNORM=DONE
      IF(DP0.LT.DZERO)THEN
!        WRITE(MW6,781 N,(DPNL(M,N),M=1,50)
!        DNORM=-DNORM
!        TM=TM+DONE                                !FOR ASSX
!        WRITE(MW6,781)
        IF(DDY.NE.DZERO)GO TO 1400
      ENDIF
!
      IF(DDY.GT.DZERO.and.RZERO.LE.DZERO)GO TO 1500
      IF(DDY.EQ.DZERO)THEN
        DNORM=MNN
        DNORM=DNORM-TM
        DNORM=ZNP*ZNP/(PIH*DNORM**3)                   !DZA*DZA
        DNORM=SQRT(DNORM)
!        IF(DP0.LT.DZERO)DNORM=-DNORM
!        dnorm=1             !<<<<<<<<<<<<<<<<<<<<<<<<<<<<TEST CONT-CONT
      ENDIF
 1400 MAXTS=MAXRS
!
      IF(RZERO.GT.DZERO)THEN                           !BOX STATE NORM=1
        IF(BREL2)THEN
          DO I=1,MAXRS0
            DA(I)=DPNL(I,N)*DPNL(I,N)+DQNL(I,N)*DQNL(I,N)
          ENDDO
        ELSE
          DO I=1,MAXRS0
            DA(I)=DPNL(I,N)*DPNL(I,N)
          ENDDO
        ENDIF
!
        CALL WEDDLE(DZERO,DA,DD,MNH0,DHNS,MJH0,MAXRS0) !BOX MAXRS=MAXRS0
!
        DD=SQRT(DD)
        IF(DNORM.LT.DZERO)DD=-DD
        DNORM=DONE/DD
        IF(BPRNT0)WRITE(MW6,10320)QN(N),MYL,DNORM
      ENDIF
!
      DO M=1,MAXRS0
        DD1=DNORM*DPNL(M,N)
        IF(ABS(DD1).GT.TOLR)MAXTS=MAX(M,MAXTS)
!        FR(M)=FR(M)*DNORM
        DPNL(M,N)=DD1
        DQNL(M,N)=DNORM*DQNL(M,N)
      ENDDO
!
      IF(DDY.LT.DZERO)MAXRS=MAXTS
      DP0=DNORM*DP0
!
 1500 DORIG(N)=DP0
      DORIGZ(N)=DP0*DZ
!
      IF(MYN.LT.0)WRITE(MW6,10010)DDY,MCF,MP,MNN,MYL
!
      KN=N
      IF(BJUMP)KN=MXORB
!
! EVALUATE SOME ONE-BODY INTEGRALS
!
      DO K=1,KN
!
        DD2=DZERO    !INITIALIZE ALL FOR SAFETY AS NANs CAN BE ALLOCATED
!
        IF(QL(K).NE.QL(N))GO TO 1650
        IF(DORIGZ(K).EQ.DZERO)GO TO 1650
        IF(IYY(K).GT.0.AND.DDY.GT.DZERO.AND.MODE.LE.2)GO TO 1650
!
! must uncomment skip if calculating "duy" in sr.slatr - see also slatri
!t        if(kort.lt.0.and.ddy.gt.dzero.and.ival(k).gt.0)go to 1650!c-ry
!
        IF(.NOT.BORT.AND.MAUTO.GT.0)GO TO 1550
! C.F. SR.RADIAL
        IF(BREL2)GO TO 1550                                        !BREL
        IF(MORT.EQ.-3.AND.BREL)GO TO 1550
!
        IF(K.LT.N)THEN
          L1=K
          L2=N
        ELSE
          L1=N
          L2=K
        ENDIF
!
        IF(BDR.AND.IVAL(L1).GT.0.AND..NOT.BJUMP.AND..NOT.BREL)THEN
          IF(ABS(DADJUS(N)-DADJUS(K)).GT.D1M3)THEN
            WRITE(MW6,10290)K,DADJUS(K),N,DADJUS(N)
            WRITE(MW0,*)'*** ATTENTION: RYDBERG AND CONTINUUM ',        &
     &                  'ORBITALS ARE NOT ORTHOGONAL!'
          ENDIF
        ENDIF
!
! MUST ENSURE THAT USE DQNL(*,L1) FOR VALENCE ELECTRON WHEN APPROXIMATED
! BY A CONTINUUM SINCE THIS HAS EPSILON=0 AND WE MUST ONLY EVALUATE
! SHORT-RANGE AND 1/R CONTRIBUTIONS, 1/R CANCELS WITH SLATER
! INTEGRALS C.F. SCATTERING PROBLEM BUT ELEMENTS OFF-DIAGONAL IN
! ENERGY NOW EXIST.
!
        DO I=1,MAXRS
          DA(I)=DQNL(I,L1)*DPNL(I,L2)
!t          da(i)=dqnl(i,l2)*dpnl(i,l1)
!t          da(i)=(dqnl(i,l1)-2*dey(l1)*dpnl(i,l1))*dpnl(i,l2)
        ENDDO
        IF((MDEN.EQ.11.OR.MDEN.EQ.1.AND.NPITER.LT.0).AND.DENE.GT.DZERO) &
     &     THEN                                                !PERT DH1
          DO I=1,MAXRS
            T=EXP(-DX(I)/DEBYE)
            DA(I)=DA(I)+DTWO*DPNL(I,L1)*DPNL(I,L2)*(DONE-T)*DZ/DX(I)
          ENDDO
        ELSE
          DO I=1,MAXRS
            DA(I)=DA(I)-DTWO*DPNL(I,L1)*DPNL(I,L2)*VSC(I)
          ENDDO
        ENDIF
        IF(MPSEUD.NE.0)THEN
          DO I=1,MAXRS
            DA(I)=DA(I)+DTWO*DPNL(I,L1)*DPNL(I,L2)*(DZ/DX(I)-POTHAM(I))
          ENDDO
        ENDIF
        GO TO 1600
!
! BREL2 REALLY REQUIRES SMALL OVERLAPS SINCE USES UNMODIFIED POTENTIAL
!
 1550   IF(BREL2)THEN
          DO I=1,MAXRS
            DD2=DPNL(I,K)*DPNL(I,N)+DQNL(I,N)*DQNL(I,K)
            DA(I)=DD2*DL2(I)
          ENDDO
        ELSE
          DO I=1,MAXRS
            DA(I)=DPNL(I,K)*DPNL(I,N)*DL2(I)
          ENDDO
        ENDIF
        IF((MDEN.EQ.11.OR.MDEN.EQ.1.AND.NPITER.LT.0).AND.DENE.GT.DZERO) &
     &     THEN                                                !PERT DH1
          DO I=1,MAXRS
            T=EXP(-DX(I)/DEBYE)
            DA(I)=DA(I)+DTWO*DA(I)*((DONE-T)*DZ/DX(I)+VSC(I))/DL2(I)
          ENDDO
!        ELSEIF(MDEN10.EQ.2)THEN                           !IS NO 2-BODY
        ENDIF
        IF(MPSEUD.NE.0)THEN
          DO I=1,MAXRS
            DA(I)=DA(I)+DTWO*DA(I)*(DZ/DX(I)-POTHAM(I))/DL2(I)
          ENDDO
        ENDIF
!
 1600   CALL WEDDLE(DZERO,DA,DD,MNH,DHNS,MJH,MAXRS)
!
        DD2=DD/DTWO
        DD2=DD2*SCALER                   !C.F. COWAN SLATER SCALE FACTOR
!
 1650   KX=MIN(N,K)
        KY=MAX(N,K)
        IN=ICOL(KX,KY,IZERO)
!
        DUY(IN)=DD2                                                 !93
!
        IF(BMVDR)DCD(IN)=DZERO
!        DCD(K,N)=DZERO
!
      ENDDO
!
! UPDATE ONE-BODY ENERGY
!
      IF(DDY.LT.DZERO)THEN           !NOT ACTIVE
!
        DDY=DDY/DTWO                 !RYD TO A.U. FOR BOUND
!T           (BREL).OR.
        IF((.NOT.BORT.AND.MAUTO.GT.0))DUY(INN)=DUY(INN)+DDY*SCALER
        DEY(N)=DUY(INN)
        DUY(INN)=DUY(INN)-DDY*SCALER
!
        WRITE(MW6,*)'*** SR.RADCON: ENERGY .LT. 0 !',N
        WRITE(MW0,*)'*** SR.RADCON: ENERGY .LT. 0 !'
        GO TO 3500
!
      ELSEIF(DDY.EQ.DZERO)THEN       !RYDBERG APPROX BY K=0 CONT
!
        DD1=MNN
        DD1=DD1-TM
        DDY=ZNP/DD1                  !DZA
        DDY=DDY*DDY                  !COULOMB
        IF(BREL)THEN
          T=DTWO*DD1/(QL(N)+1)-DTHREE/DFOUR
          TMV=T*DDY*DDY              !M-V
          IF(QL(N).EQ.0)THEN         !DARWIN
            TT=-znp/DD1              !DZ0->dza->-znp since large n
            TT=TT*TT
            TD=-TT*TT*DD1
          ELSE
            TD=DZERO
          ENDIF
          T=(TMV+TD)*DALF
!          write(mw6,*)-ddy/2,-tmv*dalf/2,-td*dalf/2,-t/2
          if(ddy+t.lt.dzero)t=dzero  !use non.rel.
          DDY=DDY+T
        ENDIF
        DDY=-DDY/DTWO                !BOUND A.U. NON-HYDROGENIC
        IF(BDR)DSHIFT(N)=-DDY        !IMPLICIT RYD SHIFT (INTERP.)
        DEY(N)=DUY(INN)+DDY
!
!        if(irlx.ne.0.and.ieq(n).ne.ieq(kstore))then
!          write(mw0,*)'we have more than one ryd orbital?'
!        endif
!
        if(qed.ne.0)then             !just re-scale old bound
          factn=nnold
          factn=(factn-tm)/dd1
          factn=factn**3
          vpint(n)=vpint(n)*factn
          slfint(n)=slfint(n)*factn
        endif
!
      ELSE                           !DDY.GT.DZERO
!
        MINK=0
        DD1=-MSHIFT*MINK
        DDY=DDY-DSHIFT(N)*DTWO       !CONTINUUM RYD
        DEY(N)=DUY(INN)+DD1+DDY*(DONE+DD3)/DTWO
        IF(DEY(N).EQ.DZERO)DEY(N)=D1M10
        DUY(INN)=DUY(INN)+DDY*DD3/DTWO
!
      ENDIF
!
      IF(MYN.LT.0)WRITE(MW6,10050)N,QN(N),MYL,MION1,NZION,TM,MR5,DP0,   &
     &                            DX(MAXRS0),DZERO,                     &
     &                            (DPNL(I,N),I=II,MAXRS0),DEY(N)
!
      SCREEN(N)=TM
!
! TEST HERE EVALUATION OF SPIN-ORBIT: WITH FULL POTENTIAL IN SMALL-R
! CORRECTION FOR FULL RELATIVISTIC WAVEFUNCTIONS, SINCE WE ONLY RETAIN
! DIAGONAL IN NL AND CORRECTION DEPENDS ON E-V, AND/OR POTENTIAL
! DERIVATIVE - DO NOT USE CLOSED SHELLS THEN!
! STORED TEMPORARILY IN DARWIN ARRAY DCD.
! ***SEE ALSO SOCC TO SWITCH-OFF CALCULATION THERE.
!
      IF(DDY.LT.DZERO)THEN              !REL. SPIN-ORBIT FOR K=0 NL
        IF(.NOT.BREL2.OR.QL(N).EQ.0)GO TO 600   !TEST: IF(.NOT.BREL)
        IF(BREL2)THEN
          DO I=1,MAXRS
            GR(I)=DPNL(I,N)*DPNL(I,N)+DQNL(I,N)*DQNL(I,N)
            DA(I)=DONE+DALF*(DDY+POT(I,JPOT))/DTWO
          ENDDO
        ELSE
          DO I=1,MAXRS
            GR(I)=DPNL(I,N)*DPNL(I,N)
            DA(I)=DONE+DALF*(DQNL(I,N)/DPNL(I,N)+DTWO*DZ/DX(I))/DFOUR
          ENDDO
        ENDIF
        IF(IREL.GE.0)THEN               !NUCLEAR
          DO I=1,MAXRS
            GR(I)=GR(I)/(DX(I)*DX(I)*DX(I))
            GR(I)=GR(I)/DA(I)
          ENDDO
        ELSE                            !POTENTIAL DERIV
          DO I=1,MAXRS
            GR(I)=GR(I)*DERV1(I)/DX(I)
            GR(I)=GR(I)/DA(I)
          ENDDO
        ENDIF
        DD1=DZERO
        CALL WEDDLE(DZERO,GR,DD3,MNH,DHNS,MJH,MAXRS)
        IF(IREL.LT.0)DD3=-DD3/(2*DZ)    !POTENTIAL DERIV
        IF(BMVDR)THEN
          IN=ICOL(N,N,IZERO)
          DCD(IN)=DALF*DD3/DFOUR
        ENDIF
        GO TO 600                   !GO BACK-UP TO GENERATE NEXT ORBITAL
      ENDIF
!
! SET UP ARRAY NRLI FOR CASE BLAG=FALSE
!
      ICOUNT=1
      IF(.NOT.BLAG)GO TO 2500
!
!-----------------------------------------------------------------------
! CALCULATE CONTINUUM ORBITALS AT INTERPOLATION ENERGIES
!-----------------------------------------------------------------------
!
      ICOUNT=0
 1700 ICOUNT=ICOUNT+1
!
      IF(ICOUNT.EQ.NREL)THEN
        IF(BFOT.AND.BLAG)THEN
          DDY=2*DYY(NREL)                     !A.U. TO RYD
          CALL RK4PI(NREL,N,M8,FR,GR,TM)      !JUST GET GAUGE
        ENDIF
        ICOUNT=ICOUNT+1
      ENDIF
      IF(ICOUNT.GT.MENG)GO TO 600
!
      DDY=DYY(ICOUNT)+DSHIFT(N)
      DDY=DDY+DDY                             !A.U. TO RYD
!
      IF(DJ.GT.DZERO.OR.IORT.EQ.2.OR.BREL)THEN      !DW
!        MEND=JEND(N)
        if(bort.and.mend.ne.jend(n))stop 'mend.ne.jend on interp'
        if(mend.eq.0)stop 'sr.radcon: mend=0 on interp'
!
!
        CALL FCF6(FR,DP0,TM,MYL,DDY,DZ0,DZA,DZERO,DZERO,DZERO,ZS,MZNM,  &
     &            DL2,MEND,MJH0,MNH0,DHNS,DX,GR,MAXRS0)
!
!
        IF(MYL.LT.0)THEN
          WRITE(MW6,*)'*** FCF6 FAILURE...'
          WRITE(MW0,*)'*** FCF6 FAILURE...'
          GO TO 3500
        ENDIF
!
      ELSE                                          !COULOMBIC
        TM=DZERO
!
        CALL FCF4(FR,DP0,DDY,DZA,MYL,MJH0,MNH0,DHNS,DX)
!
      ENDIF
!
      IF(.NOT.BREL2)THEN
        DO I=1,MAXRS0                                  !MAXRS WRONG
          GR(I)=(DL2(I)+DDY)*FR(I)
        ENDDO
      ENDIF
!
      IF(MYN.LT.0)WRITE(MW6,10360)MYL,DDY,TM
!
      IF(.NOT.BORT)GO TO 1900
!
      IF(IRLX.NE.2)THEN
        IF(MORT.EQ.-3)GO TO 1900
!                    .OR..NOT.BSTO
!!cccccc        IF(BREL)GO TO 1900
!
        IF(KORT.NE.0.AND.QN(N).LT.0)GO TO 1900  !NON-ORTHOG RYDBERG/CONT
      ENDIF
!
      DO K=1,N  !K2?
!
        IF(2*MYL.NE.QL(K))GO TO 1800
        IF(DORIGZ(K).EQ.DZERO)GO TO 1800
        IF(K.LT.K1.AND.K.GT.MB0)GO TO 1800             !CASE IEQ(0).GT.0
        IF(K.GT.K2.AND.K.LT.N)GO TO 1800               !CASE IEQ(0).GT.0
        IF(IRLX.EQ.2.AND.K.NE.N.AND.QN(K).EQ.QN(N))THEN
          KKK=((N-1)*(N-2))/2+K
          OVLPGR(KKK)=DONE
          GO TO 1800
        ENDIF
        IF(QN(K).LT.0)GO TO 1800                 !NO ORTHOG TO CONTINUUM
        IF(DAJNEW(K).LT.DZERO.and.RZERO.LE.DZERO)GO TO 1800 !NOT TO CORR
        IF(BDR.AND.IVAL(K).GT.0)GO TO 1800         !NO ORTHOG TO VALENCE
!
        IF(BREL2)THEN
          DO I=1,MAXRS
            DA(I)=DPNL(I,K)*FR(I)+DQNL(I,K)*GR(I)
          ENDDO
        ELSE
          DO I=1,MAXRS
            DA(I)=DPNL(I,K)*FR(I)
          ENDDO
        ENDIF
!
        CALL WEDDLE(DZERO,DA,DD,MNH,DHNS,MJH,MAXRS)
!
        DO I=1,MAXRS0
          FR(I)=FR(I)-DD*DPNL(I,K)
          GR(I)=GR(I)-DD*DQNL(I,K)
        ENDDO
        DP0=DP0-DD*DORIGZ(K)/DZ
!
 1800 ENDDO
!
      DNORM=DONE
      IF(DP0.LT.DZERO)THEN
!        DNORM=-DNORM
!        WRITE(MW6,781)N,(FR(I),I=1,50)
!        WRITE(MW6,781)
!        TM=TM+DONE                                    !FOR ASSX
      ENDIF
!
      IF(RZERO.GT.DZERO)THEN                           !BOX STATE NORM=1
        IF(BREL2)THEN
          DO I=1,MAXRS0
            DA(I)=FR(I)*FR(I)+GR(I)*GR(I)
          ENDDO
        ELSE
          DO I=1,MAXRS0
            DA(I)=FR(I)*FR(I)
          ENDDO
        ENDIF
!
        CALL WEDDLE(DZERO,DA,DD,MNH0,DHNS,MJH0,MAXRS0) !BOX MAXRS=MAXRS0
!
        DD=SQRT(DD)
        IF(DNORM.LT.DZERO)DD=-DD
        DNORM=DONE/DD
      ENDIF
!
      IF(DNORM.NE.DONE)THEN
        DO I=1,MAXRS0
          FR(I)=DNORM*FR(I)
          GR(I)=DNORM*GR(I)
        ENDDO
        DP0=DNORM*DP0
      ENDIF
!
 1900 DM=-MSHIFT*MINK
      DM=DM+DDY/DTWO-DSHIFT(N)
!
      IF(MYN.LT.0)WRITE(MW6,10010)DDY,MCF,MP,MNN,MYL
!
!
      IF(MYN.LT.0)WRITE(MW6,10050)N,QN(N),MYL,MION1,NZION,TM,MR5,DP0,   &
     &                            DX(MAXRS0),DZERO,(FR(I),I=II,MAXRS0), &
     &                            DM
!
      IF(BDR)THEN
        WRITE(MRW11)TM,MAXRS0
        WRITE(MRW11)(FR(I),I=1,MAXRS0),(GR(I),I=1,MAXRS0),              &
     &              (DL2(I),I=1,MAXRS0)
      ENDIF
      GO TO 2500
!
!-----------------------------------------------------------------------
! IDENTIFY AND RECOVER CONTINUUM INTERPOLATION ORBITALS DURING DR
! AND ZERO-OUT INTEGRAL ARRAYS FOR RECOMPUTATION.
! (SO ANY EXPLICIT DSHIFT(N)=DZERO HERE.)
!-----------------------------------------------------------------------
!
 2000 IF(.NOT.BCONT)GO TO 2600
!
      DO J=1,IRL                    !SLATER
        KP=NRLI(J)
        IF(KP.GT.0)THEN
          M=0
          DO I=1,4
            N=QRL(I,J)
            IF(N.GT.0)M=M+IVAL(N)
          ENDDO
          IF(M.NE.0)THEN
            DO I=1,MENG
              DRLI(I,KP)=DZERO
            ENDDO
          ENDIF
        ENDIF
      ENDDO
!
      DO J=1,NL000                 !FS
        KP=NLI(J)
        IF(KP.GT.0)THEN
          M=0
          DO I=1,4
            N=QSS(I,J)
            M=M+IVAL(N)
          ENDDO
          IF(M.NE.0)THEN
            DO I=1,MENG
              DNLI(I,KP)=DZERO
            ENDDO
          ENDIF
        ENDIF
      ENDDO
!
      IF(.NOT.BLAG)GO TO 2600
!
!
      IF(ALLOCATED(FR))DEALLOCATE(FR,GR)           !CASE RYD APPROX CONT
!
      REWIND(MRW11)
      READ(MRW11)TM,MXREAD
      BACKSPACE(MRW11)
!
!      write(mw0,*)maxrs,maxrs0,mxread
!
      ALLOCATE(FR(MXREAD),GR(MXREAD),STAT=IERR)
      MAXRS0=MXREAD
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RADCON: ALLOCATION FAILS FOR FR,GR'
        NF=0
        RETURN
      ENDIF
!
      K9=1
 2100 IF(K9.GT.MXORB)GO TO 2600
!
      DO K=K9,MXORB
        IF(DEY(K).EQ.DZERO)GO TO 2200
        IF(IVAL(K).GT.0)GO TO 2200
        IF(QN(K).GT.0)GO TO 2200
        N=K
        GO TO 2300
 2200 ENDDO
      GO TO 2600
!
 2300 ICOUNT=0
      K9=N+1
!
 2400 ICOUNT=ICOUNT+1                         !START RECOVERY LOOP
!
      IF(ICOUNT.EQ.NREL)THEN
        IF(BFOT.AND.BLAG)THEN
          DDY=DYY(NREL)*DTWO                  !A.U. TO RYD
          CALL RK4PI(NREL,N,M8,FR,GR,TM)      !JUST GET GAUGE
        ENDIF
        ICOUNT=ICOUNT+1
      ENDIF
      IF(ICOUNT.GT.MENG)GO TO 2100
!
      READ(MRW11)TM,MXREAD
!
      if(mxread.gt.maxrs0)then
        stop 'sr.radcon: mesh mis-match'      !should not be
      endif
!
      READ(MRW11)(FR(I),I=1,MXREAD),(GR(I),I=1,MXREAD),                 &
     &           (DL2(I),I=1,MXREAD)
!
!---------------------------------------------------------
! *** EVALUATE BOUND-CONTINUUM INTERPOLATION INTEGRALS ***
!---------------------------------------------------------
!
 2500 CONTINUE                                     !ENTRY FOR FIRST PASS
!
! *** PI DIPOLE INTEGRALS
!
      IF(BFOT.AND.BLAG)THEN
!
        CALL RK4PI(ICOUNT,N,M8,FR,GR,TM)
!
        IF(NF.EQ.0)GO TO 3400
        IF(M8.GT.IXD24.OR.M8.LT.0)THEN
          IF(M8.GT.IXD24)WRITE(MW6,10210)IXD24,M8        !ALGEB2 CATCHES
          GO TO 3500
        ENDIF
      ENDIF
!
! *** SLATER INTEGRALS AND (IF BKUTOO)
!     2-BODY NON-FINE STRUCTURE INTEGRALS.
!
      CALL SLATRI(ICOUNT,N,KK,FR,GR,TM)
!
      IF(NF.EQ.0)GO TO 3400
      IF(KK.GT.IXFSL.OR.KK.LT.0)THEN
        IF(KK.GT.IXFSL)WRITE(MW6,10030)KK
        GO TO 3500
      ENDIF
!
      IF(KK.GT.0)THEN                                   !UPDATE
        CALL DIMUSE('MXFSL',KK)
        IF(BKUTOO)CALL DIMUSE('MXFOO',KK)
      ENDIF
!
! *** 2-BODY FINE-STRUCTURE INTEGRALS
!
      IF(NL000.GT.0)THEN
!
        CALL FSINTI(ICOUNT,N,KFS,FR,GR)
!
        IF(NF.EQ.0)GO TO 3400
        IF(KFS.GT.IXFSS.OR.KFS.LT.0)THEN
          IF(KFS.GT.IXFSS)WRITE(MW6,10040)KFS
          GO TO 3500
        ENDIF
!
        IF(KFS.GT.0)CALL DIMUSE('MXFSS',KFS)            !UPDATE
      ENDIF
!
!-----------------------------------------------------------------------
!
      IF(BJUMP)GO TO 2400
      GO TO 1700
!
! CHECK COMPLETENESS OF RADIAL FUNCTION SET
! COMPUTE RELATIVISTIC INTEGRALS (MASS AND DARWIN TERM, EJN-EQ.60)
! D2LL(K,L) IS USED BY SR.ALGEB4 WHICH EVALUATES THE BREIT-PAULI
! MODIFICATION OF THE M1 OPERATOR FOR USE BY SR.DIAGFS .
!
 2600 MP=0
      ICM=10000000
      IBM=0
      IF(BCONT)THEN
        DDY=DYY(NREL)                                   !ALWAYS A.U. NOW
!OLD        IF(.NOT.BJUMP)DDY=DDY/DTWO    !RYD TO A.U. ELSE ALREADY A.U.
      ELSE
        DDY=DZERO                                       !NOT USED
      ENDIF
!
      DO K=1,MXORB
!
        IF(DEY(K).EQ.DZERO)GO TO 2800
        MP=K
        IF(IYY(K).GT.0.AND.K.LT.ICM)ICM=K
        IF(IVAL(K).EQ.0.AND.QN(K).GT.0.AND.IBM.LT.K)IBM=K
!
        IF(SCREEN(K).GT.D999)THEN
          WRITE(MW6,10340)K
          DEY(K)=DZERO
          NF=-1
          GO TO 2800
        ELSEIF(SCREEN(K).EQ.D999)THEN
          WRITE(MW6,10330)K
        ENDIF
!
        IF(NJO.LE.0.AND..NOT.BMVD.or.qn(k).gt.0)GO TO 2800
!
        DORIGZ(K)=DORIG(K)*DZ
        IF((MAUTO.EQ.0.OR.BORT).AND..NOT.BREL)GO TO 2700
!           SR.RADWIN ACCESSED
!
        INK=ICOL(K,K,IZERO)
        DX1=DZERO
        IF(IYY(K).LT.0)DX1=DEY(K)-DUY(INK)
        IF(IYY(K).GT.0)DX1=DDY+DSHIFT(K)               !A.U.
!
        tz=dzero
        IF(.NOT.BORT)THEN
          JPOT=QL(K)/2+1
          IF(JPOT.GT.IXPOT)JPOT=IXPOT
        ELSE
          JPOT=1                                     !RYD APPROX BY CONT
          if(igagr.gt.0)tz=nzion-mion1+1
        ENDIF
!
        DO L=1,K
!
          DD3=DZERO  !INITIALIZE ALL FOR SAFETY AS NANs CAN BE ALLOCATED
          DD2=DZERO
          DD1=DZERO
!
          IF(DEY(L).EQ.DZERO)GO TO 2620                             !613
          IF(QL(K).NE.QL(L))GO TO 2620                              !613
          M=IVAL(L)+IVAL(K)
          IF(BJUMP.AND.M.EQ.0)GO TO 2650
          IF(BJUMPR.OR.BREL.AND.NL.LE.NL000)GO TO 2620
!                                      .AND.L.EQ.K .OR.BREL2
          IMT=0
          IF(IYY(K).GT.0)IMT=IMT+1
          IF(IYY(L).GT.0)IMT=IMT+1
          IF(MODE.LE.2.AND.IMT.GE.1)GO TO 2620
!
          INL=ICOL(L,L,IZERO)
          DX2=DZERO
          IF(IYY(L).LT.0)DX2=DEY(L)-DUY(INL)
          IF(IYY(L).GT.0)DX2=DDY+DSHIFT(L)
!
          DO I=1,MAXRS
            DA(I)=DPNL(I,L)*(POT(I,JPOT)-tz/dx(i))*DPNL(I,K)
          ENDDO
          IF(BREL2)THEN
            DO I=1,MAXRS
              DA(I)=DA(I)+DQNL(I,K)*(POT(I,JPOT)-tz/dx(i))*DQNL(I,L)
            ENDDO
          ENDIF
!
          CALL WEDDLE(DZERO,DA,DD3,MNH,DHNS,MJH,MAXRS)
!
          IF(.NOT.BREL)THEN        !EVALUATE INTEGRAND AT ORIGIN
            IF(QL(K).EQ.0)DD2=DORIGZ(K)*DORIGZ(L)
!
            DO I=1,MAXRS
              DPA(I)=DA(I)*POT(I,JPOT)
            ENDDO
!
            CALL WEDDLE(DZERO,DPA,DD1,MNH,DHNS,MJH,MAXRS)
!
            DD1=DD1+(DX1+DX2)*DD3
            IF(L.EQ.K)DD1=DD1+DX1*DX2
            DD2=DD2*DFSC*DFSC/(DZ*DEIGHT)
          ENDIF
!
          DD1=-DD1*DFSC*DFSC/DTWO
          IF(L.EQ.K)DD3=DX1+DD3
!
 2620     IN=ICOL(L,K,IZERO)
!
          IF(BMVDR)DMASS(IN)=DD1          !N.B. SWAPPED DMASS, DCD ORDER
          IF(BMVDR)DCD(IN)=DD2
          IF(B2LL)D2LL(IN)=DD3+DD3
!
 2650   ENDDO
!
        GO TO 2800
!
! CASE NON-RELATIVISTIC RADIAL FUNCTIONS
!
 2700   DX1=DZERO
        IF(MODE.GT.2.AND.IYY(K).GT.0)DX1=(DDY+DSHIFT(K))*DTWO       !RYD
!
        DO L=1,K
!
          DP0=DZERO  !INITIALIZE ALL FOR SAFETY AS NANs CAN BE ALLOCATED
          DD=DZERO
          DM=DZERO
!
          IF(DEY(L).EQ.DZERO)GO TO 2720                              !53
          IF(QL(K).NE.QL(L))GO TO 2720                               !53
          M=IVAL(K)+IVAL(L)
          IF(BJUMP.AND.M.EQ.0)GO TO 2750
          IF(BJUMPR)GO TO 2720                              !.OR.BREL
!                  .AND.L.EQ.K                              !.OR.BREL2
          IF(MORT.EQ.-3)GO TO 2720                          !.AND.BREL
!
          IMT=0
          IF(IYY(K).GT.0)IMT=IMT+1
          IF(IYY(L).GT.0)IMT=IMT+1
          IF(MODE.LE.2.AND.IMT.GE.1)GO TO 2720
!
          DX2=DZERO
          IF(MODE.GT.2.AND.IYY(L).GT.0)DX2=(DDY+DSHIFT(L))*DTWO     !RYD
!
          DO I=1,MAXRS
            DD3=DTWO*DZ/DX(I)
            DD2=DPNL(I,L)*(DD3+DX2)+DQNL(I,L)
            DD1=DPNL(I,K)
            DA(I)=(DD1*(DD3+DX1)+DQNL(I,K))*DD2
            DPA(I)=DD1*DD2
            IF(QN(K).LT.0.AND.QN(L).LT.0)THEN
              DD0=DX2*DPNL(I,L)*DPNL(I,K)
              DA(I)=DA(I)-DX1*DD0
              DPA(I)=DPA(I)-DD0
            ENDIF
          ENDDO
!
          CALL WEDDLE(DZERO,DPA,DP0,MNH,DHNS,MJH,MAXRS)
!
          IF(K.EQ.L)DP0=DP0+DX2
!
          IF(QL(K).EQ.0.AND..NOT.BREL)DD=DORIGZ(K)*DORIGZ(L)
          DD3=DD*DFOUR
!
          CALL WEDDLE(DD3,DA,DM,MNH,DHNS,MJH,MAXRS)
!
          IF(L.EQ.K)DM=DM+DX1*DX2
          DM=-DM*DFSC*DFSC/DEIGHT
          DD=DD*DFSC*DFSC/(DZ*DEIGHT)
!
 2720     IN=ICOL(L,K,IZERO)
!
          IF(BMVDR)DMASS(IN)=DM           !N.B. SWAPPED DMASS, DCD ORDER
          IF(BMVDR)DCD(IN)=DD
          IF(B2LL)D2LL(IN)=DP0
!
 2750   ENDDO
!
 2800 ENDDO
!
!
      IF(BJUMP)GO TO 3400
      if(ieq(0).gt.0)go to 3100
!test      IF(MORT.EQ.-3)GO TO 126
      IF(ICM.GT.IBM)GO TO 2900
      WRITE(MW6,10180)IBM,ICM
      GO TO 3500
!
 2900 IF(IVP.LT.ICM)GO TO 3000
      WRITE(MW6,10190)IVP,ICM
      GO TO 3500
!
 3000 IF(IBM.LT.IVM)GO TO 3100
      WRITE(MW6,10200)IBM,IVM
      GO TO 3500
!
 3100 CONTINUE
!
      IF(NF.LE.0)GO TO 3400
!
! RESTORE RETURNED POTENTIAL TO SR.RADIAL/RADWAV NORM.
!
      DO I=1,MAXRS0
        DL2(I)=DL2(I)/DTWO                               !/2
        DL2(I)=DL2(I)+DZ/DX(I)                           !ADD POINT
      ENDDO
!
! PRINT SOME INFO
!
      IF(.NOT.BPRNT0)GO TO 3200
      IF(II.GT.1.AND.MYN.LT.0)WRITE(MW6,10060)(DX(I),I=II,MAXRS0)
!
      IF(MODE.LT.2)THEN
        WRITE(MW6,10160)
        GO TO 3300
      ENDIF
!
      IF(BLAG)THEN
        WRITE(MW6,10110)MAUTO,MODE,ACE*2,NLAG,IXFSL,KK
        IF(BKUTOO)WRITE(MW6,10120)IXFOO,KK
        IF(NL000.GT.0)WRITE(MW6,10130)IXFSS,KFS
        WRITE(MW6,10090)MENG,NREL
        F588='(10(I4,F9.3))'
        IF(2*DYY(MENG).GE.1.D5)F588='(10(I4,F10.2))'
        IF(2*DYY(MENG).GE.1.D6)F588='(10(I4,F11.1))'
        IF(2*DYY(MENG).GE.1.D7)F588='(10(I4,F12.0))'
        WRITE(MW6,F588)(I,2*DYY(I),I=1,MENG)                     !RYD
        IF(NLAGP.NE.NLAG)WRITE(MW6,10080)NLAGP,KSHIFT,MKMAX,MXEP
        GO TO 3200
      ENDIF
!
      WRITE(MW6,10140)MAUTO,MODE,ACE*2,IXFSL,KK               !
!
 3200 CONTINUE
!
! PRINT SOME MORE INFO
!
      IF(.NOT.BPRNT0)GO TO 3400                                  !RETURN
!
      IF(BXTRP)THEN
        IF(BDR)THEN
          IF(BLAG)WRITE(MW6,10170)
          IF(.NOT.BLAG)WRITE(MW6,10160)
        ELSE
          if(kstore.eq.0)stop 'kstore=0...'
          DM=QN(KSTORE)*QN(KSTORE)
          DDY=ZNP*ZNP/DM                              !DZA*DZA
          WRITE(MW6,10150)DDY
        ENDIF
      ENDIF
!
      DD=ECOR1+ECOR1
      DM=ECOR2+ECOR2
      DD=DD*DKCM
      DM=DM*DKCM
      IF(ECOR1.NE.DZERO.OR.ECOR2.NE.DZERO)WRITE(MW6,10100)DD,DM
!
! MP IS NOW HIGHEST ORBITAL NUMBER WHICH HAS BEEN CALCULATED
!
 3300 N=MIN(MYM,MP)
      IF(N.GT.0)THEN
!                       READ AT 70 READ 590  ALLOWS TO SPECIFY PRINTOUT
        IF(MYN.LT.0)MYN=-MYN
!
        IF(MYN.LE.N)THEN
          WRITE(MW6,10350)(I,I=MYN,N)
          DO L=1,MAXRS
            WRITE(MW6,10300)L,DX(L),(DPNL(L,I),I=MYN,N)
          ENDDO
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
! LOCAL
!
 3400 IF(ALLOCATED(DORIGZ))DEALLOCATE(DORIGZ)
!
      IF(ALLOCATED(DA))THEN
        DEALLOCATE(DA,DPA,STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'RADCON: DE-ALLOCATION FAILS FOR DA,DPA'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(FR))THEN
        DEALLOCATE(FR,GR,STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'RADCON: DE-ALLOCATION FAILS FOR FR.GR'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
 3500 NF=-1
      GO TO 3400
!
!-----------------------------------------------------------------------
!
10010 FORMAT(29X,F13.5,30X,A4,I4,I3,I2)
10020 FORMAT(/' GAM ( N,  L,NION, Z, DEL/PI)    OLDEPS/RY OF RADIAL ',  &
     &       'INPUT-FUNCTIONS',3X,                                      &
     &       '(ORIGIN    N L) FNORM, 3 LAST P, <NL!H1!NL>',';STPS/PTS=',&
     &       I4,'/',I4)
10030 FORMAT(' *****STORAGE EXCEEDED IN SR.RADCON, INCREASE MXFSL TO ', &
     &       I7)
10040 FORMAT(' *****STORAGE EXCEEDED IN SR.RADCON, INCREASE MXFSS TO ', &
     &       I7)
10050 FORMAT('+',I3,I4,I4,I4,I4,F9.5,13X,I4,1X,F11.5,F10.3,17X,F8.3,1X, &
     &       3(1PE9.2),0PF12.4)
10060 FORMAT(39X,"READ('')     PBAR0      RPEND",15X,"3 LAST R:",3F9.4, &
     &       4X," (H1/2RY)"/)
10070 FORMAT(' ****ERROR IN SR.RADCON, CONTINUUM ORBITAL N=',I3,        &
     &       ' SKIPPED BECAUSE ENERGY DDY .LT. 0.0 =',F10.4)
10080 FORMAT(/' NLAGP=',I3,2X,'KSHIFT=',I5,2X,'MKMAX=',I5,2X,'MXEP=',I3)
10090 FORMAT(' THE',I4,'  INPUT CONTINUUM ENERGIES (RYD) ARE AS FOLLOWS'&
     &       ,' AND THE ENERGY IN POSITION',I4,                         &
     &       '  WILL BE USED IN H(RC)',' PRINT.'/)
!  588 FORMAT(11(I3,F9.3))
10100 FORMAT(/' ECOR1*CM=',F10.1,5X,'ECOR2*CM=',F10.1)
! 591 FORMAT(7F10.4)
10110 FORMAT(/' MAUTO=',I3,2X,'MODE=',I2,2X,'ACE=',1PE9.2,' RYD.',2X,   &
     &  'CONTINUUM FUNCTIONS IN USE; MODES 2 TO 6. INTERPOLATION IS ON,'&
     &  ,' NLAG=',I2,5X,'MXFSL=',I7/100X,'**',15X,'USED=',I7)
10120 FORMAT(116X,'MXFOO=',I7/117X,'USED=',I7)
10130 FORMAT(116X,'MXFSS=',I7/117X,'USED=',I7)
10140 FORMAT(/' MAUTO=',I3,2X,'MODE=',I2,2X,'ACE=',1PE9.2,' RYD.',2X,   &
     & 'CONTINUUM FUNCTIONS IN USE; MODES 2 TO 3. INTERPOLATION IS OFF,'&
     & ,3X,'MXFSL=',I7/100X,'***',6X,'USED=',I7)
10150 FORMAT(/' N.B. THE',                                              &
     &       ' NL VALENCE ORBITALS HAVE BEEN APPROXIMATED BY A K=0  ',  &
     &       'CONTINUUM ORBITAL AND SO THE'/                            &
     &       ' INTERPOLATION ENERGIES HAVE ','BEEN',                    &
     &       ' SHIFTED BY (Z-NION+1)**2/N**2 =',F6.3,' RYD TO ',        &
     &       'COMPENSATE.'/65X,'**********'/)          !EXPLICIT
10160 FORMAT(/' N.B. THE',                                              &
     &       ' NL VALENCE ORBITALS HAVE BEEN APPROXIMATED BY A K=0 ',   &
     &       'CONTINUUM ORBITAL.')
10170 FORMAT(/' N.B. THE',                                              &
     &       ' NL VALENCE ORBITALS HAVE BEEN APPROXIMATED BY A K=0 ',   &
     &       'CONTINUUM ORBITAL AND SO THE'/' INTERNAL AUTOIONIZATION ',&
     &       'ENERGIES WILL BE SHIFTED TO COMPENSATE.')
                                                       !IMPLICIT
10180 FORMAT(/' *****ERROR, THE LARGEST BOUND ORBITAL NUMBER USED=',I6, &
     &    ' IS GREATER THAN THE SMALLEST CONTINUUM ORBITAL NUMBER USED='&
     &    ,I6)
10190 FORMAT(/' *****ERROR, THE LARGEST VALENCE ORBITAL NUMBER USED=',  &
     &       I6,                                                        &
     &    ' IS GREATER THAN THE SMALLEST CONTINUUM ORBITAL NUMBER USED='&
     &    ,I6)
10200 FORMAT(/' *****ERROR, THE LARGEST CORE ORBITAL NUMBER USED=',I6,  &
     &      ' IS GREATER THAN THE SMALLEST VALENCE ORBITAL NUMBER USED='&
     &      ,I6)
10210 FORMAT(/' ***DIMENSION EXCEEDED IN SR.RADCON, INCREASE IXD24 FROM'&
     &       ,I7,' TO:',I7)
10220 FORMAT('*** SR.RADCON POTENTIAL REQUIRES INITIAL STEP LENGTH ',   &
     &       'DOUBLED, INCREASE MAXB1 OR INCREASE MSTEP  TO',I3,        &
     &       ' IN NAMELIST SMINIM')
10230 FORMAT(13X,'NL =',I3,I3,'   EXTERNAL POTENTIAL V(NL) FROM UNIT=', &
     &       I3,';  NON-COULOMB POT .LT. 1% OF COULOMBIC BEYOND R(IEND='&
     &       ,I5,') =',F10.6)
10240 FORMAT(23X,'NL =',I3,I3,'   S.M.-POTENTIAL V(NL) WITH SCALE ',    &
     &       'FACTOR',F10.5,';  COULOMBIC BEYOND R(IEND=',I5,') =',     &
     &       F10.6)
10250 FORMAT(45X,I1,'-POLE POLARIZED SCALE FACTOR',F10.5,               &
     &       ';  COULOMBIC DEVIATION AT R(IEND) =',F10.6)
10260 FORMAT('GAM=',I3,' GRP=',I3,8X,'NL =',I3,I3,                      &
     &       '   S.M.-POTENTIAL V(NL) WITH SCALE',' FACTOR',F10.5,      &
     &       ';  COULOMBIC BEYOND R(IEND=',I5,') =',F10.6)
10270 FORMAT(2X,'NL =',I3,I3,'   STO.-POTENTIAL CF=',I3,' WITH SCALE',  &
     &       ' FACTOR',F10.5,                                           &
     &       ';  NON-COULOMB POT .LT. 1% OF COULOMBIC BEYOND',          &
     &       ' R(IEND=',I5,') =',F10.6)
10280 FORMAT(23X,'NL =',I3,I3,' PARMET.POTENTIAL V(NL) WITH SCALE ',    &
     &       'FACTOR',F10.5,';  COULOMBIC BEYOND R(IEND=',I5,') =',     &
     &       F10.6)
10290 FORMAT(/'*** ATTENTION: RYDBERG AND CONTINUUM ORBITALS ',         &
     &       'ARE NOT ORTHOGONAL -',2(I5,F10.5)/)
! 781  FORMAT(' ORTHOGONALIZATION CHANGES SIGN OF ORBITAL K= ',I2,
!     &' VALUES NEAR ORIGIN ARE: '/10(1PE13.4))
!  781 FORMAT('+',57X,'*')
10300 FORMAT(I5,(7F18.6))
10310 FORMAT('       OVERLAP INTEGRAL',4X,I3,I2,' WITH',2I2,' =',       &
     &       1PE12.4)
10320 FORMAT('    RENORMLZTN INTEGRAL',4X,I3,I2,11X,1PE12.4)
10330 FORMAT(61X,"P/Q-INPUT FOR ORBITAL K=",I2," MISSING, S.M. USED - ",&
     &       "ORBITALS MAY"/89X,                                        &
     &       "NOT BE ORTHOGONAL TO INPUT-PNL'S WITH SAME L")
10340 FORMAT(61X,'P/Q-INPUT FOR ORBITAL K=',I2,' MISSING (OR MAXB2 TOO',&
     &       ' SMALL), CASE FAILS')
10350 FORMAT(/' OPTIONAL PRINTOUT OF  I, R(I), AND P(I):'//(20X,6I18)/)
10360 FORMAT('L=',I3,3X,'E=',F10.5,'RYD',3X,'DEL/PI=',1PD14.6/)
10370 FORMAT(I5,3E16.7)
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE RADCON
!
!                             *******************
!
      SUBROUTINE RADCX0
!
!-----------------------------------------------------------------------
!
!  SR.RADCX0 READS USER INPUT FOR CONTINUUM ORBITAL GENERATION AND
!            SETS-UP AN ENERGY MESH ACCORDINGLY.
!  IT ALSO CALCULATES THE UNIQUE CONTINUUM DISTORTED-WAVE POTENTIAL
!  USED BY THE CONTINUUM BASIS, TF OR STO, SPECIFIED AS WITH BOUND.
!  USER INPUT (SCALING PARAMETER ETC) IS VIA ORBITAL NO. MXORB+1,
!  I.E. THE NEXT POSITION AFTER THE USER DEFINED BOUND ORBITALS.
!  IF NONE READ FOR SUCH AN ORBITAL, THEN USES DATA ASSOCIATED WITH
!  THE LAST ORBITAL POSITION FOR WHICH INFO WAS READ.
!  IT COMBINES ELEMENTS OF SR.RADCN0 AND SR.RADIAL.
!
!  IT IS CALLED BY:
!    SR.DWX
!
!  IT CALLS:
!    SR.DIFF
!    SR.DIMUSE
!    SR.FIT
!    SR.TFDAPO
!    SR.STOPOT
!    SR.VMPOT
!    SR.VNUKE
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CADJ,   ONLY: DALAN,BALAN
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_CMESH,  ONLY: MHF,MRAD,MSTEP,IXTRA,xmax
      USE COMMON_CMESH,  ONLY: TINORB,RZERO,MXBOX
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_MISC,   ONLY: NF0,BNAME
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
      USE COMMON_QTG,    ONLY: NFI,NFK,NFQ
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,VSC,XC1,XC2,NPITER
      USE COMMON_NRBDW1, ONLY: MXORB,ma0,mb0
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
      USE COMMON_NRBDW4, ONLY: DSPECE,INDEX,JNDEX,NSPECE,NENERG
      USE COMMON_NRBDW5, ONLY: DYY,MENG,NLAG
      USE COMMON_NRBDW7, ONLY: MNDEX,MRNDX,MTRAN,mlim
      USE COMMON_NRBDW8, ONLY: DYY0,IYY0,MENG0
      USE COMMON_NRBDW9, ONLY: DSPECJ,INDXJ,JNDXJ,NSPECJ,NENERJ
      USE COMMON_NRBDWP, ONLY: DLAMX,DLAMDX,DLAMQX,MCFSTOX,NOCCX        &
     &                        ,JENDX,SCALERX
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBORB, ONLY: IEQ
      USE COMMON_NRBPOT, ONLY: DPOT,TOL,MEND
      USE COMMON_NRBPOT, ONLY: ZS0,ZS,JZNM
      USE COMMON_NRBPOT, ONLY: DERV1,DERV2
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBREL, ONLY: RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0
      USE COMMON_NRBREL, ONLY: DNUK0,DNUK1,DNUK2,DNUK
      USE COMMON_NRBSTO, ONLY: ALF,TEL,MSHELL,MCFSTO,MC,MCFMX,MEXPOT    &
     &                        ,NOCC,NLSTOE,BFIX,BSTO,MXSHLL
      USE COMMON_NRBVAL, ONLY: IVAL
!
      use common_nrbuse, only: buguse,buse,busi,btmp
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (DEL=D1M4)                              !FOR CONT. INTS
      PARAMETER (DTOL=D1M2)
      PARAMETER (TOLDE0=D1M1)
!OLD      PARAMETER (DLAM0=D1PT3)                  !DEFAULT CONT LAMBDA
      PARAMETER (DEPS=D1M10)
!
      ALLOCATABLE :: DELTAE(:)
      ALLOCATABLE :: IXX(:),IXX0(:),DXX(:),DXX0(:)
      ALLOCATABLE :: DA(:)
!
! THE FULL NAMELIST-ING FROM SR.RADCN0 IS USED, FOR COMPATIBILITY
! BUT THE ONLY VARIABLES USED/SPECIFIABLE ARE:
!
!            MENG, EMIN, EMAX - SCATTERED ENERGY DEFINITION, AS "USUAL"
!            NDE, DEMIN, DEMAX - EXCITATION ENERGY DEFINITION,
!                                FORMAT SPEC. AS FOR SCATTERED ENERGY
!            MENGI, EMINI, EMAXI - INTERPOLATION ENERGY DEFINITION
!                     MENGI.GT.0 FORMAT SPEC. AS FOR SCATTERED ENERGY
!                     MENGI.LT.0 INSERT -MENGI POINTS BETWEEN SCATTERED
!            DELTAX - MAX EXCITATION ENERGY RESTRICTION
!                    (DEFAULT USES HIGHEST TARGET)
!            NIDX - NO. OF "INCIDENT" ENERGIES BEYOND FINAL SCATTERED.
!                   NEW DEFAULT: AT LEAST 2 (BECAUSE OF DIPOLE)
!                   OLD "DEFAULT" (NO NIDX) JUST DELTAX, I.E. 1.
!            NLAG - POINT FORMULA, DEFAULT 2 UNLESS MENGI.LT.0 THEN
!                   2-MENGI.
!                     N.B. LARGE NOT GOOD IF POINTS WIDELY SPACED
!            TOLDE RELATIVE DIFFERENCE FOR PRUNING OF CLOSELY SPACED
!                  INTERPOLATION ENERGIES. DEFAULT 0.1
!            TEAPOT - IONIZATION POTENTIAL. IF MENG=0 THEN SCATTERING
!                     ENERGIES ARE A FUNCTION OF (INTERNAL) I.P. GIVEN
!                     BY BINDING ENERGY OF OUTER ELECTRON OF GROUND CF,
!                     UNLESS OVERRIDEN BY USER: RYD.GT.0.
!
! user should not normally change/set these test variables:
!
!            bnointerp - sets deltax=0, nidx=0, nlag=1, over-riding any
!                        user specification. Then uses nearest incident
!                        energy k-matrix. User should set interpolation
!                        energies with mengi to be the meng scattered
!                        energies *plus* all the relevant excitation
!                        energies. Obviously, this is for precise tests.
!                        Note, if comparing coupling schemes, then need
!                        to switch-off the hard-wired 2x2 approx unitary
!                        in sr.cadwx, dwxls, dwxbp  set by bunit at top.
!            ilog - gt 0 for log energy spacing
!                 - eq 0 for linear energy spacing
!                 - lt 0 code chooses appropriately (default)
!            nskp - gt 0 read and skip energy integral pairs
!                 - le 0 default, keep all.
!            tolp - ge 0 prune energies closer than tolp.
!                   lt 0 code chooses appropriately (default)
!        set nde=-1 ilog=-1 to use characteristic orbital energies, then
!            nbund- gt 0 bundle coe for n .ge. nbund (default=6)
!                 - le 0 no bundling of coe.
!
!-----------------------------------------------------------------------
!
      NAMELIST/SRADCON/                                                 &
     & ACE,                                                             &
     & DLAMX,DLAMDX,DLAMQX,SCALERX,MCFSTOX,                             &
     & ECOR1,ECOR2,ECORCA,ECORIC,ECORLS,EMIN,EMAX,MIONQ,                &
     & KSHIFT,MKMAX,MXEP,                                               &
     & MDECP,MENG,MENGP,MP,MYN,MYM,                                     &
     & NLAG,NREL,                                                       &
     & PIG,PMIN,                                                        &
     & DELTAX,DEMIN,DEMAX,NDE,NIDX,                                     &
     & EMINI,EMAXI,MENGI,                                               &
     & TEAPOT,TOLDE                                                     &
     &,ilog,nbund,nskpi,tolp,bnointerp
!     &                     ,toldc
!
! NOT ALL VARIABLES USED BY RADCX0, BUT PRESENT FOR RADCN0 COMPATIBILITY
!
! VIZ.    ECOR1,ECOR2,ECORCA,ECORIC,ECORLS,MIONQ,
!         KSHIFT,MKMAX,MXEP,
!         MDECP,MENGP,MYM,NREL,PIG,PMIN
!
!-----------------------------------------------------------------------
!
      IXD04=MAX(MXENG,1000_SP)                   !INITIAL BUFFER (LOCAL)
!
      ALLOCATE(IXX(IXD04),IXX0(IXD04),DXX(IXD04),DXX0(IXD04),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RADCX0: ALLOCATION FAILS FOR IXX ETC'
        NF=0
        GO TO 1100
      ENDIF
!
! SOME INITIALIZATIONS
!
      PI=ACOS(-DONE)
      TOL=DONE/10**ITOL
      DHNSX=DHNS(MJH)
      BORT=MORT.LT.0
      IORT=ABS(MORT)
      DZ=NZION
      NZA=NZION-MION
      NZAP=NZA+1                   !FOR TARGET ELECTRON
      DZAP=NZAP
!      DZAP2=NZAP*NZAP
      TOLR=DEL/DZAP
      SCALERX=DONE                 !COWAN SLATER INTEGRAL SCALE FACTOR
!
! ********** ALL INPUT ENERGIES SHOULD BE IN RYDBERGS ***********
!
      BTHRSH=LVMAX.GE.0
      NLAG=-1
      ilog=-999
      tolp=-done
!
      TOLDE=-DONE
      DXX(1)=DZERO
      if(abs(modd).gt.1)then                      !back compatible
        DELTAX=DSPECE(NSPECE)
      else                                         !but strictly
        DELTAX=DSPECJ(NSPECJ)
      endif
      DELTAX=DELTAX+DELTAX*DEPS  !SO AS NOT TO FLAG ZERO*USE OF INTERP E
      NIDX=-1
! SCATTERED
      EMIN=0
      EMAX=-3*DELTAX
      MENG=0
      TEAPOT=-DONE
! CHARACTERISTIC
      NDE=-999
      DEMIN=-1
      DEMAX=-2
      nbund=6            !lump all-n.ge.nbund, case use orbital epsilons
      toldc=tolde0/2                            !set zero for no pruning
! INTERPOLATION
      EMINI=-1
      EMAXI=-2
      MENGI=-999
      nskpi=0
      bnointerp=.false.
!
      IF(BNAME)THEN
!
        REWIND(MR5)                    !CASE USER NAMELISTS OUT OF ORDER
!
        READ(MR5,SRADCON,END=1200,ERR=1200)   ! <-------------- NAMELIST
!
      ELSE                                        !HISTORIC FIXED FORMAT
!
        READ(MR5,10170)E1,E2,MENG,MENGI,NDE
!
        IF(MENG.NE.0)THEN
          EMIN=E1
          EMAX=E2
        ELSEIF(MENGI.NE.0)THEN
          EMINI=E1
          EMAXI=E2
        ELSEIF(NDE.GT.0)THEN
          DEMIN=E1
          DEMAX=E2
        ENDIF
!
      ENDIF
!
      if(bnointerp)then
        nidx=0
        nlag=1
        deltax=0
      endif
!
      IF(BTHRSH)THEN
        IF(MENG.LT.0.OR.MENG.GT.1)THEN
          WRITE(MW6,10200)
          NF=-1
          GO TO 1100
        ENDIF
!                                                           !DR DEFAULTS
        ISGN=1-2*mod(abs(NLAG),ITWO)             !(-1)**NLAG
        IF(NLAG.LT.4.OR.NLAG.GT.10.OR.ISGN.LT.0)NLAG=6
        IF(NDE.EQ.-999.AND.MENGI.EQ.-999)MENGI=-2*NLAG+2     !AS INSERTS
        IF(NIDX.LE.0)NIDX=1
      ENDIF
!
      IF(NDE.EQ.-999.AND.MENGI.EQ.-999)NDE=-2
      IF(NDE.EQ.-999)NDE=0
      IF(MENGI.EQ.-999)MENGI=0
!
      if(ilog.eq.-999)then                  !set default log/lin spacing
        if(nde.lt.0)then
          ilog=1                                      !log (for char de)
        else
          ilog=0                                     !linear (for mengi)
        endif
      endif
!
      if(nde.eq.0)tolp=d1p10
      if(mengi.ge.0)tolp=dzero
      if(tolp.lt.dzero)tolp=d1pt2
!
      IF(NLAG.LT.1)THEN                       !=1 NO INTERP, USE NEAREST
        NLAG=2
        NLAG=MAX(NLAG,NLAG-MENGI)
        nlag=min(nlag,6_SP)                   !case large negative mengi
      ELSEIF(NLAG.GT.4.AND..NOT.BTHRSH)THEN
        WRITE(MW6,*)'USE OF NLAG=',NLAG
        WRITE(MW6,*)                                                    &
     &           'IS NOT RECOMMENDED UNLESS ENERGIES ARE CLOSELY SPACED'
      ENDIF
!
! SAME SCATTERED ENERGIES ARE USED IN DWXLS AND DWXBP.
!
      MENG0=MENG
      IF(MENG0.LT.0)MENG=-MIN(-NLAG,MENG0,-IFOUR)
!
      IF(MENG.GT.IXD04)THEN                    !SHOULD NOT HAPPEN NOW
        WRITE(MW6,10010)MENG
        WRITE(MW0,*)'***NUMBER OF SCATTERING ENERGIES HAS BEEN REDUCED'
        WRITE(MW0,*)'***INCREASE IXENG BUFFER TO RETAIN ALL, CONTINUING'
        MENG=IXD04
      ENDIF
!
      IF(MENG0.LT.0)THEN
!
        IF(EMAX.LT.EMIN)THEN                   !WAS NOT READ IN NAMELIST
          READ(MR5,*,END=50,ERR=50)EMIN0,EMAX0
          EMIN=EMIN0
          EMAX=EMAX0
        ENDIF
        IF(EMAX.GT.EMIN.AND.EMIN.LT.DZERO)EMIN=DZERO
!
   50   IF(NF.LE.0)GO TO 1100
!
!
!-----------------------------------------------------------------------
!
! SET-UP SCATTERED ENERGIES INTERNALY.
!
        IF((EMAX-EMIN).LT.D1M5)THEN
          WRITE(MW6,10210)EMIN,EMAX
          WRITE(MW0,*)'****ERROR IN SR.RADCX0, UNSUITABLE ENERGY RANGE'
          NF=-1
          GO TO 1100
        ENDIF
!
        IF(MENG.LE.1)THEN
          WRITE(MW6,10220)-MENG
          WRITE(MW0,*)'****ERROR IN SR.RADCX0, REQUIRE AT LEAST TWO ',  &
     &              'SCATTERED ENERGIES TO DEFINE RANGE, CASE MENG.LT.0'
          NF=-1
          GO TO 1100
        ENDIF
!
        DD=MENG-1
        EMAX=EMAX+DONE
        EMIN=EMIN+DONE
        T0=EMAX/EMIN
        DO M=1,MENG
          DM=M-1
          T=T0**(DM/DD)
          DXX0(M)=EMIN*T-DONE
        ENDDO
!
        MENG0=MENG
!
      ELSEIF(MENG0.GT.0)THEN
!
        MENG0=MENG
!
! READ USER SUPPLIED SCATTERED ENERGIES (RYD)
!
        READ(MR5,*)(DXX0(I),I=1,MENG0)
!
        IF(NF.LE.0)GO TO 1100
!
        IF(BTHRSH)THEN                           !ONLY HERE IF MENG0=1
          IF(DXX0(1).NE.DZERO)THEN               !ALLOW USER TO SET ZERO
            WRITE(MW0,*)                                                &
     &                '***RE-SETTING INPUT SCATTERING ENERGY TO ZERO...'
            DXX0(1)=DZERO
          ENDIF
        ENDIF
!
! RE-ORDER INTO ASCENDING ENERGIES (NOW NECESSARY)
!
        DO I=2,MENG0
          IM=I-1
          IF(DXX0(I).GT.DXX0(IM))GO TO 100
          T=DXX0(I)
          DXX0(I)=DXX0(IM)
          DXX0(IM)=T
!
          DO J=2,IM
            JM=I-J
            JJ=JM+1
            IF(DXX0(JJ).GT.DXX0(JM))GO TO 100
            T=DXX0(JJ)
            DXX0(JJ)=DXX0(JM)
            DXX0(JM)=T
          ENDDO
!
  100   ENDDO
!
! REMOVE DEGENERATE SCATTERING ENERGIES
!
        I=2
        DO I0=2,MENG0
          IF(DXX0(I)-DXX0(I-1).LT.DEPS)THEN
            DO J=I,MENG
              DXX0(J-1)=DXX0(J)
            ENDDO
            MENG=MENG-1
            I=I-1
          ENDIF
          I=I+1
          IF(I.GT.MENG)GO TO 150
        ENDDO
!
  150   MENG0=MENG
!
      ELSEIF(BTHRSH)THEN                                     !MENG=0
        MENG=1
        DXX0(1)=DZERO
        MENG0=MENG
      ELSE
!
! SET DEFAULT SCATTERED ENERGIES AS A FUNCTION OF I.P.
!
        IF(TEAPOT.LE.DZERO)THEN
          IC=INDEX(1)
          IF(NSL0.GT.0)IC=NFK(IC)                            !NOT CA
          DO IB=MXORB,1,-1
            IF(NEL(IB,IC).GT.0)GO TO 160
          ENDDO
!          STOP 'SR.RADCX0: SHOULD NEVER GET HERE'
  160     IN=ICOL(IB,IB,IZERO)
          TEAPOT=DUY(IN)-DEY(IB)
          TEAPOT=TEAPOT+TEAPOT
        ENDIF
        DEX=MAX(TEAPOT,DELTAX)
        MENG=4
        DXX0(1)=DZERO
        DXX0(2)=DEX/3
        DXX0(3)=DEX
        DXX0(4)=DEX*3
        IF(MAXLT.GT.35)THEN
          MENG=MENG+1
          DXX0(5)=DEX*8
        ENDIF
        MENG0=MENG
!
      ENDIF
!
! FIX FOR NEUTRALS (INC. PLASMA NEUTRALIZATION)
!
      IF((NZA.EQ.0.OR.MDEN.GT.0).AND.DXX0(1).LT.D1M2)THEN
        WRITE(MW6,10070)
        DO M=1,MENG0
          IF(DXX0(M).LT.D1M2)THEN
            DXX0(M)=D1M2
          ELSE
            GO TO 200
          ENDIF
        ENDDO
        NF=-1
      ENDIF
!
! WRITE SCATTERED ENERGIES
!
  200 WRITE(MW6,10140)MENG0
      WRITE(MW6,10150)(I,DXX0(I),I=1,MENG0)
      IF(NF.LT.0)THEN
        WRITE(MW0,*)                                                    &
     &   '*** ERROR: ALL SCATTERING ENERGIES TOO SMALL FOR A NEUTRAL...'
        GO TO 1100
      ENDIF
!
! ADD ENERGIES ABOVE LAST SCATTERED ENERGY, REQUIRED UP TO +DELTAX.
!
      IF(NIDX.LT.0)THEN               !1=OLD DEFAULT, POOR FOR DIPOLES
        IF(MENG0.GT.1)THEN
          T=DELTAX/(DXX0(MENG0)-DXX0(MENG0-1))
          NIDX=INT(T,SP)
          NIDX=MAX(ITWO,NIDX)
        ELSE
          NIDX=2                                               !SIMPLE
        ENDIF
        NIDX=MAX(NIDX,NLAG)
      ENDIF
!
      MENG00=MENG0
      IF(MENG0+NIDX.le.IXD04.and.nde.le.0)THEN
        if(ilog.gt.0)then
          e0=DXX0(MENG0)+done
          e1=e0+DELTAX
          t0=e1/e0
          dd=nidx
          DO M=1,NIDX
            de=m
            t=t0**(de/dd)
            DXX0(MENG0+M)=e0*t-done
!            write(mw0,*)meng0+m,dxx0(meng0+m)
          ENDDO
        else
          if(nidx.gt.0)DE=DELTAX/NIDX
          DO M=1,NIDX
            DXX0(MENG0+M)=DXX0(MENG0)+DE*M
          ENDDO
        endif
        MENG00=MENG0+NIDX
      ENDIF
!
!-----------------------------------------------------------------------
!
! SET-UP CHARACTERISTIC EXCITATION ENERGIES DELTAE(I), I=0,NDE.
!
! (COULD ALSO ATTEMPT TO SET FROM ACTUAL DSPECE VALUES... BUT OPTIONAL
!  USE OF ORBITAL ENERGIES IS IMPLEMENTED: SET ILOG=-1 (WITH NDE.LT.0)
!  BECAUSE DEFAULT ILOG=-999 IS RE-SET TO +1 FOR NDE.LT.0.)
!
      IF(NDE.LT.0.AND.ILOG.LT.0)THEN
        IXNDE=NBUND*NBUND
      ELSE
        IXNDE=ABS(NDE)
      ENDIF
!
      ALLOCATE(DELTAE(0:IXNDE),STAT=IERR)                         !LOCAL
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RADCX0: ALLOCATION FAILS FOR DELTAE'
        NF=0
        GO TO 1100
      ENDIF
!
! ***CURRENTLY, NO INTERPOLATION OF SCATTERED ENERGIES AND SO *MUST*
!    HAVE DELTAE(0)=0 TO ENSURE INPUT SCATTERED ENERGIES ARE USED
!    AS INTERPOLATION ENERGIES AS WELL.***
!
      DELTAE(0)=DZERO
!
      IF(NDE.LT.0)THEN                            !USE A RANGE OF DELTAE
!
        IF(DEMAX.LT.DEMIN)THEN                 !WAS NOT READ IN NAMELIST
          DEMIN=DZERO
          DEMAX=DELTAX
!          READ(MR5,*,END=23,ERR=23)DEMIN0,DEMAX0   !ALLOW ONLY NAMELIST
!          IF(DEMIN0.GE.DZERO)DEMIN=DEMIN0           !TO AVOID CONFUSION
!          IF(DEMAX0.GT.DEMIN)DEMAX=DEMAX0
        ELSE
          IF(DEMIN.LT.DZERO)DEMIN=DZERO
        ENDIF
!
! 23     CONTINUE
        NDE0=-NDE
        NDE=0
!        IF(DEMIN.GT.DZERO)NDE=-1 !DROP ORIGINAL POINTS, NOT ALLOWED YET
!
        if(ilog.gt.0)then
          dd=nde0
          e2=done
          e0=done
          e1=DELTAX+e2
          t0=e1/e0
          DO I=1,NDE0
            di=i
            t=t0**(di/dd)
            t=e0*t-e2
            IF(T.GE.DEMIN)THEN
              NDE=NDE+1
              DELTAE(NDE)=T
              IF(T.GT.DEMAX)GO TO 220
            ENDIF
          ENDDO
  220     DELTAX=DELTAE(NDE)
        elseif(ilog.eq.0)then
          DE=DELTAX/NDE0
          DO I=1,NDE0
            T=DELTAE(I-1)+DE
            IF(T.GE.DEMIN)THEN
              NDE=NDE+1
              DELTAE(NDE)=T
              IF(T.GT.DEMAX)GO TO 240
            ENDIF
          ENDDO
  240     DELTAX=DELTAE(NDE)
        else                                      !use orbital energies
          do i=1,nbund
            deltae(i)=0                           !max delta-e (n.eq.n')
          enddo
          np=nbund
          nq=np+1
          do j=2,nbund                  !mxnde
            do i=1,j-1
              np=np+1
              nq=nq+1
              deltae(np)=0                        !max delta-e (n.ne.n')
              deltae(nq)=d1p30                    !min delta-e (n.ne.n')
            enddo
            np=nq
            nq=np+j
            if(nq+j.gt.ixnde)go to 260
          enddo
  260     nde=0
          do i=mb0+1,mxorb
            if(dey(i).ne.dzero)then
              nl=min(int(qn(i),sp),nbund)         !limit resolved
!              ll=ql(i)/2
              in=icol(i,i,izero)
              dei=duy(in)-dey(i)
              do j=i+1,mxorb
                if(dey(j).ne.dzero)then
                  nu=min(int(qn(j),sp),nbund)     !limit resolved
!                  lu=ql(j)/2
                  in=icol(j,j,izero)
                  dej=duy(in)-dey(j)
                  de=2*abs(dei-dej)
                  nm=min(nl,nu)
                  nx=max(nl,nu)
                  if(nl.ne.nu)then
                    np=(nx-1)*(nx-2)+nm+nbund
                    nq=(nx-1)*(nx-1)+nm+nbund
                  else
                    np=nu                         !min(nu,nbund)
                    nq=0
                  endif
!                  write(mw6,*)nl,nu,np,nq,de,deltae(np),deltae(nq)
                  nde=max(nde,np,nq)
                  if(nde.le.ixnde)then
                    deltae(np)=max(deltae(np),de)
                    deltae(nq)=min(deltae(nq),de)
                  endif
                endif
              enddo
            endif
          enddo
          if(nde.gt.ixnde)then          !should not happen now
            write(mw6,10050)nde
            nf=-1
            go to 1100
          endif
!          do i=1,nde
!            write(mw0,*)i,deltae(i)
!          enddo
!
          dpx=0
          dq=d1p30
          do i=1,nbund
            dpx=max(dpx,deltae(i))                !max delta-e (n.eq.n')
            if(deltae(i).gt.deps)dq=min(dq,deltae(i)) !min  "   "    "
            deltae(i)=0
          enddo
          deltae(1)=dpx
          deltae(2)=dq
          i=1
          nq=nde
          if(demin.eq.dzero)demin=deps               !just remove zeroes
          do i0=1,nq
            btest1=deltae(i).lt.demin.or.deltae(i).gt.demax
            btest2=abs(deltae(i)-deltae(i-1)).lt.toldc*deltae(i)
            if(btest1.or.btest2)then
              do j=i+1,nde
                deltae(j-1)=deltae(j)
              enddo
              nde=nde-1
              i=i-1
            endif
            i=i+1
            if(i.gt.nde)go to 280
          enddo
  280     deltae(0)=dzero                            !just in case
        endif
!
      ELSEIF(NDE.GT.0)THEN
!
        READ(MR5,*)(DELTAE(I),I=1,NDE)
        DELTAX=DZERO
        DO I=1,NDE                                 !CASE OUT OF ORDER
          DELTAX=MAX(DELTAX,DELTAE(I))
        ENDDO
!
      ENDIF
!
! WRITE CHARACTERISTIC EXCITATION ENERGIES
!
      IF(NDE.NE.0)THEN
!
! FIRST RE-ORDER TO ASCENDING (NOT NECESSARY, BUT LESS CONFUSING)
!
        DO I=2,NDE
          IM=I-1
          IF(DELTAE(I).GT.DELTAE(IM))GO TO 300
          T=DELTAE(I)
          DELTAE(I)=DELTAE(IM)
          DELTAE(IM)=T
!
          DO J=2,IM
            JM=I-J
            JJ=JM+1
            IF(DELTAE(JJ).GT.DELTAE(JM))GO TO 300
            T=DELTAE(JJ)
            DELTAE(JJ)=DELTAE(JM)
            DELTAE(JM)=T
          ENDDO
  300   ENDDO
!
        WRITE(MW6,10120)NDE+1
        WRITE(MW6,10150)(I,DELTAE(I),I=0,NDE)
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! READ ANY USER SUPPLIED INTERPOLATION ENERGY SET-UP
! (MENGI,EMINI,EMAXI,DXXI->DXX)
!
!
! SAME INTERPOLATION ENERGIES ARE USED IN DWXLS AND DWXBP.
!
      MENGI0=MENGI
      IF(MENGI0.LT.0)MENGI=-MENGI0
!
      MM=MENGI+MENG
      IF(MM.GT.IXD04)THEN
        WRITE(MW6,10020)MM
        WRITE(MW0,*)                                                    &
     &      '*** TOO MANY INTERPOLATION ENERGIES, INCREASE IXENG BUFFER'
        NF=-1
        GO TO 1100
      ENDIF
!
! SET-UP INTERPOLATION ENERGIES INTERNALY BY INSERTING -MENGI POINTS
! BETWEEN EXISTING SCATTERING ENERGY POINTS BETWEEN EMINI AND EMAXI,
! LIN OR LOG SPACED.
!
      IF(MENGI0.LT.0)THEN
!
        IF(EMAXI.LT.EMINI)THEN                 !WAS NOT READ IN NAMELIST
          EMINI=DZERO
          EMAXI=DXX0(MENG0)+DELTAX
!          READ(MR5,*,END=21,ERR=21)EMIN0,EMAX0     !ALLOW ONLY NAMELIST
!          IF(EMIN0.GE.DZERO)EMINI=EMIN0             !TO AVOID CONFUSION
!          IF(EMAXI.GT.EMINI)EMAXI=EMAX0
        ENDIF
        IF(EMAXI.GT.EMINI.AND.EMINI.LT.DZERO)EMINI=DZERO
!
!  21    CONTINUE
        IF(NF.LE.0)GO TO 1100
!
        IF(EMAXI.LT.EMINI)THEN
          T=EMAXI
          EMAXI=EMINI
          EMINI=T
        ENDIF
!      write(mw0,*)'emini, emaxi=', emini,emaxi
!
        IF((EMAXI-EMINI).LT.D1M5)THEN
          WRITE(MW6,10230)EMINI,EMAXI
          WRITE(MW0,*)'****ERROR IN SR.RADCX0, UNSUITABLE ENERGY RANGE'
          NF=-1
          GO TO 1100
        ENDIF
!
! NOW INSERT -MENGI ENERGIES
!
        DD=MENGI+1
        IM=0
        MP=1
        if(nde.le.0)MP=MP-NIDX
!
        if(ilog.gt.0)then                !log spacing of inserted points
          DO M=1,MENG0-MP
            IF(DXX0(M).GE.EMINI.AND.DXX0(M+1).LE.EMAXI.AND.DXX0(M+1)    &
     &         -DXX0(M).LT.TOLP*DELTAX)THEN
              e0=DXX0(M)+done
              e1=DXX0(M+1)+done
              t0=e1/e0
              DO I=1,MENGI
                IM=IM+1
                IF(IM.LE.IXD04)THEN
                  di=i
                  t=t0**(di/dd)
                  DXX(IM)=e0*t-done
!                  write(mw0,*)im,dxx(im),dxx0(m),dxx(im)-dxx0(m)
                ENDIF
              ENDDO
            ENDIF
          ENDDO
        else                          !linear spacing of inserted points
          DO M=1,MENG0-MP
            IF(DXX0(M).GE.EMINI.AND.DXX0(M+1).LE.EMAXI.AND.DXX0(M+1)    &
     &         -DXX0(M).LT.TOLP*DELTAX)THEN
              DE=(DXX0(M+1)-DXX0(M))/DD
              DO I=1,MENGI
                IM=IM+1
                IF(IM.LE.IXD04)DXX(IM)=DXX0(M)+I*DE
!                write(mw0,*)im,dxx(im),m,dxx0(m)      !,dxx(im)-dxx0(m)
              ENDDO
            ENDIF
          ENDDO
        endif
!
        IF(MP.LE.0)THEN                                          !EQ->LE
          IM=IM+1
          IF(IM.LE.IXD04)DXX(IM)=DXX0(MENG00)                    !0->00
        ENDIF
!
        IF(IM.GT.IXD04)THEN
          WRITE(MW6,10020)IM
          WRITE(MW0,*)                                                  &
     &       '***TOO MANY INTERPOLATION ENERGIES, INCREASE IXENG BUFFER'
          NF=-1
          GO TO 1100
        ENDIF
!
        MENGI=IM
!
      ELSEIF(MENGI.GT.0)THEN
!
! READ USER SUPPLIED INTERPOLATION ENERGIES (RYD)
!
        READ(MR5,*)(DXX(I),I=1,MENGI)
!
        IF(NF.LE.0)GO TO 1100
        IF(MENGI.EQ.1)GO TO 400
!
! RE-ORDER INTO ASCENDING ENERGIES (NOT NECESSARY, BUT LESS CONFUSING)
!
        DO I=2,MENGI
          IM=I-1
          IF(DXX(I).GT.DXX(IM))GO TO 350
          T=DXX(I)
          DXX(I)=DXX(IM)
          DXX(IM)=T
!
          DO J=2,IM
            JM=I-J
            JJ=JM+1
            IF(DXX(JJ).GT.DXX(JM))GO TO 350
            T=DXX(JJ)
            DXX(JJ)=DXX(JM)
            DXX(JM)=T
          ENDDO
  350   ENDDO
!
      ELSEIF(NDE.EQ.0)THEN
!
        DXX(1)=DXX0(MENG0)+DELTAX
        MENGI=1
!
      ENDIF
!
      IF(MENGI0.GT.0.and.nde.eq.0)THEN
        IF(DXX(MENGI).LT.(D0PT9*DXX0(MENG0)+DELTAX))THEN
          WRITE(MW6,10060)DXX(MENGI),DXX0(MENG0)+DELTAX
          WRITE(MW0,*)                                                  &
     & '*** MAX INTERPOLATION ENERGY TOO SMALL FOR MAX SCATTERED ENERGY'
        ENDIF
      ENDIF
!
  400 IF(NZA.EQ.0.AND.DXX(1).LT.D1M2)THEN
        WRITE(MW6,10080)
        DO M=1,MENGI
          IF(DXX(M).LT.D1M2)THEN
            DXX(M)=D1M2
          ELSE
            GO TO 500
          ENDIF
        ENDDO
      ENDIF
!
!-----------------------------------------------------------------------
!
! NOW SET-UP COMPLETE BASIS OF INTERPOLATION ENERGIES
! (ADD-IN ORIGINAL MENG0 POINTS PLUS ANY DUE TO NDE.)
!
!-----------------------------------------------------------------------
!
  500 MENG=(NDE+1)*MENG00+MENGI                   !MAX POSSIBLE
!
      MX=MIN(MENG,IXD04)
      DO M=1,MX
        IXX(M)=0
        IXX0(M)=0
      ENDDO
!
      t0=dxx0(meng0)+deltax+d1m5
!
      MENG=MENGI
      DO M=1,MENG00
!
        IF(DELTAE(0).EQ.DZERO)THEN
          MENG=MENG+1
          IF(MENG.LE.IXD04)THEN
            IF(M.LE.MENG0)THEN
              IXX(MENG)=M                      !FLAG SCATTERING ENERGIES
            ELSE
              IXX(MENG)=-999                     !FLAG THE NIDX ENERGIES
            ENDIF
            DXX(MENG)=DXX0(M)
          ENDIF
        ENDIF
!
        IF(NDE.GT.0)THEN
!                  .and.m.le.meng0
          IF(M.LT.MENG00)THEN
            T1=DXX0(M+1)
          ELSE
            T1=DXX0(M)+TOLP*DELTAX+D1M5
          ENDIF
          IF(T1-DXX0(M).GE.TOLP*DELTAX)THEN
            DO N=1,NDE
              T=DXX0(M)+DELTAE(N)
              if(t.lt.t0)then
                MENG=MENG+1
                IF(MENG.LE.IXD04)DXX(MENG)=T
!            else
!              do not bailout as deltae may not be energy ordered
              endif
            ENDDO
          ENDIF
        ENDIF
!
      ENDDO
!
      IF(MENG.GT.IXD04)THEN
        WRITE(MW6,10040)MENG
        NF=-1
        GO TO 1100
      ENDIF
!
! RE-ORDER INTO ASCENDING ENERGIES
!
      DO I=2,MENG
        IM=I-1
        IF(DXX(I).GT.DXX(IM))GO TO 600
        T=DXX(I)
        DXX(I)=DXX(IM)
        DXX(IM)=T
        M=IXX(I)
        IXX(I)=IXX(IM)
        IXX(IM)=M
!
        DO J=2,IM
          JM=I-J
          JJ=JM+1
          IF(DXX(JJ).GT.DXX(JM))GO TO 600
          T=DXX(JJ)
          DXX(JJ)=DXX(JM)
          DXX(JM)=T
          M=IXX(JJ)
          IXX(JJ)=IXX(JM)
          IXX(JM)=M
        ENDDO
!
  600 ENDDO
!
! PRUNE CLOSELY ADJACENT ENERGIES (BUT DO NOT DROP ANY ORIGINAL POINTS,
! NOR THE LAST, UNLESS ACCIDENTLY DEGENERATE, AND RETAIN ENOUGH FOR
! INTERPOLATION AT HIGH-E - SEE TDE)
!
      IF(TOLDE.LT.DZERO)THEN
        TOLDE=TOLDE0
        IF(NDE.NE.0.OR.MENGI0.LT.0)TOLDE=TOLDE/2
      ENDIF
      TDE=D0PT95*DELTAX
!
      MX=MENG
!OLD      IF(IXX(MX).EQ.0)IXX(MX)=-999             !NOW FLAGGED ALL NIDX
!
      I=2
      DO IX=2,MX
        T=ABS(DXX(I)-DXX(I-1))
        IF(T.LE.TOLDE*DXX(I).AND.T.LT.TDE)THEN
          IP=0
          IF(IXX(I).EQ.0)THEN
            IP=I+1
          ELSEIF(IXX(I-1).EQ.0)THEN
            IP=I
          ELSEIF(T.LE.D1M5*DXX(I))THEN
            IP=I
            if(ixx(i).lt.0)ixx(i)=ixx(i-1)
          ENDIF
          IF(IP.GT.0)THEN
            DO J=IP,MENG
              DXX(J-1)=DXX(J)
              IXX(J-1)=IXX(J)
            ENDDO
            MENG=MENG-1
            I=I-1
          ENDIF
        ENDIF
        I=I+1
        if(i.gt.meng)go to 700                    !we are done, bail out
      ENDDO
!
  700 CONTINUE                         !IF(IXX(MENG).EQ.-999)IXX(MENG)=0
!
      DO M=1,MENG
        IF(IXX(M).EQ.-999)THEN
          IXX(M)=0
        ELSE
          M0=IXX(M)
          IF(M0.GT.0.AND.M0.LE.MENG0)IXX0(M0)=M
        ENDIF
      ENDDO
!
!-----------------------------------------------------------------------
!
! ALLOCATE FOR SCATTERING (MENG0) AND INTERPOLATION (MENG) ENERGIES
!
      CALL DIMUSE('MXENG',MENG)
!
      IF(MENG.GT.MXENG)THEN
        IF(MXENG.GT.0)WRITE(MW6,10030)MENG,MXENG
      ENDIF
      IXENG=MENG
!
! EX-CXOMMON/NRBDW5/
      ALLOCATE(DYY(MENG),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RADCX0: ALLOCATION FAILS FOR DYY'
        NF=0
        GO TO 1100
      ENDIF
!
! EX-CXOMMON/NRBDW8/
      ALLOCATE(IYY0(MENG0),DYY0(MENG0),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RADCX0: ALLOCATION FAILS FOR IYY0,DYY0'
        NF=0
        GO TO 1100
      ENDIF
!
!-----------------------------------------------------------------------
!
! TRANSFER (REDUCED SET) TO COMMON VARIABLES
!
      DO M=1,MENG
        DYY(M)=DXX(M)
      ENDDO
!
      DO M=1,MENG0
        IYY0(M)=IXX0(M)
        DYY0(M)=DXX0(M)
      ENDDO
!
! WRITE INTERPOLATION ENERGIES (RYD)
!
      WRITE(MW6,10130)MENG
      WRITE(MW6,10150)(I,DYY(I),I=1,MENG)
!
! WRITE MAPPING OF SCATTERED TO INTERPOLATION
!
      WRITE(MW6,10110)(M0,IYY0(M0),M0=1,MENG0)
!
! WRITE LAGRANGE INTERPOLATION INFO
!
      WRITE(MW6,10160)NLAG
!
!-----------------------------------------------------------------------
!
! SET-UP A MAPPING OF MTRAN INTERACTING ENERGY PAIRS:
! MNDEX(M,MT) GIVES ENERGY PAIRS (M=1,2) FOR MT=1,MTRAN.
! FORMALLY, |E1-E2|.GT.DELTAE DO NOT CONTRIBUTE.
! FOR INTERPOLATION, WE GO NLAG/2 POINTS FURTHER.
! (WILL NOT CATCH USER DELTAX << NEEDED.)
! WE MUST ALSO CATCH THE REVERSE CASE BECAUSE OF USE
! OF FALLING ORDER ON TWO-BODY INTEGRALS.
!
      IF(DELTAX.LT.D0PT9*DSPECE(NSPECE))THEN
        WRITE(MW6,10090)DELTAX,DSPECE(NSPECE)
        WRITE(MW0,*)                                                    &
     &'***LARGEST FLAGGED EXCITATION ENERGY LESS THAN MAX TARGET ENERGY'
        WRITE(MW0,*)'***COLLISION INTEGRALS ARE BEING EXTRAPOLATED!'
      ENDIF
!
! EX-CXOMMON/NRBDW7/
      IXD06=MENG*MENG
      ALLOCATE(MNDEX(IXD06,2),MRNDX(IXD06),mlim(meng,2),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RADCX0: ALLOCATION FAILS FOR MNDEX,MRNDX,mlim'
        NF=0
        GO TO 1100
      ENDIF
!
! buse flags actual usage of interpolation energies
!
! ex-common/nrbuse/
      allocate(buse(meng),stat=ierr)
!
      if(ierr.ne.0)then
        write(mw0,*)'radcx0: allocation fails for buse'
        nf=0
        go to 1100
      endif
!
      if(buguse)then
        allocate(busi(meng,meng),stat=ierr)
!
        if(ierr.ne.0)then
          write(mw0,*)'radcx0: allocation fails for busi'
          nf=0
          go to 1100
        endif
      endif
!
      allocate(btmp(meng,meng),stat=ierr)
!
      if(ierr.ne.0)then
        write(mw0,*)'radcx0: allocation fails for btmp'
        nf=0
        go to 1100
      endif
!
!-----------------------------------------------------------------------
!
      do m2=1,meng
        do m1=1,meng
          btmp(m1,m2)=.false.
        enddo
      enddo
!
! FIRST PASS SETS PAIRS, BUT MAY NOT CATCH REVERSE ENERGY MATCH
!
!      write(mw0,*)deltax
      TE=DELTAX+DEPS
      NLAG2=(NLAG+1)/2
!
      DO M0=1,MENG0
        M2=IYY0(M0)
        DO M1=M2,MENG
          IF(DYY(M1)-DYY(M2).GT.TE)THEN
            LP=M1
            GO TO 750
          ENDIF
        ENDDO
        LP=MENG
  750   CONTINUE
        LM0=MAX(IONE,M2-NLAG2+1)
        LP0=MIN(MENG,LP+NLAG2)   !NLAG2-1 -> NLAG2 for dipole (see xint)
        DO M1=LM0,LP0
          btmp(m1,m2)=.true.
        ENDDO
      ENDDO
!
! so, if one pair is required, flag the reverse pair as well
!
      do m0=1,meng0
        m2=iyy0(m0)
        if(m2.gt.meng)stop 'sr.radcx0: faulty energy index...'
        do m1=1,meng
          btmp(m2,m1)=btmp(m1,m2)
        enddo
      enddo
!
! Allow user to flag removal, e.g. from a test-run - see sr.dwx, fn.xint
! to uncomment such log info. Be wary if reverse not flagged, maybe need
! by falling order reverse integral.
!
      do n=1,nskpi
        READ(MR5,*)m1,m2
        if(m1.le.meng.and.m2.le.meng)then
          btmp(m1,m2)=.false.
        endif
      enddo
!
! now we can index
!
      MTRAN=0
      do m2=1,meng
        ml=0
        mu=0
        do m1=1,meng
          if(btmp(m1,m2))then
            MTRAN=MTRAN+1
            MNDEX(MTRAN,1)=M1
            MNDEX(MTRAN,2)=M2
!            write(mw6,*)mtran,m1,m2,dyy(m1),dyy(m2)
            mu=m1
          else
            if(mu.eq.0)ml=m1
          endif
        enddo
        if(ixx(m2).gt.0)then                        !a scattering energy
          mlim(m2,1)=ml+1
          mlim(m2,2)=mu
          if(mu-ml.lt.nlag)then
            write(mw0,*)'Not enough interpolation integral energies'
            if(nlag.gt.2)then
              write(mw0,*)'Try decreasing NLAG to',nlag-1
              write(mw6,10180)nlag-1
            else
              write(mw0,*)'Check deltax not set too small?'
!              write(mw0,*)m2,ml+1,mu,dyy(m2),deltax
              write(mw6,10190)deltax
            endif
            nf=-1
            go to 1100
          endif
        else                                     !shouldn't be necessary
          mlim(m2,1)=0
          mlim(m2,2)=-1
        endif
      enddo
!
      if(.not.buguse)then                        !not needed any more
        deallocate(btmp,stat=ierr)
!
        if(ierr.ne.0)then
          write(mw0,*)'radcx0: de-allocation fails for btmp'
          nf=0
          go to 1100
        endif
      endif
!
      WRITE(MW6,10100)MTRAN
      write(mw6,'(20(1x,2i3))')(mndex(m,1),mndex(m,2),m=1,mtran)
!
! SET-UP REVERSE MAPPING INDEX (COULD DO BETTER)
!
      DO M=1,MTRAN
        M1=MNDEX(M,1)
        M2=MNDEX(M,2)
        IF(M1.NE.M2)THEN
          DO MM=1,MTRAN
            IF(M1.EQ.MNDEX(MM,2).AND.M2.EQ.MNDEX(MM,1))THEN
              MRNDX(M)=MM
              GO TO 800
            ENDIF
          ENDDO
          write(mw6,*)'***',m,m1,m2
          stop 'mtran index error 2'                  !should not happen
        ELSE
          MRNDX(M)=M
        ENDIF
  800 ENDDO
!
!-----------------------------------------------------------------------
!
! GENERATE A UNIQUE CONTINUUM DW POTENTIAL FOR THE BASIS
!
!-----------------------------------------------------------------------
!
      T=SQRT(DYY(MENG))                         !FIRST CHECK RADIAL MESH
      IF(T.NE.DZERO)THEN
        T=PI/T
        T=T/DHNSX
!        IF(T.LT.DTWELV)THEN
        IF(T.LT.DSIX)THEN
          M0=MSTEP+1
          WRITE(MW6,10330)DYY(MENG),M0
          WRITE(MW0,*)'RADIAL MESH TOO COARSE'
          NF=-1
          GO TO 1100
        ENDIF
!        ENDIF
      ENDIF
!
      NOCCM=MOD(NOCC,I1000)
      IF(NOCCM.NE.0)THEN               !WE HAVE A UNIQUE SET OF OCC NOS
        IF(NOCCX.EQ.0)THEN             !WE USE THE UNIQUE POTENTIAL
          IF(NOCC.GT.0)WRITE(MW6,10310)MEND,DX(MEND)
          IF(NOCC.LT.0)WRITE(MW6,10320)MEND,DX(MEND)
          JENDX=MEND
          GO TO 900
        ELSEIF(NOCCX.GT.0)THEN               !ADD AN ELECTRON TO N-1 OCC
          NOCC0=NOCC
          NOCC=ABS(NOCC)
          IF(NOCCX.LE.NOCC)THEN
            TEL(NOCCX)=TEL(NOCCX)+DONE
          ELSE
            DO I=NOCC+1,NOCCX
              TEL(I)=DZERO
            ENDDO
            TEL(NOCCX)=DONE
            NOCC=NOCCX
          ENDIF
!         write(mw0,*)(tel(i),i=1,nocc)
          IF(NOCC0.LT.0)NOCC=-NOCC
        ELSE                      !USE UNCREENED FAC N-ELEC OCC FOR CONT
!         write(mw0,*)'fac:'
!         write(mw0,*)(tel(i),i=1,nocc)
        ENDIF
      ENDIF
!
! LOCAL FOR STOPOT
      IF(BSTO)THEN
!
        IXORB1=MXORB+1
!
        ALLOCATE(IVAL(IXORB1),STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'RADCX0: ALLOCATION FAILS FOR IVAL'
          NF=0
          GO TO 1100
        ENDIF
!
        ALLOCATE(SCREEN(IXORB1),STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'RADCX0: ALLOCATION FAILS FOR SCREEN'
          NF=0
          GO TO 1100
        ENDIF
!
      ENDIF
!
      IF(DLAMX.EQ.DZERO)THEN                    !SET DEFAULT CONT LAMBDA
        IF(BSTO)THEN
          DLAMX=DONE
        ELSE                                                         !TF
          IF(NZA.GT.2)THEN
            DLAMX=1.3D0
          ELSE
            DLAMX=DONE+0.1D0*NZA
          ENDIF
        ENDIF
      ENDIF
!
!      NPARAM=NPARAM+1                           !INDEX DLAMX - NOT USED
!
      DJ=DLAMX
      IF(DJ.GT.0)THEN
        MYN=MION+1                                                  !N+1
        DS=DZ
        DJ0=DJ
      ELSE
        IF(IORT.LT.0)DS=-DJ*DZ     !I.E. NOT USED. USE ASYMPTOTIC CHARGE
        DS=NZION-MION
        MYN=1
        DJ0=DONE
      ENDIF
!
      DHNS0=DHNS(1)
      INUK=-1
      MK=MXORB+1
      QN(MK)=-90
      QL(MK)=0
      IEQ(MK)=MK
      MYL=0
!
      IF(BSTO)THEN
        BALAN=.FALSE.
        DO I=1,MK
          IVAL(I)=0                              !NO RYD, BUT FOR STOPOT
        ENDDO
        DO I=1,IXORB1
          SCREEN(I)=DZERO
        ENDDO
        TEL(MK)=0
        IF(MCFMX.GT.0)THEN
          IF(MCFSTOX.EQ.0)MCFSTOX=1
                                         !ASSUME USER LISTS GROUND FIRST
          MCFMX=MK
        ENDIF
        MCFSTO(MK)=MCFSTOX
      ELSE
        DJ1=DONE
        DJ2=DONE
        IF(DLAMDX.NE.DONE)THEN
          IF(ABS(DLAMDX).LT.DHALF)DLAMDX=DLAMDX+DONE !ASSUME REL TO ZERO
          IF(DLAMDX.GT.DHALF)DJ1=DLAMDX
        ENDIF
        IF(DLAMQX.NE.DONE)THEN
          IF(ABS(DLAMQX).LT.DHALF)DLAMQX=DLAMQX+DONE !ASSUME REL TO ZERO
          IF(DLAMQX.GT.DHALF)DJ2=DLAMQX
        ENDIF
        CRRCT1=DZERO
        CRRCT2=DZERO
      ENDIF
!
      MPP=1                                            !PLASMA POTENTIAL
      IF(MDEN.LT.0)MPP=2
!
      IF(.NOT.BSTO)CALL TFDAPO(DS,MYN,MK,DJ0,DJ1,DJ2,DHNS0,MAXRS,MJH,   &
     &                         MNH,DX,DPOT,TOL,MEND,CRRCT1,CRRCT2)
                                                                  !,DHNS
!
      IF(BSTO)CALL STOPOT(DS,MYN,MK,DJ0,DHNS0,MAXRS,MJH,MNH,DHNS,DX,    &
     &                    DPOT,DTOL,MEND,MPP)
!
      IF(NF.LE.0)GO TO 1100                                      !RETURN
!
      IF(DHNS(1).NE.DHNS0)THEN
        WRITE(MW6,*)'SR.RADCX0: PROBLEM GENERATING N+1 POTENTIAL'
        WRITE(MW0,*)'SR.RADCX0: PROBLEM GENERATING N+1 POTENTIAL'
        NF=-1
        GO TO 1100
      ENDIF
!                                                 V(X>X(MEND)) COULOMBIC
      JENDX=MEND
      IF(.NOT.BSTO)THEN
        WRITE(MW6,10260)DJ,MEND,DX(MEND)
        IF(CRRCT1.NE.DZERO)WRITE(MW6,10270)1,DJ1-DONE,CRRCT1
        IF(CRRCT2.NE.DZERO)WRITE(MW6,10270)2,DJ2-DONE,CRRCT2
      ENDIF
!
      IF(BSTO)THEN
        IF(NOCCX.EQ.0)THEN
          WRITE(MW6,10280)MCFSTOX,DJ,MEND,DX(MEND)
        ELSEIF(NOCCX.GT.0)THEN
          WRITE(MW6,10290)NOCCX-mb0,MEND,DX(MEND)
        ELSE
          WRITE(MW6,10300)MEND,DX(MEND)
        ENDIF
      ENDIF
!
! NOW LOOK TO REDUCE RADIAL MESH EXTENT FOR SCATTERING INTEGRALS.
! THIS IS A BALANCE BETWEEN MEMORY USAGE FOR THE BASIS AND TIME
! SPENT RE-GENERATING IT ASYMPTOTICALY.
!
  900 CONTINUE                                   !FAC RE-ENTRY
!
      IF(RZERO.GT.DZERO)THEN
        DO M=1,MAXRS
          IF(DX(M).GT.RZERO)GO TO 950
        ENDDO
        M=MAXRS
  950   MAXPS=M
      ELSE
        MAXPS=0
        DO K=1,MXORB
          IF(DEY(K).NE.DZERO)THEN
            DO M=1,MAXRS
              IF(ABS(DPNL(M,K)).GT.TOLR)MAXPS=MAX(MAXPS,M)
            ENDDO
          ENDIF
        ENDDO
      ENDIF
!
      MAXRS0=MAXRS
      MAXRS=0
      MJH0=MJH
      DO I=1,MJH0
        MAXRS=MNH(I)+MAXRS
        MJH=I
        IF(MAXRS.EQ.MAXPS)GO TO 1000
        IF(MAXRS.GT.MAXPS)THEN
          MAXRS=MAXRS-MNH(I)
          MNH(I)=MAX(MAXPS-MAXRS,ININE)
          MAXRS=MAXRS+MNH(I)
          GO TO 1000
        ENDIF
      ENDDO
!
 1000 WRITE(MW6,10240)MAXRS0,DX(MAXRS0),MAXRS,DX(MAXRS)
!
      IF(ABS(SCALERX-DONE).GT.D1M8)WRITE(MW6,10250)SCALERX
!
! ADD-IN ANY MODEL POTENTIAL (PLASMA, POLARIZATION, C60 ETC)
! CURRENTLY THERE IS NO PLASMA LOOP AND SO INHERITS ANY DENE/TKAY SET.
!
      ZNP=DX(MAXRS0)*DPOT(MAXRS0)
!
      MML=MYL
!ORE              IF(BORT.AND.IEQ(MK).GE.MA.AND.IEQ(MK).LE.MB)MML=-MML
      IF(MDEN.GT.2.AND.MPP.GT.1)ZNP0=ZNP
!
! <=v27.x inherited last atomic plasma potential o.k. for debye perhaps
! but should re-neutralize as have extra continuum electron now.
! also, here we use n+1 tfdapo/stopot whereas atomic is n-electron, so
! to reproduce <=v27.x comment-out vsc minim de-alloc and dwx alloc
! and the call vmpot below.
!
!      write(mw0,*)'radial znp,dz=',znp+1,dz,dpot(100),vsc(100)
      CALL VMPOT(ZNP,MML,MAXRS0,DX,DZ,MAXRS,MPP,-MK,MXORB)
!      write(mw0,*)'radcx0 znp,dz=',znp,dz,dpot(100),vsc(100)
!
      IF(NF.LE.0)GO TO 1100                                   !FAILURE
!
      IF(MDEN.GT.2)MPP=MPP+1
!
! V -> 2(V-Z/R)
!
      DO I=1,MAXRS
        DPOT(I)=DPOT(I)-DZ/DX(I)
        DPOT(I)=DPOT(I)+DPOT(I)
      ENDDO
!
! RE-GENERATE FINITE NUCLEUS
! (ASSUME ANY ISSUES CAUGHT BACK IN SR.RADIAL.)
!
      IF(INUK.LT.0)THEN
!
        CALL VNUKE(DZ,MSTEP,DHNS0,MAXRS,DX,IFLG1,IFLG2)
!
        INUKP=INUK+1
!
      ENDIF
!
! RE-ALIGN FINITE NUCLEUS FOR SR.FCF6
!
      DO I=1,INUK
        DNUK(I)=DTWO*(DNUK0(I)-DZ/DX(I))
      ENDDO
!
      ZS(0)=DTWO*ZS0(0)
!
! INITIALIZE CONTINUUM DW POTENTIAL FOR KAPPA-AVERAGED ORBITALS
!
      IF(BREL)THEN
!
        ALLOCATE(DA(MAXRS),STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'RADCX0: ALLOCATION FAILS FOR DA'
          NF=0
          GO TO 1100
        ENDIF
!
        DO I=1,MAXRS
          DA(I)=DPOT(I)
          DA(I)=DA(I)+DTWO*VSC(I)                        !+PLASMA POT
        ENDDO
!
! SET-UP POTENTIAL DERIVATIVES FOR DARWIN
!
        CALL DIFF(DA,DERV1,MNH,DHNS,MJH)
        CALL DIFF(DERV1,DERV2,MNH,DHNS,MJH)
!
        INUKP=INUK+1
!
        DO I=INUKP,MAXRS
          T=DX(I)**2
          DERV1(I)=DHALF*DERV1(I)-DZ/T
          DERV2(I)=DHALF*DERV2(I)+DTWO*DZ/(T*DX(I))
        ENDDO
!
        DEALLOCATE(DA)
!
! ADD-IN FINITE NUCLEUS
!
        DO I=1,INUK
          DERV1(I)=DHALF*DERV1(I)+DNUK1(I)
          DERV2(I)=DHALF*DERV2(I)+DNUK2(I)
!          write(mw6,*)i,dx(i),dnuk(i),derv1(i),derv2(i)
        ENDDO
!
        DO J=1,JZNM
          ZS(J)=DTWO*ZS0(J)
        ENDDO
!
      ELSE                                !JUST POWER SERIES NEAR ORIGIN
!
        M1=0
        DD=DZERO
!
        CALL FIT(DD,M1,DHNS(1),DPOT,ZS(1))
!
        IF(RNUK.GT.DZERO)THEN                 !ADD-IN FINITE NUCLEUS
          DO J=1,JZNM
            ZS(J)=ZS(J)+DTWO*ZS0(J)
          ENDDO
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
 1100 CONTINUE
!
! LOCAL
      IF(ALLOCATED(DELTAE))THEN
        DEALLOCATE(DELTAE,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'RADCX0: DE-ALLOCATION FAILS FOR DELTAE'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(IXX))THEN
        DEALLOCATE(IXX,IXX0,DXX,DXX0)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'RADCX0: DE-ALLOCATION FAILS FOR IXX,DXX'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(IVAL))THEN
        DEALLOCATE(IVAL,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'RADCX0: ALLOCATION FAILS FOR IVAL'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
      IF(ALLOCATED(SCREEN))THEN
        DEALLOCATE(SCREEN,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'RADCX0: DE-ALLOCATION FAILS FOR SCREEN'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
 1200 WRITE(MW6,10340)
      WRITE(MW0,*)'*** SR.RADCX0: ERROR READING NAMELIST SRADCX0!'
                                                                  !FATAL
      NF=-1
      GO TO 1100
!
!-----------------------------------------------------------------------
!
10010 FORMAT(/' THE NUMBER OF SCATTERED ENERGIES HAS BEEN REDUCED'/     &
     &       ' INCREASE IXENG TO',I4,' TO RETAIN ALL, CONTINUING...'/)
10020 FORMAT(/'TOO MANY INTERPOLATION ENERGIES INCREASE IXENG BUFFER TO'&
     &       ,I4)
10030 FORMAT('***SR.RADCX0: ALLOCATION INCREASES NUMBER OF CONTINUUM ', &
     &       'ENERGIES IXENG =',I4,' .GT. MXENG=',I4)
10040 FORMAT(/'NOT ENOUGH BUFFER SPACE (MXD04), INCREASE IXENG TO',I4,  &
     &       ' OR REDUCE NUMBER OF SCATTERING',                         &
     &       ' AND/OR CHARACTERISTIC ENERGIES')
10050 FORMAT(/'NOT ENOUGH BUFFER SPACE (NDE), INCREASE IXNDE TO',I4)
10060 FORMAT(/'*** WARNING: LARGEST USER SUPPLIED INTERPOLATION ENERGY',&
     &       F10.3/                                                     &
     &       'IS LESS THAN LARGEST SCATTERED ENERGY PLUS TARGET ENERGY',&
     &       F10.3/3X,                                                  &
     & 'TRANSITIONS WITH LARGER EXCITATION ENERGIES WILL BE INACCURATE!'&
     & )
10070 FORMAT(/'*** RE-SETTING SCATTERED ENERGY E=0 TO 0.01 FOR NEUTRALS'&
     &       )
10080 FORMAT(/'*** RE-SETTING INTERPOLATION ENERGY E=0 TO 0.01 FOR ',   &
     &       'NEUTRALS')
10090 FORMAT(//'*** WARNING: YOUR LARGEST CHARACTERISTIC EXCITATION ',  &
     &       'ENERGY',F10.3,' IS LESS THAN THE MAX TARGET ENERGY',      &
     &       F10.3/4X,                                                  &
     & 'TRANSITIONS WITH LARGER EXCITATION ENERGIES WILL BE INACCURATE!'&
     & )
10100 FORMAT(/' RESULTANT TOTAL NUMBER OF ENERGY INTEGRAL PAIRS:',I4/)
10110 FORMAT(//' THE SCATTERED ENERGIES ARE MAPPED TO THE INTERPOLATION'&
     &       ,' ENERGIES AS FOLLOWS:'/(/20(I4,I3)))
10120 FORMAT(//' THE',I4,'  CHARACTERISTIC EXCITATION ENERGIES (RYD)',  &
     &       ' ARE AS FOLLOWS:'/)
10130 FORMAT(//' THE',I4,'  CONTINUUM INTERPOLATION ENERGIES (RYD)',    &
     &       ' ARE AS FOLLOWS:'/)
10140 FORMAT(//' THE',I4,'  INPUT SCATTERED CONTINUUM ENERGIES (RYD)',  &
     &       ' ARE AS FOLLOWS:'/)
10150 FORMAT(10(I3,F10.3))
10160 FORMAT(/' WHERE AN NLAG=',I2,                                     &
     &       '-POINT LAGRANGE INTERPOLATION IS TO BE USED.')
10170 FORMAT(2F10.1,3I5)
10180 FORMAT(//'Not enough interpolation integral energies',            &
     &       ' - try decreasing NLAG to',i3)
10190 FORMAT(//'Not enough interpolation integral energies',            &
     &       ' - check DELTAX=',f10.3,' not set too small?')
10200 FORMAT(/' ****ERROR IN SR.RADCX0, CANNOT READ/USE ADDITIONAL',    &
     & ' SCATTERING ENERGIES WITH THRESHOLD PARTIAL COLLISION STRENGTHS'&
     & ,' (LVMAX.GE.0)'/,                                               &
     & ' ****RE-SET MENG=0 (DEFAULT) AND ADJUST INPUT ACCORDINGLY')
10210 FORMAT(/' ****ERROR IN SR.RADCX0, UNSUITABLE ENERGY RANGE FOR ',  &
     &       'SCATTERING ENERGIES, EMIN=',F10.4,3X,'EMAX=',F10.4/)
10220 FORMAT(/'****ERROR IN SR.RADCX0, REQUIRE AT LEAST TWO ',          &
     &       'SCATTERED ENERGIES TO DEFINE RANGE, CASE MENG.LT.0'/      &
     &       ' BUT MENG=',I3)
10230 FORMAT(/' ****ERROR IN SR.RADCX0, UNSUITABLE ENERGY RANGE FOR ',  &
     &       'INTERPOLATION, EMINI=',F10.4,3X,'EMAXI=',F10.4/)
10240 FORMAT(/' REDUCING RADIAL EXTENT FROM  X(',I5,')=',F8.3,          &
     &       '  TO  X(',I5,')=',F8.3,'  FOR',' SCATTERING INTEGRALS'//)
10250 FORMAT(' *** COWAN SLATER INTEGRAL SCALE FACTOR: ',F7.4//)
10260 FORMAT(///' CONTINUUM S.M.-POTENTIAL WITH SCALE FACTOR',F10.5,    &
     &       ';  COULOMBIC BEYOND R(IEND=',I5,') =',F10.6)
10270 FORMAT(14X,I1,'-POLE PERTURBED SCALE FACTOR',F10.5,               &
     &       ';  COULOMBIC DEVIATION AT R(IEND) =',F10.6)
10280 FORMAT(///' CONTINUUM STO -POTENTIAL CF=',I3,' WITH SCALE FACTOR',&
     &       F10.5,';  NON-COULOMB POT .LT. 1% OF COULOMBIC BEYOND',    &
     &       ' R(IEND=',I5,') =',F10.6)
10290 FORMAT(///' CONTINUUM NOCC-POTENTIAL NOCCX=',I3,';  COULOMBIC',   &
     &       ' BEYOND R(IEND=',I5,') =',F10.6)
10300 FORMAT(///' CONTINUUM FAC -POTENTIAL *UNSCREENED*;  COULOMBIC',   &
     &       ' BEYOND BEYOND R(IEND=',I5,') =',F10.6)
10310 FORMAT(///' CONTINUUM FAC -POTENTIAL (=BOUND);  COULOMBIC BEYOND',&
     &       ' R(IEND=',I5,') =',F10.6)
10320 FORMAT(///' CONTINUUM NOCC-POTENTIAL (=BOUND);  COULOMBIC BEYOND',&
     &       ' R(IEND=',I5,') =',F10.6)
10330 FORMAT(/' SR.RADCX0: EMAX=',1PD9.2,' MESH TOO COARSE, CONTINUUM-',&
     &       'CONTINUUM INTEGRALS IN ERROR.'/                           &
     &       '*** REDUCE EMAX IN NAMELIST ',                            &
     &       'SRADCX0 OR INCREASE MSTEP TO',I3,' IN NAMELIST SMINIM')
10340 FORMAT('*** SR.RADCX0: ERROR READING NAMELIST SRADCX0!'/4X,       &
     &       'IF PRESENT, CHECK FOR ILLEGAL OR MISTYPED VARIABLE NAMES')
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE RADCX0
!
!                             *******************
!
      SUBROUTINE RADIAL(DAJNEW)
!
!-----------------------------------------------------------------------
!
!  SR.RADIAL CALCULATES THOSE RADIAL FUNCTIONS FOR WHICH THE POTENTIAL
!  V(L) IS TO BE CHANGED SINCE PREVIOUS CALLS, DAJNEW(J).NE.DADJUS(J)
!  J=L+1; FOR FUNCTIONS NOT NEEDED DEY(K) HAS BEEN INITIALIZED AS 0.;
!  NK,LK=QN(K),QL(K)/2, NORMALLY (ALGEB1) K=1,2,3.. FOR NL=1S,2S,2P..
!  ALTERNATE STO POTENTIAL AND/OR V(NL).
!
!  IT IS CALLED BY:
!    SR.CALCFX
!    SR.CAVE0
!    SR.MINIM
!
!  IT CALLS:
!    SR.BDCF3
!    SR.BXSCHN
!    SR.DIFF
!    SR.DIMUSE
!    SR.MESH
!    SR.MVDINT
!    SR.QEDINT
!    SR.RADCON
!    SR.RADWAV
!    SR.RADWIN
!    SR.STOPOT
!    SR.TFDAPO
!    SR.VMPOT
!    SR.VNUKE
!    SR.VPNL
!    SR.WEDDLE
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CADJ,   ONLY: ICOUNT,ICOUNT0
      USE COMMON_CADJ,   ONLY: DALAN,BALAN
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_CMESH,  ONLY: MHF,MRAD,MSTEP,IXTRA,xmax
      USE COMMON_CMESH,  ONLY: TINORB,RZERO,MXBOX
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
!      USE COMMON_DMQSS3, ONLY: NL000=>NL,NL=>NL000
      USE COMMON_DXRL,   ONLY: IRL
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_GENINF, ONLY: SCALER
      USE COMMON_INTS,   ONLY: IXD28
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR
      USE COMMON_MINIM,  ONLY: MPNCH,KUTCAS,BPRINT
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
      USE COMMON_REL,    ONLY: DMASS,DCD,D2LL
!
      use common_misc,   only: iw,iwp,btime,btimex
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD,KORT
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL3, ONLY: MCFSS,KCFSS,KUTSS,KUTSO,QQCUT
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,VSC,XC1,XC2,NPITER
      USE COMMON_NRBDQE, ONLY: DQNL,MXQIN,BHFF
      USE COMMON_NRBDR,  ONLY: IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR
      USE COMMON_NRBDW,  ONLY: IDW
      USE COMMON_NRBDWP, ONLY: DLAMX,DLAMDX,DLAMQX,MCFSTOX,NOCCX
      USE COMMON_NRBFSI, ONLY: BNRBFSI,DNLI,NLI
      USE COMMON_NRBINT, ONLY: DRLI,DYY,IYY,NRLI,MENG,NREL,NLAG,NLAGP   &
     &                        ,BLAG,BBC2
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBOLP, ONLY: OVLPGR,OVLPCF,IPAIR
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX                     &
     &                        ,MXBORB,MXVORB,MXFORB,NGRP
      USE COMMON_NRBPOT, ONLY: DPOT,TOL,MEND
      USE COMMON_NRBPOT, ONLY: ZS0,ZS,JZNM
      USE COMMON_NRBPOT, ONLY: POT,JPOT1
      USE COMMON_NRBPOT, ONLY: POTHAM,MPSEUD
      USE COMMON_NRBPOT, ONLY: DERV1,DERV2
      USE COMMON_NRBPOT, ONLY: ALFD,RCUT,ALAV,RCAV,IPOLFN
      USE COMMON_NRBQED, ONLY: VPINT,SLFINT,QED
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBREL, ONLY: RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0
      USE COMMON_NRBREL, ONLY: DNUK0,DNUK1,DNUK2,DNUK
      USE COMMON_NRBSHF, ONLY: DSHIFT,MSHIFT,KSHIFT,MKMAX,MXEP
      USE COMMON_NRBSTO, ONLY: ALF,TEL,MSHELL,MCFSTO,MC,MCFMX,MEXPOT    &
     &                        ,NOCC,IOCC,NLSTOE,BFIX,BSTO,MXSHLL,NGAPSTO&
     &                        ,MEXPOT0,faca,facsp,fac_csi,faclam
      USE COMMON_NRBVAL, ONLY: IVAL,BJUMP,IRAD
      use common_nrbtmp, only: rnorm
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (DEL=D1M6)                 !SEE ALSO MINIM
      PARAMETER (DTOL=D1M2)
      PARAMETER (DKEY=D999)
      PARAMETER (DLAM0=D1M10)              !DAJNEW=DADJUS
      PARAMETER (TOLPP=D1M5)
!
      CHARACTER(LEN=3) LAB1,LAB2
      CHARACTER(LEN=4) TLBL
      CHARACTER(LEN=12) LABB
      CHARACTER(LEN=21) FOUT
!
      ALLOCATABLE :: DEOLD(:)
!
      ALLOCATABLE :: DA(:),DP(:),DQ(:)
!
      DIMENSION DAJNEW(*)    !IN CALCFX,MINIM, BUT LOCAL DEXTRE IN CAVE0
!
      SAVE INUKP,MAXPS
      save maxrs0                      !not necess. but useful for debug
!-----------------------------------------------------------------------
!
      BMVDR=ALLOCATED(DCD)
!
!-----------------------------------------------------------------------
!
      btimet=btime.and.ieq(0).lt.0              !.t. gives more detailed
      if(btimet)call nrb_time(timei)
!
      MAUTOH=MAUTO                                                 !HOLD
!
!   THE RADIAL FUNCTIONS WILL BE CALCULATED UNTIL THE RELATIVE CHANGE
!     IN THE EIGENVALUE IS SMALLER THAN TOL
!
      TOL=DONE/10**ITOL
!
      MDEN10=MOD(MDEN,ITEN)
      IF(MDEN.NE.0)THEN
!
! MIGHT BE FASTER TO USE OLD DENSITY FUNCTIONS?
!  SO COMMENT-OUT MP0 BELOW.....
        MP0=0
!
! MAX NO OF ITERATIONS OF RADIAL FUNCTIONS FOR SELF-CONSISTENT SOLUTION
!  SUBJECT TO ALL EPSILONS CONVERGING TO TOLPP (THEN BMPP=.FALSE.)
!
        MPP5=ABS(NPITER)
        IF(MDEN.LT.-1)MPP5=MAX(-MDEN,MPP5)
        MPP=1
        IF(BJUMP)MPP=2
        BMPP=.FALSE.
        KDEX=0
        TPEX=DZERO
        TDEX=DZERO
!
        ALLOCATE(DEOLD(MXORB))
!
        do i=1,mxorb
          DEOLD(i)=DZERO
!          rinf2(i)=d1p10
        enddo
!
      ELSE
        MPP=0
      ENDIF
!
      BDR=IDR.NE.0
!      BCONT=MODE.EQ.2.OR.MODE.EQ.3
!
      DZ=NZION
      BREL2=ABS(IREL).EQ.2
!
      IPOTJ=0
      JPOT=-1
      JPOT0=JPOT
      KPOT=0
!
      LOLD=-1
      EOLD=DZERO
      DDE=DONE                                   !FOR NO NEW DQNL
      NZA=MAX(IONE,NZION-MION+1)
      TOLR=DEL/NZA
      NOCCM=MOD(NOCC,I1000)
!
      BORT=MORT.LT.0        !.T.= NL-DEP, BUT MAY NOT ORTHOG! ELSE L-DEP
      IORT=ABS(MORT)
      IF(IORT.EQ.5)TOLR=TINORB                   !RZERO
!
      BHF=MHF.GT.0
!      IF(BHFF)BHFF0=.TRUE.
      BPRNT0=BPRINT
      IF(BPRINT)BPRNT0=JPRINT.NE.-3
      BPRNT3=JPRINT.NE.-3
!
      MB0=MB
!p      IF(IEQ(0).LT.0)MXBORB=-IEQ(0)              !FOR NON-UNIQUE BASIS
      IF(IEQ(0).GT.0)THEN                        !UNPACK
        IF(IRLX.LT.0)MB0=0                  !IRLX.LT.0 MEANS IEQ(0).GT.0
!p        ID=IEQ(0)-MXORB
!p        NGRP=ID/100000
!p        ID=ID-100000*NGRP
!p        MXFORB=ID/10000
!p        ID=ID-10000*MXFORB
!p        MXVORB=ID/1000
!p        ID=ID-1000*MXVORB
!p        MXBORB=ID
!pc       write(mw0,*)ngrp,mxborb,mxvorb,mxforb
      ENDIF
!
! SOME INITIALIZATIONS
!
      ALLOCATE(IRAD(MXORB))                         !FOR RADWIN (EVNTLY)
!
      IF(.NOT.BJUMP)THEN
!
        MSHIFT=10000
        TSHFT=4*MSHIFT
        BLAG=.FALSE.
!
        IVLSUM=0
        DO I=1,MXORB
          IVLSUM=IVLSUM+IVAL(I)
          IRAD(I)=0
          DSHIFT(I)=DZERO
          MI=QN(I)
          QN(I)=INT(ABS(MI),QP)
          IYY(I)=-1
          DORIG(I)=DZERO                            !FOR SAFETY
        ENDDO
        IF(IVLSUM.NE.0.AND.MORT.LE.-4.AND.IUNIT(MW16).EQ.0)THEN !BOX/LPS
          IUNIT(MW16)=1
          OPEN(MW16,FILE='OVRLAP',STATUS='REPLACE')
                                                   !ORBITAL OVERLAP LIST
        ENDIF
!
        IF(IRLX.EQ.2)THEN
          II=(MXORB*(MXORB-1))/2
          DO I=1,II
            OVLPGR(I)=DZERO
          ENDDO
          II=(KMAX*(KMAX-1))/2
          DO I=1,II
            OVLPCF(I)=DZERO
          ENDDO
        ENDIF
!
      ENDIF
!
! PRINT DETAILS OF RELATIVISTIC RADIAL OPERATORS IN USE
!
      INUK=-1
      IF(BREL.AND.BPRNT0)THEN
        LAB1='OFF'
        IF(ABS(IREL).EQ.2)LAB1=' ON'
        LAB2='OFF'
        IF(IRTARD.NE.0)LAB2=' ON'
        WRITE(MW6,10220)LAB1,IREL,LAB2,IRTARD
        LABB='            '
        IF(IBREIT.LT.0)LABB='GENERALIZED+'
        IF(IBREIT.GT.0)LABB='GENERALIZED '
        WRITE(MW6,10210)-KUTSO,KUTSS,KUTOO,LABB,IBREIT,QED
      ENDIF
!
! CALCULATE DPNL(I,K)=<NL(K)!X(I)> FOR NK,LK=QN(K),QL(K)/2 AT X(I)
!   ACCORDING TO INTERVAL SET-UP OF STATISTICAL MODEL(=S.M.) POTENTIAL
!   EVALUATE DUY(J,K)=<NL(J)! V(L)-Z/X !NL(K)> FOR LJ=LK=L, E&N 2.8,
!   AND FOR N'=N DEY(K)=DUY(K,K)+EIGENENERGY/2RY(=2EPSILON,E+N2.1)
!
! SR. TFDAPO CALCULATES STATISTICAL MODEL POTENTIAL FOR MION ELECTRONS
!   AND ELECTRIC NUCLEAR CHARGE DZ; SR. STOPOT CALCULATES SLATER-TYPE-
!   ORBITAL UNIVERSAL POTENTIAL FOR MION-1 ELECTRON ION WITH CHARGE DZ
!   OUTPUT: POTENTIAL IN /COM1/, DX(I)=X(I) FROM INTERVAL SET-UP MJH..
!   DHNS(M)=DHNS(1)*2**(M-1); DX(IEND)=RANGE OF NON-COULOMB POTENTIAL
!
! SR. RADWAV CALCULATES RADIAL FUNCTIONS RHO IN POTENTIAL FROM TFDAPO
!   IF BSTO .FALSE. (NZION .GT. 0 READ-IN SR.MINIM) OR FROM STOPOT
!   IF BSTO .TRUE.  (NZION .LT. 0 READ-IN SR.MINIM).
!   FOR SCREEN(K)=SCREENING PARAMETERS SEE NOTE IN SR MINIM
!
! FIRST, SET-UP THE MAXIMAL RADIAL MESH, MAXRS POINTS.
!
! THIS WILL EVENTUALLY BE TRUNCATED TO MAXPS, WHICH CONVERGES INTEGRALS.
!
! NOTE: DO NOT NEED TO DEFINE A SEPARATE MAXPS MESH FOR INTEGRALS IN
! SR.RADIAL SINCE ONLY ONE-BODY EXIST AND SR.WEDDLE CAN HANDLE MAXPS
! NON-ALIGNED WITH THE MNH(I),I=1,MJH WHICH DEFINES MAXRS.
!
      IF(MAXRS.EQ.0)MAXPS=0          !INITIALIZE
!
      IFLAGR=0
  100 IFLAGR=IFLAGR+1
!
      CALL MESH(NZION,MION,TOLR,DHNS0,DX,IFLAGR)
!
      IF(NF.LE.0)GO TO 2100
!
      MAXRS0=MAXRS                   !MAXRS WILL BE TRUNCATED EVENTUALLY
!
! NOW SET-UP FINITE NUCLEUS
!
      IF(INUK.LT.0)THEN
!
        CALL VNUKE(DZ,MSTEP,DHNS0,MAXRS,DX,IFLG1,IFLG2)
!
        IF(DHNS0.GT.DHNS(1)*D1PT05)THEN       !CURRENTLY, ONLY DECREASED
          DHNS(1)=DHNS0
          INUK=-1
          GO TO 100
        ELSEIF(DHNS0.LT.DHNS(1)/D1PT05)THEN
          GO TO 2200                   !AS DX ETC NOT RE-ALLOCATABLE YET
        ENDIF
!
        INUKP=INUK+1
!
      ENDIF
!
! WRITE SOME MESH INFO
!
      JI=1
      IF(BORT.AND.MXQIN.LT.50)WRITE(MW6,10170)MXQIN
      IF(BPRNT3.AND..NOT.BJUMP)THEN
        WRITE(MW6,10230)TOL,MAXRS,MSTEP,NZION,MION
        IF(.NOT.BORT.AND.BHFF.AND.MAUTO.GE.0)WRITE(MW6,10240)IXPOT
        IF(BSTO.AND.MHF.EQ.0)THEN
          IF(MEXPOT0.GT.0.AND.MDEN.NE.0)THEN
            WRITE(MW6,10250)MEXPOT+10*MEXPOT0
          ELSE
            WRITE(MW6,10250)MEXPOT
          ENDIF
        ENDIF
      ENDIF
!
! WRITE STO INFO (OCCUPATION NOS ETC)
!
      IF(BSTO.AND.BPRNT0.AND.MHF.EQ.0)THEN
!
        IF(BALAN)WRITE(MW6,10260)
!
        IF(NOCCM.NE.0)THEN
!
          WRITE(MW6,10270)
!
          WKT=0
          DO I=1,ABS(NOCC)
            WKT=WKT+TEL(I)
            WRITE(MW6,"(I4,F10.4)")I,TEL(I)
          ENDDO
          WRITE(MW6,10280)WKT
!
        ELSE
!
          IF(MCFMX.EQ.0.AND.IRLX.EQ.0)WRITE(MW6,10290)KMAX
          IF(MCFMX.LT.0.AND.NOCC.LE.0)THEN
            WRITE(MW6,10300)MIN(-MCFMX,KMAX)
            WRITE(MW0,10300)MIN(-MCFMX,KMAX)
          ENDIF
!
        ENDIF
!
      ENDIF
!
! PRE-LOAD EXTERNAL ORBITALS, CASE SELF-CONSISTENT CONFIG. AVERAGE POT
!
      IF(BHFF.AND.MDEN.LT.0)THEN
!
        DO K=1,MXORB
          IF(SCREEN(K).GE.D999.AND.SCREEN(K).LT.D5999)DADJUS(K)         &
     &       =DAJNEW(K)                                   !FLAG COMPUTED
          IF(SCREEN(K).LT.D999)DEY(K)=DZERO       !AS NOT YET CALCULATED
        ENDDO
!
        CALL RADWIN(MAXPS)
!
        BHFF=.FALSE.
        IF(MAUTO.EQ.0)MAUTO=1                          !FOR RADCON
!
        DO K=1,MXORB
          IF(DADJUS(K).EQ.DAJNEW(K))SCREEN(K)=-3999    !RE-FLAG EXTERNAL
          IF(SCREEN(K).GT.DZERO)DEY(K)=DONE            !RE-FLAG FOR CALC
        ENDDO
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! THE NAMES HERE ARE NOT NECESSARILY SIGNIFICANT THEY ARE COMMON LEGACY.
!
! LOCAL
      ALLOCATE(DA(MAXRS),DP(MAXRS),DQ(MAXRS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RADIAL: ALLOCATION FAILS FOR DA,DP,DQ'
        NF=0
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
! BEGIN OUTER LOOP OVER L/NL-DEPENDENT LAMBDAS/ORBITALS
!
      NP0=0
      IF(IPOLFN.LT.0)NP0=-IPOLFN
      NPARM3=(NP0+1)*NPARAM
!
  200 DJ=DZERO
!
      DO J=1,NPARAM               !<------------------------------------
!
!
        IF(IORT.LT.4)THEN
          DO N=0,NP0
            N0=N*NPARAM+J
            IF(ABS(DAJNEW(N0)-DADJUS(N0)).GT.DLAM0)GO TO 250
          ENDDO
          GO TO 800
        ENDIF
!
  250   CONTINUE
!
        JEND(J)=MEND
        IF(BORT)THEN
          IF(SCREEN(J).GT.D5999.AND.IVAL(J).EQ.0)GO TO 800
          IF(SCREEN(J).GT.DKEY.AND.IVAL(J).EQ.0)GO TO 700
          JI=J
        ELSE
          IPOTJ=J
        ENDIF
!
! BEGIN INNER LOOP OVER ORBITALS
!
        DO K=JI,MXORB             !<------------------------------------
!
!
          IF(DEY(K).EQ.DZERO)GO TO 580
          IF(BJUMP.AND.IVAL(K).EQ.0)GO TO 580
!
          MK=K
          MYN=QN(K)
          MYL=QL(K)/2
!
          INK=ICOL(K,K,IZERO)
!
          IF(DEY(K).EQ.DONE)DUY(INK)=DZERO
!
! !test/pass unique fac potl
          if((nocc.gt.0.or.mhf.eq.2).and.mpp.lt.2.and.kpot.eq.0)then
            jpot=0                            !n.b. can't flag until we
            jpot0=0                           !actually have an sto potl
          endif
!
! SET-UP POTENTIAL, EITHER USE EXISTING ONE OR GENERATE A NEW ONE
!
          MRED=0
          IF(BORT)THEN
            IF(.NOT.BSTO)THEN                     !TRY AND "OPTIMIZE" TF
              IF(MORT.GT.-4)then
                if(ieq(0).lt.0)then                       !RELAXED BASIS
                  kf=igrcf(k)
                  if(kf.gt.0)then
                    ii=qcg(nf,kf)       !CHECK OUTER ORBITAL FOR CF TYPE
                    if(abs(qn(ii)).lt.90.and.ival(ii).eq.0)then
                      mred=0                                  !N+1 BOUND
                    else
                      mred=1                   !RYD/CONT, SO REDUCE CORE
                    endif
                  else
                    if(idr.gt.0)mred=1                      !CLOSED CORE
                  endif
                elseif(ieq(0).gt.0)then   !FIND OUTER ORB GROUP BOUNDARY
                  if(ieq(k).gt.mb0)then
                    if(ival(k).eq.0)then
                      lf=mxborb*ngrp+mb0
                      do l=lf+1,mxorb
                        if(dey(l).ne.dzero.and.igrcf(l).eq.igrcf(k))then
                          if(abs(qn(l)).ge.90.or.ival(l).ne.0)then
                            mred=1                             !RYD/CONT
                            go to 252
                          endif
                        endif
                      enddo
  252                 continue
                    endif
                  else
                    if(idr.gt.0)mred=1
                  endif
!        mred=0   !test
!          write(mw0,*)'mred:',k,mred
                else                                       !UNIQUE BASIS
                  if(idr.gt.0)mred=1                          !DR "CORE"
                endif
!TEST                                                    !PS CLOSED CORE
!TEST     elseIF(MORT.EQ.-4.AND.IEQ(K).GE.MA.AND.IEQ(K).LE.MB)then
!TEST       MRED=1
              ENDIF
            ENDIF
!
            LI=1                             !LOWER ORB BOUND FOR ORTHOG
            LF=K                             !UPPER ORB BOUND FOR ORTHOG
!
            if(ieq(0).ne.0.and.irlx.ne.2)then   !FIND ORB GROUP BOUNDARY
              ng=igrcf(k)
              li=mxborb*(ng-1)+mb0+1
              if(ival(k).ne.0)lf=li+mxborb-1
!         write(mw0,*)'orthog',ng,':',li,lf,k
            endif
!
!        write(mw6,*)k,ival(k),mred
            IF(IVAL(K).EQ.0.and.nocc.le.0)GO TO 280         !NON-VALENCE
            MRED=MION-NF-NW                      !0 UNLESS MRED USER-SET
            if(ieq(0).ne.0)go to 300
!
            IF(JPOT.GT.0)GO TO 360
!        IF(.NOT.BSTO.OR.BSTO.AND.IVLSUM.EQ.1)THEN   !POT NOT DEFINED IN
            JPOT=1                   !RADCON FOR RYD ORB APPROXED BY K=0
            IF(BJUMP)GO TO 260
            JPOT=0
!        ENDIF
            GO TO 300
!
          ELSE                                !HISTORIC L-DEPENDENT POTS
!
            JPOT=MYL+1
            IF(JPOT.NE.J)GO TO 600                         !IPOTJ=J HERE
            IF(DAJNEW(J).EQ.DJ.AND.IORT.LT.4)GO TO 360
            IF(.NOT.BJUMP)GO TO 300
            IF(JPOT.GT.IXPOT)JPOT=IXPOT
!
          ENDIF
!
  260     IF(SCREEN(K).GT.DKEY)GO TO 580
!
! LOAD OLD POTENTIAL
!
          DO I=1,MAXRS
            DPOT(I)=POT(I,JPOT)
          ENDDO
          MEND=JEND(J)
          DJ=DAJNEW(J)
          GO TO 340
!
  280     CONTINUE
!
! POTENTIAL UNCHANGED FROM LAST CALL
!
          BTEST1=.NOT.BSTO.OR.MHF.EQ.1.OR.MHF.EQ.2      !TF/external/FAC
          BTEST2=DAJNEW(J).EQ.DJ.AND.IORT.LT.4.AND.IPOLFN.EQ.0
          btest=dj.ne.dzero.and.balan.and.iocc.gt.mshell     !unique STO
          if(btest.and.ieq(0).eq.0.and.bprnt3.and.mpp.le.0)then   !write
            IF(.NOT.BHF)then
              WRITE(MW6,10140)MYN,MYL,MCFSTO(K),DAJNEW(J),MEND,DX(MEND)
            else
              WRITE(MW6,10100)MYN,MYL,MHF,MEND,DX(MEND)
            endif
            go to 360
          endif
          BTEST=BTEST1.AND.BTEST2.or.btest
          IF(BTEST.and.ieq(0).eq.0)GO TO 360
!
! GENERATE NEW POTENTIAL
!
  300     DJ=DAJNEW(J)
          DJ0=DJ
          IF(.NOT.BSTO)THEN
            DJ1=DONE
            DJ2=DONE
            IF(NP0.GT.0)DJ1=DAJNEW(NPARAM+J)
            IF(NP0.EQ.2)DJ2=DAJNEW(2*NPARAM+J)
          ENDIF
!
          DS=DZ
!
          MIONX=max(MION-MRED,IONE)                  !EXPECTED NO. ELECS
          MION1=MIONX
!
          IF(DJ.GT.DZERO)GO TO 320
          IF(IORT.EQ.2)GO TO 320                    !CUSP CONDITION
          IF(BREL)GO TO 320                         !MUST SET POT RADWAV
!
          IF(IORT.LT.4)DS=-DJ*DZ                    !HYDROGENIC ORBITALS
          IF(IORT.EQ.4)DS=-MYN*(NZION-MIONX+1)*DJ/DTWO
                                                    !PSEUDO-STATE BASIS
          IF(IORT.EQ.5)DS=-(NZION-MIONX+1)*DJ        !BOX-STATE BASIS
!
          MION1=1
          DJ0=DONE
!
! THOMAS-FERMI DIRAC AMALDI POTENTIAL
!
  320     IF(.NOT.BSTO)CALL TFDAPO(DS,MION1,MK,DJ0,DJ1,DJ2,DHNS0,MAXRS, &
     &                             MJH,MNH,DX,DPOT,TOL,MEND,CRRCT1,     &
     &                             CRRCT2)                        !,DHNS
!
! SLATER-TYPE ORBITAL POTENTIAL
!
          IF(BSTO)CALL STOPOT(DS,MION1,MK,DJ0,DHNS0,MAXRS,MJH,MNH,DHNS, &
     &                        DX,DPOT,DTOL,MEND,MPP)
!
          IF(NF.LE.0)GO TO 2100                                  !RETURN
!
          IF(DHNS0.GT.DHNS(1)*D1PT05)THEN             !POTENTIAL FAILURE
! TRY INCREASING RANGE BY DOUBLING OF INITIAL STEP, NO REALLOCATION HERE
            if(iflagr.gt.1)then           !only double initial step once
              write(mw0,*)                                              &
     &       '***SR.RADIAL: MESH/POTENTIAL/OPTIMIZATION OUT OF CONTROL?'
              write(mw6,*)                                              &
     &       '***SR.RADIAL: MESH/POTENTIAL/OPTIMIZATION OUT OF CONTROL?'
              write(mw6,*)(dajnew(i),i=1,nparm3)
              go to 2200
            endif
            DO I=1,NPARM3
              DADJUS(I)=DZERO
            ENDDO
            IF(IUNIT(MR12).GT.0)THEN            !BHFF0
              REWIND(MR12)
              BHFF=.TRUE.
            ENDIF
            MAXPS=0
            JPOT=-1
            DHNS(1)=DHNS0                       !HISTORIC DOUBLING
            xmax=d3half*abs(xmax)               !limit increase
!
            DEALLOCATE(DA,DP,DQ,STAT=IERR)      !FUTUREPROOF
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'RADIAL: DE-ALLOCATION FAILS FOR DA,DP,DQ'
              IF(NF.GT.0)NF=0
              GO TO 2100
            ENDIF
!
            GO TO 100
          ELSEIF(DHNS0.LT.DHNS(1)/D1PT05)THEN    !CURRENTLY NOT POSSIBLE
            GO TO 2200                    !DX ETC NOT RE-ALLOCATABLE YET
          ENDIF
!
          IF(.NOT.BPRNT3.OR.MPP.GT.1)GO TO 340
          IF(.NOT.BORT)THEN
            IF(.NOT.BSTO.AND..NOT.BHF)WRITE(MW6,10150)MYL,DJ,MEND,      &
     &         DX(MEND)
            IF(BSTO.AND..NOT.BHF)WRITE(MW6,10160)MYL,DJ,MEND,DX(MEND)
            IF(BHF)WRITE(MW6,10090)MYL,MHF,MEND,DX(MEND)
            GO TO 340
          ENDIF
!
          IF(BORT.AND..NOT.BSTO.AND..NOT.BHF)THEN
            IF(IEQ(0).EQ.0)THEN
              WRITE(MW6,10110)MYN,MYL,DJ,MEND,DX(MEND)
              IF(NP0.GT.0)WRITE(MW6,10120)1,DJ1-DONE,CRRCT1         !DJ1
              IF(NP0.EQ.2)WRITE(MW6,10120)2,DJ2-DONE,CRRCT2         !DJ2
            ELSE
              WRITE(MW6,10130)K,IGRCF(K),MYN,MYL,DJ,MEND,DX(MEND)
            ENDIF
          ENDIF
          IF(BSTO.AND..NOT.BHF)WRITE(MW6,10140)MYN,MYL,MCFSTO(K),DJ,    &
     &                               MEND,DX(MEND)
          IF(BHF)WRITE(MW6,10100)MYN,MYL,MHF,MEND,DX(MEND)
!
  340     CONTINUE
!
          KPOT=1                      !FLAG WE ACTUALLY HAVE A POTENTIAL
!
! EVALUATE MODEL PTOL, E.G. POLARIZATION PTOL, OR PLASMA SCREENING PTOL,
! APPLIED TO ALL ORBITALS. TO SWITCH-OFF FOR CORE REQUIRES UNCOMMENTING
! 'CORE' BELOW AND IN SR.RADCON
!
          ZNP=DX(MAXRS)*DPOT(MAXRS)
          MML=MYL
!ORE  IF(BORT.AND.IEQ(MK).GE.MA.AND.IEQ(MK).LE.MB)MML=-MML
          IF(MCFMX.GT.0)ZNP0=-D99
!
          CALL VMPOT(ZNP,MML,MAXRS,DX,DZ,MAXPS,MPP,MK,MXORB)
!
          IF(NF.LE.0)GO TO 2000                                 !FAILURE
!
! EVALUATE DIFFERENTIALS OF POTENTIAL FOR MASS-VELOCITY AND DARWIN
! FOR USE BY PMVDAR (HANDLE POINT NUCLEAR ANALYTICALLY).
! COULD ADD-IN PLASMA POT - SEE ALSO FN.PMVDAR
!
          IF(BREL)THEN
!
! NOTE DIFFERENCE OF /COM1/DPOT POTENTIAL TO SR.RADCON/FCF6 USE
            IF(MDEN.EQ.0)THEN
              DO I=1,MAXRS
                DA(I)=DPOT(I)-DZ/DX(I)                   !SUBTRACT POINT
              ENDDO
            ELSE                                         !ADD PLASMA POT
              DO I=1,MAXRS
                DA(I)=DPOT(I)-DZ/DX(I)+VSC(I)         !-POINT+PLASMA POT
              ENDDO
            ENDIF
!
            CALL DIFF(DA,DERV1,MNH,DHNS,MJH)
            CALL DIFF(DERV1,DERV2,MNH,DHNS,MJH)
!
            DO I=INUKP,MAXRS                             !ADD POINT BACK
              DD1=DX(I)**2
              DERV1(I)=DERV1(I)-DZ/DD1
              DERV2(I)=DERV2(I)+DTWO*DZ/(DX(I)*DD1)
!         if(i-inuk.lt.150)write(mw6,*)i,dx(i),dpot(i),derv1(i),derv2(i)
            ENDDO
!
! ADD-IN FINITE NUCLEUS
!
            DO I=1,INUK
              DERV1(I)=DERV1(I)+DNUK1(I)
              DERV2(I)=DERV2(I)+DNUK2(I)
!          write(mw6,*)i,dx(i),dpot(i),derv1(i),derv2(i)
            ENDDO
!                             MAY SMOOTH EDGE, CASE UNIFORM
            IF(IFLG2.GT.IFLG1)THEN
!        write(mw0,*)
!     &    iflg1,iflg2,dx(iflg1),dx(iflg2),dnuk2(iflg1),dnuk2(iflg2)
              DXX=DX(IFLG1)-DX(IFLG2)
              DO I=IFLG1,IFLG2
                DERV2(I)=DERV2(IFLG1)*(DX(I)-DX(IFLG2))/DXX-DERV2(IFLG2)&
     &                   *(DX(I)-DX(IFLG1))/DXX
!            write(mw0,*)i,dx(i),dnuk2(i)
              ENDDO
            ENDIF
!
          ENDIF
!
! NOW ENTER SECTION TO GENRATE RADIAL ORBITAL, NUMERICALLY IN
! RADWAV OR ANALYTICALLY (NON-REL COULOMB, INC. LAGUERRES) IN BDCF3
!
  360     KAPPA=0     !PMVDAR IGNORES KAPPA AND USES ITS OWN, DEFAULT -1
!
!      if(myl.gt.0)kappa=-myl-1                   !myl or -myl-1
!
          JEND(J)=MEND
          SC=SCREEN(K)
          IF(SC.GT.DKEY)GO TO 580
          BJUMPR=.FALSE.
!
          IF(SC.LE.-DKEY)THEN     !RADIAL SHIFTS BOUND TO SUPRESS MIXING
            QN(K)=-QN(K)             !SO TESTS ETC ON QN(K)<0, NOT MYN>0
            SC=(QL(K)+1)*MYN
            IF(SC.GE.MION)SC=MION-1
            MODE=4
          ENDIF
!
          IF(DJ.GT.DZERO)GO TO 380                !DW OR REL COULOMB
!
          DS=DJ*DZ                                !COULOMBIC, LAGUERRES
          SC=DZ+DS
!
          IF(IORT.EQ.2)GO TO 380                  !USE RADWAV
          IF(BREL)GO TO 380                       !REL COULOMB
          IF(DENE.NE.DZERO)GO TO 380              !PLASMA SCREENING
!
          IF(IORT.EQ.4)DS=MYN*(NZION-MIONX+1)*DJ/DTWO !NON-REL LAGUERRES
          IF(IORT.EQ.5)DS=-(NZION-MIONX+1)*DJ     !BOX STATES
!
          IF(MODE.EQ.4)IYY(K)=1
          DD2=MYN
          DE=DS/DD2
          DE=-DE*DE
          M=1
!
          IF(IORT.NE.5)THEN                         !HYDROGENIC/PS
!
            CALL BDCF3(DP,DE,MYN,MYL,DS,M,MAXRS,DX) !AS DS.LT.0 HERE
!
            IF(MYL.LT.0)GO TO 2200                              !FAILURE
          ELSE                                      !BOX
            IF(MYL.EQ.LOLD)THEN
              IF(EOLD.GT.DZERO)DE=EOLD*D1PT05
              IF(EOLD.LE.DZERO)DE=EOLD/D1PT05
            ENDIF
!
            CALL BXSCHN(MJH,MNH,DHNS,DS,MYN,MYL,DE,DP,DX,MXBOX,MSTEP)
!
            IF(MYL.LT.0)THEN
              WRITE(MW6,*)'*** BXSCHN FAILURE...'
              WRITE(MW0,*)'*** BXSCHN FAILURE...'
              GO TO 2200
            ENDIF
!
            LOLD=MYL
            EOLD=DE
          ENDIF
!
          DP0=DP(1)/DX(1)**(MYL+1)
          GO TO 400
!
!T  TEST CODE RE-ENTRY POINT FOR GO TO AT STATEMENT 642
!T  55  BJUMPR=.TRUE.
!T      BREL=.FALSE.
!
!
  380     CALL RADWAV(MK,MYN,MYL,DZ,MAXRS,MJH,MNH,DHNS,DX,SC,DP,DQ,DE,  &
     &                DP0,DQ0,pnorm,rtwo)
!
!
          IF(NF.LE.0)GO TO 2100
!
          IF(.NOT.BJUMP.AND.BPRNT3.AND.(MDEN10.GT.2.OR.MDEN.LT.0))      &
     &       WRITE(MW6,10070)MYN,MYL,DE,MPP
!
          IF(MYN.LE.0.OR.MYL.LT.0)THEN
            WRITE(MW6,*)'*** SR.RADWAV FAILURE...'
            WRITE(MW0,*)'*** SR.RADWAV FAILURE...'
            if(balan)then
              write(mw0,*)'Unphysical STO potential?'
              write(mw6,*)'Unphysical STO potential?'
              write(mw6,*)(dajnew(i),i=1,nparm3)
            endif
            GO TO 2200
          ENDIF
!
          if(bort.and.mend.ne.jend(k))then
            stop 'mend.ne.jend'                    !should not happen...
          endif
          if(mend.eq.0)then
            stop 'sr.radial: mend=0'               !should not happen...
          endif
!
!      rinf2(k)=rtwo              !hydrogenic estimate seems good enough
          rnorm(k)=pnorm
!      write(mw0,*)k,rtwo  !pnorm
!
  400     IF(MGRP.LT.0)THEN
            T0=MION-1
            T1=MYN
            T0=T1*(T0-SC)
            SC=T0/(DZ-SC)
          ENDIF
          IF(SCREEN(K).LT.DKEY)SCREEN(K)=SC
!
          DDE=DE
          IF(BREL2)DDE=DZERO   !IF BREL THEN OMITS DDE FROM DQ IF ORTHOG
!
          DO M=1,MAXRS
            IF(ABS(DP(M)).GT.TOLR)MAXPS=MAX(M,MAXPS)
            DPNL(M,K)=DP(M)
          ENDDO
          IF(BREL2)THEN
            DO M=1,MAXRS
              DQNL(M,K)=DQ(M)
            ENDDO
          ELSE
!        write(mw6,*)'k=',k,dz,dde
            DO M=1,MAXRS
              DQNL(M,K)=((DPOT(M)-DZ/DX(M)+VSC(M))*DTWO+DDE)*DP(M)
!          if(m.le.maxps)write(mw6,*)m,dx(m),DQNL(M,K),dpot(m)*dx(m)-dz
            ENDDO
          ENDIF
!
          IF(BJUMPR)GO TO 560
!
          if(mden.ne.0)then
            IF(IEQ(K).GT.MB)THEN           !LEVELS INSENSITIVE TO COMMON
              TPE=-ABS(DE-DEOLD(K))/DE
              IF(TPE.GT.TOLPP)THEN                           !KEEP GOING
                BMPP=.TRUE.
                IF(TPE.GT.TPEX)THEN
                  KDEX=K
                  TPEX=TPE
                  TDEX=DEOLD(K)                   !AS DEOLD GETS UPDATED
                ENDIF
              ENDIF
            ENDIF
!            bmpp=.true.                          !force at least npiter
!            mpp5=npiter
            DEOLD(K)=DE
          endif
!
          DE=DE/DTWO
          DDE=DDE/DTWO
          DEY(K)=DE                          !FLAG EXISTS, or for radwin
          IRAD(K)=1
          DORIG(K)=DP0
          K0=K
          IF(BJUMP)K0=MXORB
!
          IF(.NOT.BORT)THEN
            IF(ICOUNT.LT.ICOUNT0)K0=MXORB
            GO TO 500                        !AS HAVE UNMODIFED "DQNL"
          ENDIF
!
          IF(IRLX.NE.2)THEN
            IF(MORT.EQ.-3)THEN
              IF(ICOUNT.LT.ICOUNT0)K0=MXORB
              IF(BREL)GO TO 500
              GO TO 460
            ENDIF
            IF(KORT.NE.0.AND.IVAL(K).GT.0)GO TO 460  !NON-ORTHOG RYDBERG
          ENDIF
!
! ORTHONORMALIZE
!
          DS=DZERO
!
          DO L=1,K
!
            IF(DEY(L).EQ.DZERO)GO TO 420                 !DOES NOT EXIST
            IF(QL(K).NE.QL(L))GO TO 420                  !WRONG ORB A.M.
            IF(MORT.LT.0.AND.IRLX.NE.2.AND.QN(K).EQ.QN(L).AND.L.NE.K)   &
     &         GO TO 420                                     !FOR SAFETY
!        IF(MORT.LE.-4.AND.QN(K).EQ.QN(L).AND.L.NE.K)GO TO 635  !BOX/LPS
            IF(L.LT.LI.AND.L.GT.MB0)GO TO 420          !CASE IEQ(0).GT.0
            if(l.gt.lf.and.l.lt.k)go to 420            !case ieq(0).gt.0
            IF(IVAL(K)+IVAL(L).EQ.2.AND.IRLX.NE.2.AND.QN(K).EQ.QN(L)    &
     &         .AND.L.NE.K)GO TO 420                       !SKIP RYDBERG
!        IF(IVAL(K)+IVAL(L).EQ.1.AND..NOT.BSTO.AND.IRLX.NE.2)GO TO 635
            IF(SCREEN(L).GE.DKEY)GO TO 580             !NOT YET COMPUTED
            IF(L.EQ.K.AND.(DS.EQ.DZERO.OR.IRLX.EQ.2))GO TO 440
                                                           !SKIP UNMODFD
!
            IF(BREL2)THEN
              DO M=1,MAXPS
                DA(M)=DPNL(M,L)*DPNL(M,K)+DQNL(M,L)*DQNL(M,K)
              ENDDO
            ELSE
              DO M=1,MAXPS
                DA(M)=DPNL(M,L)*DPNL(M,K)
              ENDDO
            ENDIF
!
            CALL WEDDLE(DZERO,DA,DS,MNH,DHNS,MJH,MAXPS)
!
            IF(L.EQ.K)GO TO 420
            IF(BPRNT0)WRITE(MW6,10190)QN(K),MYL,QN(L),MYL,DS
!
            IF(MORT.LE.-4)THEN
              IF(IVAL(K).EQ.1)THEN
                NN=QN(L)
                IF(DAJNEW(L).LT.DZERO)NN=-NN
                WRITE(MW16,10200)MYL/2,QN(K),NN,DS
                IF(QN(K).LE.NN)THEN
                  WRITE(MW6,10060)K,QN(K),NN,L
!              GO TO 999                   !ERROR: VALENCE N .LE. CORE N
                  GO TO 420
                ENDIF
                IF(DAJNEW(L).LT.DZERO)GO TO 420
!         ELSE
!           IF(DAJNEW(K)*DAJNEW(L).LT.DZERO)THEN
!             NN=QN(K)
!             IF(DAJNEW(K).LT.DZERO)NN=-NN
!             WRITE(MW16,795)QL(L)/2,QN(L),NN,DS
!           ENDIF
              ENDIF
            ENDIF
!
            IF(IRLX.EQ.2)THEN
              KK=((K-1)*(K-2))/2+L
              OVLPGR(KK)=DS
              GO TO 420
            ENDIF
!
            DO M=1,MAXRS
              DPNL(M,K)=DPNL(M,K)-DS*DPNL(M,L)
              DQNL(M,K)=DQNL(M,K)-DS*DQNL(M,L)
            ENDDO
            DP0=DP0-DS*DORIG(L)
!
  420     ENDDO
!
! END ORTHOGONALIZATION
!
          IF(DS.LT.DEL)THEN
            WRITE(MW6,10180)K
            NF=-1
            DEY(K)=DZERO
            GO TO 580
          ENDIF
!
          DS=DONE/SQRT(DS)
          IF(DP0.LT.DZERO)THEN
!       DS=-DS
!       WRITE(MW6,781)K,(DPNL(M,K),M=1,50)
!        WRITE(MW6,781)
          ENDIF
!
          DO M=1,MAXRS
            DPNL(M,K)=DS*DPNL(M,K)
            IF(ABS(DPNL(M,K)).GT.TOLR)MAXPS=MAX(MAXPS,M)
            DQNL(M,K)=DS*DQNL(M,K)
          ENDDO
          DP0=DS*DP0
          DORIG(K)=DP0
!
! NEED TO RECALCULATE ORBITALS L .GT. K  WITH QL(L) .EQ. QL(K)
! DURING MINIMIZATION SO CAN RE-ORTHOGONALIZE TO NEW K.
!
  440     IF(.NOT.BDR)THEN
            DO L=K,MXORB
              IF(QL(L).EQ.QL(K).AND.DEY(L).NE.DZERO)THEN
                DO N=0,NP0
                  N0=N*NPARAM
                  DADJUS(N0+L)=DZERO
                ENDDO
              ENDIF
            ENDDO
          ENDIF
!
! END ORTHONORM
!
  460     IF(DDE.EQ.DZERO)GO TO 500                               !BREL2
!
! FORM NON-NUCLEAR ELECTROSTATIC ONE-BODY ENERGY INTEGRALS:
!                              NON-RELATIVISTIC ORBITALS, IF BREL ABOVE,
!                              RELATIVISTIC LARGE CPT ONLY IF BREL2,
!                              THEN ENERGY FACTOR MAYBE OMITTED
!                              FROM DQNL DURING ORTHOG - SEE DDE.
!
          DO L=1,K0
!
            DD2=DZERO
                     !INITIALIZE ALL FOR SAFETY AS NANs CAN BE ALLOCATED
!
            IF(DEY(L).EQ.DZERO)GO TO 470
            IF(QL(K).NE.QL(L))GO TO 470                             !639
            IF(SCREEN(L).GE.DKEY)GO TO 470                          !639
            IF(K.LE.ABS(MPSEUD))GO TO 470
            IF(L.GT.K.AND.IVAL(L).GT.0)GO TO 480
!
!test        call diff(DPNL(1,l),derv1,MNH,DHNS,MJH)
!test        call diff(derv1,derv2,MNH,DHNS,MJH)
!test        tlll=(ql(l)*(ql(l)+2))/4
!test        t=1
!
            DO M=1,MAXPS
!testc          if(dene.gt.dzero)t=exp(-dx(m)/debye)
!test          da(m)=-derv2(m)+(tlll/dx(m)**2-2*dz*t/dx(m))*dpnl(m,l)
!test          da(m)=da(m)*dpnl(m,k)
              DA(M)=DQNL(M,K)*DPNL(M,L)
!TEST          DA(M)=DQNL(M,L)*DPNL(M,K)
            ENDDO
            IF((MDEN.EQ.11.OR.MDEN.EQ.1.AND.NPITER.LT.0).AND.           &
     &         DENE.GT.DZERO)THEN                              !PERT DH1
              DO M=1,MAXPS
                T=EXP(-DX(M)/DEBYE)
                DA(M)=DA(M)+DTWO*DPNL(M,L)*DPNL(M,K)*(DONE-T)*DZ/DX(M)
              ENDDO
            ELSE
              DO M=1,MAXPS
                DA(M)=DA(M)-DTWO*DPNL(M,L)*DPNL(M,K)*VSC(M)
              ENDDO
            ENDIF
            IF(MPSEUD.NE.0)THEN
              DO M=1,MAXPS
                DA(M)=DA(M)+DTWO*DPNL(M,L)*DPNL(M,K)                    &
     &                *(DZ/DX(M)-POTHAM(M))
              ENDDO
            ENDIF
!
            CALL WEDDLE(DZERO,DA,DS,MNH,DHNS,MJH,MAXPS)
!
            DD2=DS/DTWO
            DD2=DD2*SCALER               !C.F. COWAN SLATER SCALE FACTOR
!
  470       KX=MIN(L,K)
            KY=MAX(L,K)
            IN=ICOL(KX,KY,IZERO)
!
!            if(kx.ne.ky)
!     &      write(mw6,*)'one-body:  ',k0,in,k,l,dd2
!
            DUY(IN)=DD2
!
  480     ENDDO
!
          DUY(INK)=DUY(INK)-DDE*SCALER
          DEY(K)=DUY(INK)+DE
          IF(QN(K).LT.0)DEY(K)=DEY(K)-TSHFT
!
          IF(.NOT.BREL)THEN
            DE=DE-DDE        !SO NOT DOUBLE COUNTED IN D2LL WHEN IN DQNL
            DEC=DZERO
          ENDIF
!
          GO TO 540
!
! FORM NON-NUCLEAR ELECTROSTATIC ONE-BODY ENERGY INTEGRALS:
!                                NON-REL DOES NOT USE DQNL.
!                                REALLY REQUIRES OVERLAPS BE SMALL AS
!                                USES UNMODIFIED POTENTIAL.
!                                IF ONLY SMALL CPT THEN CAN GO THRU
!                                NON-REL BRANCH ABOVE.
!
  500     BFIRST=.TRUE.
!
          DO L=1,K0
!
            DS=DZERO !INITIALIZE ALL FOR SAFETY AS NANs CAN BE ALLOCATED
!
            IF(DEY(L).EQ.DZERO)GO TO 510
            IF(QL(K).NE.QL(L))GO TO 510                             !604
            IF(SCREEN(L).GE.DKEY)GO TO 510                          !604
!       IF(BREL.AND.L.NE.K)GO TO 605
            IF(K.LE.ABS(MPSEUD))GO TO 510
            IF(L.GT.K.AND.IVAL(L).GT.0)GO TO 520
!
            IF(BFIRST)THEN
              IF((MDEN.EQ.11.OR.MDEN.EQ.1.AND.NPITER.LT.0).AND.         &
     &           DENE.GT.DZERO)THEN                                  !DH
                DO I=1,MAXPS
                  T=EXP(-DX(I)/DEBYE)
                  DP(I)=DPOT(I)-T*DZ/DX(I)+VSC(I)
!         write(78,*)i,dx(i),dpot(i)*dx(i),t*dz,vsc(i)*dx(i),dp(i)*dx(i)
                ENDDO
!          ELSEIF(MDEN10.EQ.2.AND.DENE.GT.DZERO)THEN       !IS NO 2-BODY
              ELSE
                DO I=1,MAXPS
                  DP(I)=DPOT(I)-DZ/DX(I)
                ENDDO
              ENDIF
              IF(MPSEUD.NE.0)THEN
                DO I=1,MAXPS
                  DP(I)=DP(I)+DZ/DX(I)-POTHAM(I)
                ENDDO
              ENDIF
              BFIRST=.FALSE.
            ENDIF
!
            IF(BREL2)THEN
              DO I=1,MAXPS
                DA(I)=DP(I)*(DPNL(I,L)*DPNL(I,K)+DQNL(I,L)*DQNL(I,K))
              ENDDO
            ELSE
              DO I=1,MAXPS
                DA(I)=DP(I)*DPNL(I,L)*DPNL(I,K)
              ENDDO
            ENDIF
!
            CALL WEDDLE(DZERO,DA,DS,MNH,DHNS,MJH,MAXPS)
!
            DS=DS*SCALER                 !C.F. COWAN SLATER SCALE FACTOR
!
  510       KX=MIN(L,K)
            KY=MAX(L,K)
            IN=ICOL(KX,KY,IZERO)
!
!            if(kx.ne.ky)
!     &      write(mw6,*)'rel one-body:  ',maxps,k0,in,k,l,ds
!
            DUY(IN)=DS
!
            IF(BMVDR)DCD(IN)=DZERO
!
  520     ENDDO
!
          DEY(K)=DE+DUY(INK)                         !AS DE OMIITED HERE
          IF(QN(K).LT.0)DEY(K)=DEY(K)-TSHFT
!
! END ONE-BODY ENERGY DETERMINATION
!
! ADD-IN EIGEN-ENERGY
!
          IF(.NOT.BREL2.AND.DDE.EQ.DZERO)THEN
            DDE=DE+DE
            DO I=1,MAXRS
              DQNL(I,K)=DQNL(I,K)+DDE*DPNL(I,K)
            ENDDO
            DDE=DE
          ENDIF
!
! DETERMINE CORRECTION TO KAPPA AVERAGE ENERGIES
!
! CAN ALSO TEST HERE EVALUATION OF SPIN-ORBIT: WITH FULL POTENTIAL IN
! SMALL R CORRECTION FOR WHEN SMALL CPT IN USE, SINCE WE ONLY RETAIN
! DIAGONAL IN NL CORRECTION DEPENDS ON E-V, AND/OR POTENTIAL DERIVATIVE.
! DO NOT USE CLOSED SHELLS THEN! STORED TEMPORARILY IN DARWIN ARRAY DCD.
! **NO GOOD FOR RADWIN!** SEE ALSO SOCC TO SWITCH-OFF CALCULATION THERE.
!
  540     IF(.NOT.BREL.OR.K.LE.ABS(MPSEUD).OR.QL(K).EQ.0)GO TO 560
!
          IF(BREL2)THEN
            DO I=1,MAXPS
              DP(I)=DPNL(I,K)*DPNL(I,K)
!     &                    +DQNL(I,K)*DQNL(I,K) !for test (B&W) s-o only
              DA(I)=DONE+DALF*(DE+DPOT(I))/DTWO
            ENDDO
          ELSE
            DO I=1,MAXPS
              DP(I)=DPNL(I,K)*DPNL(I,K)
              DA(I)=DONE+DALF*(DQNL(I,K)/DPNL(I,K)+DTWO*(DE-DDE+DZ/DX(I)&
     &              ))/DFOUR
            ENDDO
          ENDIF
!
          DO I=1,MAXPS
            DQ(I)=DP(I)*DERV1(I)/DX(I)            !POTENTIAL DERIV
            DP(I)=DP(I)/(DX(I)*DX(I)*DX(I))       !NUCLEAR
            DP(I)=DP(I)/DA(I)
            DQ(I)=DQ(I)/DA(I)
          ENDDO
          DD3=DZERO
!                                          !BREL2 TEST ONLY & .not.b1mbp
!T      CALL WEDDLE(DZERO,DP,DD3,MNH,DHNS,MJH,MAXPS)
!
          DD3=DALF*DD3/DFOUR
!
! TEST KAPPA-AVERAGED (NUCLEAR) SPIN-ORBIT CONTRIBUTION.
! NEED TO UNCOMMENT KAPPA=QL(K)/2 AT STATEMENT NUMBER 601 ABOVE
!
!      write(mw0,*)'kappa=',kappa
!      write(mw0,*)dd3,dd3*2*dz,dey(k),duy(ink),de
!
          IF(KAPPA.GT.0)THEN
            DSOOLD=DD3
          ELSEIF(KAPPA.LT.0)THEN
            I0=(QL(K)/2)
            I1=I0+1
            I2=I0+I1
            DD3=(DSOOLD*I0+DD3*I1)/I2
            write(mw0,*)'kappa-averaged spin-orbit=',dd3,dd3*2*dz
            DSOOLD=DD3
          ENDIF
!
          IN=ICOL(K,K,IZERO)
          IF(BMVDR)DCD(IN)=DD3                             !DSOOLD
!
          CALL WEDDLE(DZERO,DQ,DD3,MNH,DHNS,MJH,MAXPS)
!
          DD3=DALF*DD3/DFOUR
          IF(BMVDR.AND.IREL.LT.0)DCD(IN)=-DD3/DZ  !USE POTENTIAL DERIV
!
! TEST KAPPA-AVERAGED ONE-BODY ENERGY CONTRIBUTION.
! NEED TO UNCOMMENT KAPPA=QL(K)/2 AT STATEMENT NUMBER 601 ABOVE
!
          IF(KAPPA.NE.0)THEN
            DDD=-(KAPPA+1)*DD3          !KAPPA DEPENDENT ONE-BODY ENERGY
          ELSE
            DDD=-DZERO*DD3           !KAPPA=-1 .EQ. (2J+1) KAPPA-AVERAGE
          ENDIF
!
          DUY(INK)=DUY(INK)+ddd
          DEY(K)=DEY(K)+ddd
!
!      write(mw0,*)ddd,dey(k),duy(ink),de
!
! TEST KAPPA-AVERAGED BINDING ENERGY (EPSILON) CONTRIBUTION.
! NEED TO UNCOMMENT KAPPA=QL(K)/2 AT STATEMENT NUMBER 601 ABOVE.
!
          IF(KAPPA.GT.0)THEN
            DEHOLD=DE
          ELSEIF(KAPPA.LT.0)THEN
            I0=(QL(K)/2)
            I1=I0+1
            I2=I0+I1
            DE=(DEHOLD*I0+DE*I1)/I2
!        write(mw0,*)'kappa-averaged epsilon=',de
!        dehold=de
          ENDIF
!
          IF(KAPPA.GT.0)THEN
            KAPPA=-KAPPA-1
            GO TO 380
          ELSEIF(KAPPA.LT.0)THEN
            KAPPA=0
            GO TO 380
          ENDIF
!
! DETERMINE CORRECTION TO KAPPA-AVERAGED BINDING ENERGY
!
          CALL DIFF(DPNL(1,K),DA,MNH,DHNS,MJH)
!
          DO I=1,MAXPS
            DA(I)=DQ(I)*DX(I)*DA(I)/DPNL(I,K)
          ENDDO
!
          CALL WEDDLE(DZERO,DA,DD4,MNH,DHNS,MJH,MAXPS)
!
          DD4=DALF*DD4/DFOUR
          DEC=(QL(K)+1)*(DD3-DD4)
!      if(brel2)dec=dec/rnorm(k)**2
!
!      if(ql(k).eq.0)go to 642       !test
!      write(mw0,*)'correction to kappa-averaged binding energy='
!     &          ,dd3,dd4,dec,de,de+dec
!      dec=0.0
          DE=DE+DEC
!      de=dehold        !test use explicitly calculated deviation, above
!
          DEY(K)=DE+DUY(INK)
!
          IF(.NOT.BREL2.and.dde.ne.dzero)THEN
            DDE=DE-DDE
            DDE=DDE+DDE
            DO I=1,MAXRS
              DQNL(I,K)=DQNL(I,K)+DDE*DPNL(I,K)
            ENDDO
            dde=de
          ENDIF
!
! UNCOMMENT TWO LINES 'IF..' BELOW TO LOOP AROUND RADIAL EQUATION TWICE
! (BOUND AND CONTINUUM AUTOMATICALLY TAKEN CARE OF) FIRST TO EVALUATE
! RELATIVISTIC RADIAL FUNCTION FOR ONE-BODY AND ELECTROSTATIC MATRIX
! ELEMENTS THEN TO EVALUATE NON-RELATIVISTIC RADIAL FUNCTION FOR
! TWO-BODY FINE-STRUCTURE AND (IF INSERTED IN RADCON AND DIAGON)
! TWO-BODY NON-FINE-STRUCTURE. SHOULD NOT BE NEEDED AS USE OF
! RELATIVISTIC RADIAL FUNCTIONS FINE FOR ALL OPERATORS - HISTORIC.
! N.B. REMOVE SECOND APPEARENCE OF STATEMENT NO 642, UNCOMMENT 55, NEXT
!
!T642 IF(BREL.AND..NOT.BJUMPR)GO TO 55
!T    IF(BJUMPR)BREL=.TRUE.
!
!  ******************DATA TO RELATIVISTIC CONTRIBUTIONS*****************
!
!     IF BHFF .TRUE. THEN THERE EXIST ORBITALS TO BE CALCULATED IN
!     SR.RADWIN, LEAVE CALC OF REL CONTRIB TIL THEN.
!
  560     IF(.NOT.BMVD.AND.NJO.LE.0.OR.BHFF)GO TO 580
!
! MASS-VELOCITY AND DARWIN (+M1+BP RAD)
!
          CALL MVDINT(K,DE,MRED,MAXPS)
!
!
  580     IF(K.LE.ABS(MPSEUD))THEN
            DUY(INK)=DZERO
            DEY(K)=DZERO
          ENDIF
          IF(K.EQ.ABS(MPSEUD).AND..NOT.BHFF)THEN
            CALL VPNL(DZ,-IONE,IZERO,WK,DJ0,MAXRS,MJH,MNH,DHNS,POTHAM,  &
     &                DTOL,MEND)
            IF(NF.LE.0)GO TO 2000                                !RETURN
          ENDIF
!
          IF(.NOT.BORT)GO TO 600
          IF(JPOT.NE.0)GO TO 700
          JPOT1=K                       !CASE RYD LAMBDA NL.NE.CONTINUUM
          JPOT=1
          IPOTJ=1
          GO TO 650
!
! END INNER LOOP OVER ORBITALS
!
  600   ENDDO                    !<-------------------------------------
!
!
! ADJUST POTENTIAL STORAGE
!
        IF(IPOTJ.GT.IXPOT)THEN           !J.GT.
          WRITE(MW6,*)' SR.RADIAL: L=',MYL,' USES L=',IXPOT-1,          &
     &                ' POTENTIAL'
          WRITE(MW0,*)' SR.RADIAL: L=',MYL,' USES L=',IXPOT-1,          &
     &                ' POTENTIAL'
          GO TO 700
        ENDIF
        IF(BJUMP)GO TO 700
!
  650   IF(IPOTJ.GT.0)THEN
          DO I=1,MAXRS
            POT(I,IPOTJ)=DPOT(I)
          ENDDO
          CALL DIMUSE('MXPOT',IPOTJ)
        ENDIF
!
  700   CONTINUE
!
! BACK-UP NEW SCALING PARAMETERS TO DADJUS
!
        DO N=0,NP0
          N0=N*NPARAM
          DADJUS(N0+J)=DAJNEW(N0+J)
        ENDDO
!
! END OUTER LOOP OVER SCALING PARAMETERS
!
  800 ENDDO                       !<------------------------------------
!
!-----------------------------------------------------------------------
!
! UPDATE DQNL (IF NOT ALREADY DONE SO)
!
      IF(.NOT.BREL2.AND.DDE.EQ.DZERO)THEN
        DO K=1,MXORB
          IF(DEY(K).EQ.DZERO)GO TO 850
          IF(SCREEN(K).GT.DKEY)GO TO 850
          DE=DEY(K)-DUY(INK)
          DE=DE+DE
          DO M=1,MAXRS
            DQNL(M,K)=DQNL(M,K)+DE*DPNL(M,K)
          ENDDO
  850   ENDDO
      ENDIF
!
! UPDATE PLASMA POTENTIAL ITERATION
!
      IF(MDEN10.GT.2.OR.MDEN.LT.0.AND..NOT.BJUMP)THEN
        IF(MPP.LT.MPP5.AND.BMPP)THEN              !RE-SET AND TRY AGAIN
!          call flush(mw6)
          MPP=MPP+1
          I0=0
          DO I=1,NPARAM
!            i0=0                                 !limit core iterations
!            if(mpp.gt.qn(i)+1)i0=mb              !if troublesome
!            if(ieq(i).ge.i0)then
            if(screen(i).gt.-d999.AND..NOT.BFIX(I))then
              do n=0,np0
                n0=n*nparam+i
                DADJUS(n0)=DZERO
              enddo
            endif
!            endif
          ENDDO
          ZNP0=-D99
          BMPP=.FALSE.
          KDEX=0
          TPEX=DZERO
          TDEX=DZERO
          JPOT=JPOT0
          MHF=0
          GO TO 200
        ELSEIF(BMPP)THEN
          WRITE(MW6,10310)KDEX,TDEX,DEOLD(KDEX),TPEX   !AS OLD HOLDS NEW
          IF(TPEX.GT.100*TOLPP/NZA)WRITE(MW0,*)' *** SR.RADIAL:',       &
     &    ' SELF-CONSISTENT ITERATION OF RADIAL FUNCTIONS NOT CONVERGED'
!          do i=1,maxrs
!            write(66,566)i,dx(i),dx(i)*dpot(i),-dpot(i)
!  566 format(i5,3(1pe16.7))
!          enddo
        ENDIF
        IF(noccm.GT.0.AND.mexpot.EQ.4)THEN
!                                             !might suppress if facsp<0
          WRITE(MW6,10010)abs(facsp),faclam           !fac matching info
          WRITE(MW6,10020)faca
        ENDIF
      ENDIF
!
      if(abs(includ).ge.1000000)then
        do k=1,mxorb
          if(screen(k).lt.-d999)then
            de=dey(k)-duy(ink)                           !epsilon a.u.
            de=-2*de
            screen(k)=dz-sqrt(qn(k)*de)
          endif
        enddo
      endif
!
! DETERMINE QED CONTRIBUTIONS (ALL ORBITALS)
!
      IF(QED.NE.QZERO)CALL QEDINT(MAXPS)
!
      if(btimet)then
        call nrb_time(timef)
        times=timef-timei
!par        if(iam.ge.0)then                                        !par
!par          write(iwp,*)'proc',iam,' for radial:'                 !par
!par          write(iwp,*)'    radial time=',nint(times)            !par&
!par     &               ,'sec'                                     !par
!par          call flush(iwp)                                       !par
!par        else                                                    !par
        write(iw,*)'radial time=',nint(times),'sec'
!par        endif                                                   !par
      endif
!
! LOOK FOR ANY EXTERNAL ORBITALS
!
      IF(.not.BHFF.and..not.bdr)GO TO 1300
!
      IF(.NOT.BJUMP)GO TO 1200
!
      DO K=1,MXORB
        IF(DEY(K).EQ.DZERO)GO TO 900
        IF(SCREEN(K).LT.DKEY)GO TO 900
        GO TO 1000
  900 ENDDO
      IF(.NOT.BLAG)BHFF=.FALSE.
      GO TO 1300
!
 1000 MAXPS=0
!
      DO K=1,MXORB
        IF(DEY(K).EQ.DZERO)GO TO 1100
        IF(QN(K).LT.0)GO TO 1100
        IF(SCREEN(K).GT.DKEY)GO TO 1100
        DO M=1,MAXRS
          IF(ABS(DPNL(M,K)).GT.TOLR.or.dx(m).lt.rzero)MAXPS=MAX(MAXPS,M)
        ENDDO
 1100 ENDDO
!
 1200 IF(MAUTO.GT.0)GO TO 1500
!
!
! TO READ RADIAL BOUND FUNCTIONS AS INPUT AND PROCESS THEM.
!
      IF(BHFF)THEN
!
        CALL RADWIN(MAXPS)
!
        IF(NF.LE.0)GO TO 2000                                    !RETURN
!
        BHFF=.FALSE.
!
        IF(MAUTO.EQ.0)GO TO 1500
!
      ENDIF
!
! PREPARE FOR DROPPING ALL POINTS I BEYOND WHICH ALL /<NL!X>/.LT.TOLR
!                                               - AS DEFINED BY MAXPS
!
 1300 CONTINUE
!
      IF(RZERO.GT.DZERO)THEN
        DO M=1,MAXRS
          IF(DX(M).GT.RZERO)GO TO 1350
        ENDDO
        M=MAXRS
 1350   MAXPS=M
      ENDIF
!                                                             !for cont.
      if(mauto.gt.0.and.mden.ne.0.and.xmax.gt.dzero)go to 1500 !for cont
!
      MAXRS=0
      MJH0=MJH
      DO I=1,MJH0
        MAXRS=MNH(I)+MAXRS
        MJH=I
        IF(MAXRS.EQ.MAXPS)GO TO 1400
        IF(MAXRS.GT.MAXPS)THEN
          MAXRS=MAXRS-MNH(I)
          nxtra=9
!          if(.not.bsto.and.mauto.gt.0)nxtra=max(nxtra,2*mnh(i-1))!test
          MNH(I)=MAX(MAXPS-MAXRS,nxtra)
          MAXRS=MAXRS+MNH(I)
          GO TO 1400
        ENDIF
      ENDDO
!
 1400 IF(MAUTO.LE.0)THEN
        MAXPS=MAXRS                         !TWEAk C.F. OLD MAXQS
        GO TO 1600                          !.NOT.BHFF.OR.
      ENDIF
!
!*****************************************************************
! EVALUATE CONTINUUM FUNCTIONS FOR AUTO/PHOTOIONIZATION RATE
! DETERMINATION IN SR.DIAGON AND SR.DIAGFS
!*****************************************************************
!
 1500 CONTINUE
!
      if(btimet)call nrb_time(timei)
!
      CALL RADCON(MAXPS)
!
      if(btimet)then
        call nrb_time(timef)
        times=timef-timei
!par        if(iam.ge.0)then                                        !par
!par          write(iwp,*)'proc',iam,' for radcon:'                 !par
!par          write(iwp,*)'    radcon time=',nint(times)            !par&
!par     &               ,'sec'                                     !par
!par          call flush(iwp)                                       !par
!par        else                                                    !par
        write(iw,*)'radcon time=',nint(times),'sec'
!par        endif                                                   !par
      endif
!
      IF(NF.LE.0)GO TO 2000                                      !RETURN
!
!-----------------------------------------------------------------------
!
!
! WRITE RADIAL MESH AND EFFECTIVE CHARGE DUE TO NUCLEUS PLUS CLOSED
! SHELL CORE AND/OR THEN ORBITALS TO FILE 'potout' *OR* 'radout' IN
! SS/IMPACT FORMAT. *** CURRENTLY USES SAME UNIT SO EITHER, NOT BOTH.***
!
 1600 IF(MRAD.GE.0)GO TO 2000
!
! FIRST DETERMINE EFFECTIVE CHARGE
!
      IF(MPSEUD.EQ.0.AND..NOT.BHFF.AND.MHF.EQ.0.AND.NOCCM.EQ.0)THEN
        CALL VPNL(DZ,-IONE,IZERO,WK,DONE,MAXRS,MJH,MNH,DHNS,DPOT,DTOL,  &
     &            MEND)
        IF(NF.LE.0)GO TO 2000                                    !RETURN
      ENDIF
!
      MMRAD=MOD(MRAD,I100)
!
      IF(IUNIT(MW13).LT.0)THEN
        WRITE(MW6,*)"TRYING TO RE-OPEN FILE='radout/potout'..."
        WRITE(MW0,*)'TRYING TO RE-OPEN UNIT=13'
        GO TO 2200                                               !RETURN
      ENDIF
      IUNIT(MW13)=1  !TBD: USE DIFFERENT UNITS THEN MRAD=-113 GIVES BOTH
!
      IF(MMRAD.NE.0)OPEN(MW13,FILE='radout',STATUS='REPLACE')  !MRAD=-13
      IF(MRAD.LE.-I100)OPEN(MW13,FILE='potout',STATUS='REPLACE')  !=-100
!
      MAXW2=(MAXRS-1)/2
      MAXW=MAXW2*2-1
      MAXW2=MAXW2+1
      MAXX=2*MAXW2
!
      IF(MAXX.GT.99999)THEN
        FOUT='(I5,2(I6,2(1PE14.7)))'
      ELSEIF(MAXX.GT.9999)THEN
        FOUT='(I5,2(I5,2(1PE14.7)))'
      ELSE
        FOUT='(I5,2(I4,2(1PE14.7)))'
      ENDIF
!
      TLBL='TFDA'
      IF(BSTO)TLBL='STO '
      IF(BREL)TLBL='REL '
      IF(IORT.EQ.4)TLBL='LPS '
      IF(IORT.EQ.5)TLBL='BOX '
!
      NORB=0
      IF(MMRAD.NE.0)THEN
        DO J=1,MXORB
          IF(DEY(J).EQ.DZERO.AND.J.GT.ABS(MPSEUD))GO TO 1650
          NORB=NORB+1
 1650   ENDDO
      ENDIF
!
      DO I=1,5
        IF(I.LE.IXVAR)THEN
          DA(I)=DADJUS(I)
        ELSE
          DA(I)=DZERO
        ENDIF
      ENDDO
!
      KEY=-9
      WRITE(MW13,10030)KEY,NORB,MB,MAXX,MION,DZ,(DA(I),I=1,5),TLBL
!
      KEY=-8
      I1=1
      I2=2
      WRITE(MW13,FOUT)KEY,I1,ZERO,DZ,I2,DX(1),DX(1)*DPOT(1)
!
      DO I=1,MAXW,2
        I1=I+1
        I2=I+2
        I3=I+3
        WRITE(MW13,FOUT)KEY,I2,DX(I1),DX(I1)*DPOT(I1),I3,DX(I2),DX(I2)  &
     &                  *DPOT(I2)
      ENDDO
!
      IF(MMRAD.EQ.0)GO TO 1800
!
! WRITE ORBITAL FUNCTIONS P AND Q IN "IMPACT" FORMAT
!
      ZERO=DZERO
      DO J=1,MXORB
        IF(DEY(J).EQ.DZERO.AND.J.GT.ABS(MPSEUD))GO TO 1700
        KEY=-7
        MYN=QN(J)
        MYL=QL(J)/2
        INJ=ICOL(J,J,IZERO)
        DE=DEY(J)-DUY(INJ)
        DE=DE+DE
        T=ZERO
        IF(IEQ(J).GE.MA.AND.IEQ(J).LE.MB)T=2*(QL(J)+1)
        WRITE(MW13,10050)KEY,J,MYN,MYL,T,DE,MAXW2,TLBL
!
        KEY=-6
        I1=1
        I2=2
        WRITE(MW13,FOUT)KEY,I1,DORIG(J),ZERO,I2,DPNL(1,J),DQNL(1,J)
!
        DO I=1,MAXW,2
          I1=I+1
          I2=I+2
          I3=I+3
          WRITE(MW13,FOUT)KEY,I2,DPNL(I1,J),DQNL(I1,J),I3,DPNL(I2,J),   &
     &                    DQNL(I2,J)
        ENDDO
 1700 ENDDO
!
! FULL ATOMIC STO POTENTIAL FOR E.G. EXTERNAL D.W.
!
!***CURRENTLY, SAME FILE AS ORBITALS,
!   BUT -100 NO WRITE OF ORBITALS, ONLY POTENTIAL
!
 1800 IF(MRAD.GT.-100.OR.MCFMX.LE.0.OR.IEQ(0).NE.0)GO TO 1900
!
      IF(NOCCM.EQ.0)THEN              !ELSE WE ALREADY HAVE A UNIQUE POT
        MNP=MION+1
        DJ0=DAJNEW(MCFMX)
!
        CALL STOPOT(DZ,MNP,MCFMX,DJ0,DHNS0,MAXRS,MJH,MNH,DHNS,DX,DPOT,  &
     &              DTOL,MEND,MPP)
!
        IF(NF.LE.0)GO TO 2000                                    !RETURN
      ENDIF
!
      KEY=-14
      J=-1
      DJ0=DZERO
      T=ZERO
      WRITE(MW13,10050)KEY,J,MEND,J,T,DJ0,MAXW2,TLBL
!
      KEY=-4
      I1=1
      I2=2
      POT0=DTHREE*DPOT(1)
      WRITE(MW13,10040)KEY,I1,POT0,POT0,I2,DPOT(1),DPOT(1)
!
      DO I=1,MAXW,2
        I1=I+1
        I2=I+2
        I3=I+3
        WRITE(MW13,10040)KEY,I2,DPOT(I1),DPOT(I1),I3,DPOT(I2),DPOT(I2)
      ENDDO
!
 1900 WRITE(MW13,10030)
!
      CLOSE(MW13,STATUS='KEEP')
      IUNIT(MW13)=-1
!
 2000 CONTINUE
!
!-----------------------------------------------------------------------
!
! check radial overlaps
!
!      do 450 k=1,mxorb
!        if(dey(k).eq.dzero)go to 450
!        do 451 j=k,mxorb
!          if(dey(j).eq.dzero)go to 451
!          if(ql(j).ne.ql(k))go to 451
!          do i=1,maxps
!            da(i)=dpnl(i,k)*dpnl(i,j)
!            if(brel)da(i)=da(i)+dqnl(i,k)*dqnl(i,j)
!          enddo
!          call weddle(dzero,da,dd1,mnh,dhns,mjh,maxps)
!          write(mw6,453) k,j,dd1
! 453      format(2i5,1pe15.5)
! 451    enddo
! 450  enddo
!
! CHECK RADIAL MESH SUFFICIENT (N.B. MAXRS HAS BEEN TRUNACTED BY NOW)
!
      IF(MAXPS.EQ.MAXRS0.and.IORT.LT.4.and.mden.le.0)THEN
        IF(MAXRS0.EQ.MAXB1)THEN                   !END OF PHYSICAL ARRAY
          WRITE(MW6,10080)MSTEP
          WRITE(MW0,*)'SR.RADIAL: RADIAL ARRAY FULL'
          GO TO 2200                                             !RETURN
        ELSE
          WRITE(MW6,*)' WARNING: INTERNAL RADIAL ARRAY MAYBE TOO SHORT!'
          WRITE(MW0,*)' WARNING: INTERNAL RADIAL ARRAY MAYBE TOO SHORT!'
!          write(mw0,*)'xmax=',xmax
        ENDIF
      ENDIF
!
      MAUTO=MAUTOH                                           !RE-INSTATE
!
!-----------------------------------------------------------------------
!
! DUMP FOR DWX
!
      IF(IDW.NE.0)THEN
        IF(IUNIT(MRW11).GT.0)CLOSE(MRW11)         !OPENED FOR IDW=0 CONT
        IUNIT(MRW11)=1
        OPEN(MRW11,STATUS='SCRATCH',FORM='UNFORMATTED')
        REWIND(MRW11)
        WRITE(MRW11)MXORB,MJH,MAXRS
        WRITE(MRW11)(DUY(I),I=1,IXD28),(DEY(K),K=1,MXORB)
        WRITE(MRW11)(DHNS(J),J=1,MJH),(MNH(J),J=1,MJH)
        WRITE(MRW11)(DX(M),M=1,MAXRS),(DORIG(K),K=1,MXORB)
        WRITE(MRW11)((DPNL(M,K),M=1,MAXRS),K=1,MXORB)
        WRITE(MRW11)((DQNL(M,K),M=1,MAXRS),K=1,MXORB)
        WRITE(MRW11)DLAMX,DLAMDX,DLAMQX
        IF(BSTO)THEN
          WRITE(MRW11)MCFMX,MEXPOT,NOCC,NLSTOE,MCFSTOX,NOCCX
          IF(NOCC.NE.0)THEN
            IF(NOCCX.EQ.0)THEN               !PASS UNIQUE POTENTIAL
              WRITE(MRW11)MEND
              WRITE(MRW11)(DPOT(M),M=1,MAXRS)
            ELSE                             !PASS TARGET OCCUPATION NOS
              IXSHLL=ABS(NOCC)
              WRITE(MRW11)(TEL(I),I=1,IXSHLL)
            ENDIF
          ENDIF
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
! LOCAL
!
 2100 IF(ALLOCATED(IRAD))DEALLOCATE(IRAD)
      IF(ALLOCATED(DEOLD))DEALLOCATE(DEOLD)
!
      IF(ALLOCATED(DA))THEN
        DEALLOCATE(DA,DP,DQ,STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'RADIAL: DE-ALLOCATION FAILS FOR DA,DP,DQ'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
 2200 NF=-1
      GO TO 2100
!
!-----------------------------------------------------------------------
!
10010 FORMAT(//1X,1P,'FAC MATCHING CHARGE=',E13.5/1X,                   &
     &       'FAC FITTING LAMBDA =',E13.5/)
10020 FORMAT(/1X,'FAC HARTREE-SLATER EXCHANGE COEFFICIENT=',1P,E13.5/)
10030 FORMAT(3I5,4X,I9,I4,F5.1,5F7.3,A4)
10040 FORMAT(I5,2(I4,2(1PE14.7)))
10050 FORMAT(3I5,I3,F5.1,2X,F12.6,I6,29X,A4)
10060 FORMAT(' WARNING: ORBITAL',I3,' HAS VALENCE N=',I3,               &
     &       ' .LE. CORE N=',I3,' OF ORBITAL',I3)
10070 FORMAT(' N=',I3,5X,'L=',I3,5X,'EPSILON=',F12.5,10X,'MPP=',I3)
10080 FORMAT(' SR.RADIAL: RADIAL ARRAY FULL -- TRY BIGGER INTEGRATION ',&
     &'RANGE - MORE POINTS (INCREASE MAXB1 2) OR LONGER STEPS (DECREASE'&
     &,' MSTEP IN NAMELIST SMINIM)'/' CURRENTLY, MSTEP=',I3)
10090 FORMAT(16X,'LL =',I2,'    EXTERNAL POTENTIAL V(LL) TYPE MHF=',I2, &
     &       ';  NON-COULOMB POT .LT. 1% OF COULOMBIC BEYOND R(IEND=',  &
     &       I5,') =',F10.6)
10100 FORMAT(13X,'NL =',I3,I3,'   EXTERNAL POTENTIAL V(NL) TYPE MHF=',  &
     &       I2,';  NON-COULOMB POT .LT. 1% OF COULOMBIC BEYOND R(IEND='&
     &       ,I5,') =',F10.6)
10110 FORMAT(23X,'NL =',I3,I3,'   S.M.-POTENTIAL V(NL) WITH SCALE',     &
     &       ' FACTOR',F10.5,';  COULOMBIC BEYOND R(IEND=',I5,') =',    &
     &       F10.6)
10120 FORMAT(45X,I1,'-POLE PERTURBED SCALE FACTOR',F10.5,               &
     &       ';  COULOMBIC DEVIATION AT R(IEND) =',F10.6)
10130 FORMAT('GAM=',I3,' GRP=',I3,8X,'NL =',I3,I2,                      &
     &       '    S.M.-POTENTIAL V(NL) WITH SCALE',' FACTOR',F10.5,     &
     &       ';  COULOMBIC BEYOND R(IEND=',I5,') =',F10.6)
10140 FORMAT(2X,'NL =',I3,I3,'   STO.-POTENTIAL CF=',I3,' WITH SCALE',  &
     &       ' FACTOR',F10.5,';  NON-COULOMB POT .LT. 1% OF COULOMBIC', &
     &       ' BEYOND R(IEND=',I5,') =',F10.6)
10150 FORMAT(24X,'LL =',I2,',..   S.M.-POTENTIAL V(LL) WITH SCALE',     &
     &       ' FACTOR',F10.5,';  COULOMBIC BEYOND R(IEND=',I5,') =',    &
     &       F10.6)
10160 FORMAT(3X,'LL =',I2,',..   STO.-POTENTIAL V(LL) WITH SCALE',      &
     &       ' FACTOR',F10.5,';  NON-COULOMB POT .LT. 1% OF COULOMBIC', &
     &       ' BEYOND R(IEND=',I5,') =',F10.6)
10170 FORMAT(' NON-ORTHOGONAL ORBITALS IN USE; BUT MAXB2=',I5,          &
     &  ' INSUFFICIENT FOR DQNL, ERRORS MAY ARISE IN ONE-BODY INTEGRALS'&
     &  )
10180 FORMAT('  NEAR IDENTICAL FUNCTION FOR ORBITAL K=',I2,             &
     &       ' CASE SKIPPED  ')
10190 FORMAT('       OVERLAP INTEGRAL',4X,I3,I2,' WITH',2I2,' =',       &
     &       1PE12.4)
! 781  FORMAT( ' ORTHOGONALIZATION CHANGES SIGN OF ORBITAL K=' ,I2,
!     &' VALUES NEAR ORIGIN ARE: '/10(1PE13.4))
! 781 FORMAT('+',57X,'*')
10200 FORMAT(3I5,1PE13.4)
10210 FORMAT(/5X,'BREIT INTERACTIONS: ',1X,'KUTSO=',I2,3X,'KUTSS=',I4,  &
     &       3X,'KUTOO=',I2,2X,A12,1X,'(IBREIT=',I2,')',12X,'QED=',I2)
10220 FORMAT(//5X,'KAPPA-AVERAGED RELATIVISTIC WAVEFUNCTIONS ',         &
     &       'IN USE: ',' SMALL COMPONENT IS ',A3,' (IREL=',I2,')',3X,  &
     &       'RETARDATION IS ',A3,' (IRTARD=',I2,')'/75X,'***',28X,     &
     &       '***')
10230 FORMAT(///' RADIAL FUNCTIONS:   PRECISION OF EIGENVALUE IS',      &
     &       1PE9.2,2X,I8,' POINTS (MSTEP=',I2,');  ATOMIC NUMBER',I3,  &
     &       ',   NUMBER OF ELECTRONS',I3)
10240 FORMAT('+',122X,'MXPOT=',I2)
10250 FORMAT(//' STO POTENTIALS WITH MEXPOT=',I4/)
10260 FORMAT(/' ATTENTION: STO POTENTIAL SCALING PARAMETERS ARE ',      &
     &  'APPLIED LOCALLY TO EACH SUB-SHELL AND NOT GLOBALLY PER ORBITAL'&
     &  )
10270 FORMAT(/' STO POTENTIAL OCCUPATION NUMBERS:'//' GAM',6X,'WOCC')
10280 FORMAT(/' SUM',F10.4/)
10290 FORMAT(' STO POTENTIAL OCCUPATION NUMBERS AVERAGED OVER THE',     &
     &       ' FIRST',I5,                                               &
     &       ' SPECTROSCOPIC CONFIGS THAT CONTAIN AN ORBITAL')
10300 FORMAT(' STO POTENTIAL OCCUPATION NUMBERS AVERAGED OVER THE',     &
     &       ' FIRST',I5,                                               &
     &       ' SPECTROSCOPIC CONFIGS *** LIKELY UNPHYSICAL ***')
10310 FORMAT(//' *** SR.RADIAL: SELF-CONSISTENT ITERATION OF RADIAL ',  &
     &       'FUNCTIONS MAY NOT BE CONVERGED'/16X,                      &
     &       'CHECK EPSILONS TO SEE IF THEY',' ARE ACCURATE ENOUGH:',I5,&
     &       2F12.5,1PD10.1)
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE RADIAL
!
!                             *******************
!
      SUBROUTINE RADWAV(K0,N,L,Z,NPOINT,NI,NTI,DXI,X,SCREEN,DP,DQ,EA    &
     &                 ,DP0,DQ0,pnorm,rinf2)
!
!-----------------------------------------------------------------------
!
!  SR.RADWAV CALCULATES ELECTRON BOUND WAVE FUNCTIONS IN A POTENTIAL POT
!  IF SR.TFDAPO/STOPOT IS RUN BEFOREHAND THEN MODULE COMMON_NRBPOT WILL
!  CONTAIN THE POTENTIAL DPOT(I) AT RADIAL MESH POINTS X(I),I=1,NPOINT
!  QUANTITIES REQUIRED     - APART FROM DPOT(I) AND X(I) -
!  K=ORBITAL NUMBER
!  N=PRINCIPAL QUANTUM NUMBER, L=ANGULAR MOMENTUM,
!  Z=NUCLEAR CHARGE, ASYMPTOTIC CHARGE =DPOT(NPOINT)*X(NPOINT) ASSUMED
!  NI=NUMBER OF INTERVALS INTO WHICH THE WHOLE RANGE IS DIVIDED,
!  NTI(J)=NUMBER OF STEPS (.GE.8) IN EACH INTERVAL J=1,NI,
!  DXI(J)=STEP LENGTH IN INTERVAL J, NPOINT=TOTAL NUMBER OF STEPS
!  SCREEN IS AN ESTIMATE OF THE SCREENING VALUE IN A RYDBERG FORMULA;
!  AFTER EXCECUTING RADWAV THE INITIAL VALUE OF SCREEN IS REPLACED BY
!  THE CALCULATED SIGMA.
!  OTHER INPUT ARE MEND, TOL(=10**(-ITOL))
!
!  RESULTS
!  DP(I) I=1,NPOINT VALUES OF THE NORMALIZED WAVE FUNCTION
!  E=ENERGY EIGENVALUE IN RYDBERGS (INACCURACY ABS(DE/E).LT.TOL);
!  SCREEN=SCREENING PARAMETER IN A RYDBERG FORMULA (FOR  E=EA).
!  IF BREL THEN DQ(I) CONTAINS THE SMALL COMPONENT, AND DP(I) THE LARGE.
!
!  IT IS CALLED BY:
!    SR.RADIAL
!
!  IT CALLS:
!    SR.DIFF
!    SR.NUMERO
!    FN.PMVDAR
!    SR.WEDDLE
!    FN.WHITEX
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: MHF,MRAD,MSTEP,IXTRA,xmax
!
      USE COMMON_NRBAL1, ONLY: MA,MB
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,VSC,XC1,XC2,NPITER
      USE COMMON_NRBPOT, ONLY: DPOT,TOL,MEND
      USE COMMON_NRBPOT, ONLY: ZS0,ZS,JZNM
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBREL, ONLY: RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0
      USE COMMON_NRBREL, ONLY: DNUK0,DNUK1,DNUK2,DNUK
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION DP(*),X(*),DXI(*),NTI(*),DQ(*)
      DIMENSION A(12),U(3),IND(3),PKOEF(4),Y(:)              !Y(6)
!
      PARAMETER (C3=2.094_WP)
!
      PARAMETER (DEPS0=D1M70)
!
! LARGEST EXP ARGUMENT FOR WP=4,8,16
      PARAMETER (DEXP0=D88*(WP/4)**3*(1+nint(real(WP)/16)))
!
      ALLOCATABLE :: PQ(:)
!
      POINTER :: Y
      TARGET :: A
!
      Y=>A(7:12)                                 !FOR PASS TO SR.NUMERO
!
!      EQUIVALENCE (Y(1),A(7))                   !FOR PASS TO NUMERO
!
!-----------------------------------------------------------------------
!
! THE NAMES HERE ARE NOT NECESSARILY SIGNIFICANT THEY ARE COMMON LEGACY.
!
! LOCAL
      ALLOCATE(PQ(NPOINT),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RADCON: ALLOCATION FAILS FOR PQ'
        NF=0
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
! HISTORICALLY, THE E-VALUE SEARCH STARTED WITH THE WHITTAKER FUNCTION
! BEING EVALUATED AT THE OUTER TURNING POINT, FOR SPEED. AS THE E-VALUE
! IS REFINED, THE SWITCH IS MADE TO EVALUATING IT AT THE STARTING POINT
! FOR INWARD NUMEROV, WHICH OBTAINS THE WHOLE FUNCTION. SPEED IS
! NOT AN ISSUE HERE NOWADAYS AND FOR INCREASINGLY HIGH RYDBERG STATES
! (WHERE WE HAVE A GOOD INITIAL ESTIMATE OF THE E-VALUE) CANCELLATION
! ERROR IS INCREASINGLY LARGE LEADING TO AN INACCURATE DERIVATIVE
! WHICH CAUSES FAILURE TO CONVERGE - THE SWITCH OVER IS NOT ENOUGH
! TO SAVE YOU. FOR BACKWARDS REPRODUCIBILITY, WE KEEP THE HISTORIC
! APPROACH FOR LOW-N (FOR NOW) BUT SWITCH IT OFF FOR RYDBERG STATES.
!
      BSHORT=N.LT.10               !.TRUE. FOR ALL-N IS HISTORIC
!
! INITIALIZE
!
      MAXIT=25
      IF(N.EQ.1)MAXIT=30
!w      IF(BREL.AND.N.EQ.1)MAXIT=40
      IF(DENE.GT.DZERO)MAXIT=45
      ITERA=MAXIT
!
!T      DE0=D1P20                               !SEE BELOW FOR UNCOMMENT
      BREL2=ABS(IREL).EQ.2
      EMINIM=D1M70
      NPRES=NPOINT
      BNORM=.FALSE.
      IJPGT=0
      NCORR=0
!
      NODES=N-L
      TL=L
      TLP=L+1
      TLL=L*(L+1)
!
! ZN=ASYMPTOTIC SCREENING CHARGE=DPOT(.GT.MEND)*X(.GT.MEND)
!
      ZN=DPOT(NPOINT)*X(NPOINT)
      ZNS=VSC(NPOINT)*X(NPOINT)
      ZNA=ZN+ZNS      !FOR SR.NUMERO (& FN.PMVDAR) BUT NOT USED BY A.S.
!                     !                        AS IND(1).NE.0 & EE.LT.0
! CORRECT THE SCREENING CHARGE IF TOO LARGE
!
      IF(Z-ZN.LT.SCREEN)then
!        write(*,*)'re-setting screen:',screen,z-zn
        SCREEN=Z-ZN
      endif
      ZSC=Z-SCREEN
!
! NORMALLY CAUGHT, BUT SOME THINGS ARE HARD TO CATCH IN ALGEB
!
      IF(ZN.LT.DHALF)THEN
        WRITE(MW6,*)                                                    &
     &   '*** SR.RADWAV: CANNOT TREAT NEGATIVE IONS, INCREASE NZION TO:'&
     &   ,INT(Z-ZN)+1
        WRITE(MW0,*)                                                    &
     &       '*** SR.RADWAV: CANNOT TREAT NEGATIVE IONS, INCREASE NZION'
        NF=-1
        GO TO 2200
      ENDIF
!
! WE NEED TO CARRY-OUT A POWER SERIES EXPANSION FOR P(X) NEAR THE ORIGIN
!
!      P(X)=A(1)*X**(L+1) +...+A(NK)*X**(L+NK)      (FOR NK SMALL)
!
! TO OBTAIN THE FIRST TWO POINTS P(1)|X=H, P(2)|X=H+H WITH WHICH TO
! START THE OUTWARDS NUMEROV SOLUTION FOR ALL P(I)|X.
! A(1) IS USUALLY TAKEN TO BE UNITY, I.E. WE OBTAIN AN UN-NORMALIZED
! SOLUTION AND NORMALIZE IT SUBSEQUENTLY VIA <P*P>=1.
! FOR VERY LARGE-L EITHER BOTH OF THE STARTING POINTS ARE ZERO (SO THE
! NUMEROV GIVES ALL 0=P(I)|X) OR THE NUMEROV OF P OVERFLOWS AT SOME X>1.
!
! SO, WE DETERMINE A SAFE VALUE X=XC AT WHICH TO START BY CONSIDERATION
! OF THE HYDROGENIC NORMALIZATION C=A(1) VIZ. WHERE C*X**(L+1) FIRST
! EXCEEDS DEPS AND SET ALL P(I)|X<XC TO DEPS. WE DO NOT NEED TO WORRY
! ABOUT ANY NON-HYDROGENIC EFFECTS (ELECTRON CLOUD, RELATIVISTIC, PLASMA
! SCREENING) SINCE WE WILL RENORMALIZE FINALLY AS USUAL.
!
! WE FIRST EVALUATE LOG(C) (TO AVOID UNDERFLOW) WHERE
!
!      C=(2*Z/N)**(L+1)*SQRT[Z*(N+L)!/(N-L-1)!]/[N*(2*L+1)!]
!THEN
!      XC**(L+1)=DEPS/C  I.E. LOG(XC)=[LOG(DEPS)-LOG(C)]/(L+1)
!
!      screen0=screen
      ZC=ZSC                 !=ZSC OPTIMIZES FOR RYD, NEEDED FOR LARGE-L
      DEPS=DEPS0*SQRT(ZC)
      CLOG=TLP*LOG((ZC+ZC)/N)-LOG(REAL(N,WP))
!
      L2=L+L
      L2P=L2+1
      LN=N+L
      T=DZERO
      TL2=DZERO
      DO I=0,L2
        T1=LN-I
        T1=LOG(T1)
        T2=L2P-I
        T2=LOG(T2)
        T=T+(T1-T2)
        TL2=TL2+T2
      ENDDO
!
      CLOG=CLOG+(LOG(ZC)+(T-TL2))/DTWO
      XCLOG=(LOG(DEPS)-CLOG)/TLP
!
      if(abs(xclog).gt.dexp0)then
        write(mw6,*)'***sr.radwav: xclog too large'
        write(mw0,*)'***sr.radwav: xclog too large'
        nf=-1
        go to 2200
      endif
      XC=EXP(XCLOG)
!
      X0=Z*Z-TLL*(ZSC/N)**2             !ESTIMATE OF INNER TURNING POINT
      X0=SQRT(X0)+Z
      X0=TLL/X0
!      write(*,*)z,zsc,n,l
!      write(*,*)x(1),xc,x0
!      clog0=clog
!                                      !FIND A SAFE POSITION IN THE MESH
      K=0
      I0=0
      DO I=1,NI
!        NHI=I
        NC=NTI(I)
        DO J=1,NC
          K=K+1
          IF(X(K).GT.XC)THEN
            IF(J.EQ.1)THEN              !AVOID ENDS
              I2=2                      !NOT =2, INCASE I=1
            ELSEIF(J.EQ.NC)THEN
              I2=NC-1
            ELSE
              I2=J
            ENDIF
!            KC=K+I2-J                   !EVALUTE PS AT X(KC-1), X(KC)
            I1=I
            GO TO 100
          ENDIF
        ENDDO
        I0=I0+NC
      ENDDO
!
      WRITE(MW6,*)                                                      &
     &'***SR.RADWAV:UNABLE TO FIND SAFE STARTING POINT FOR POWER SERIES'
      WRITE(MW0,*)                                                      &
     &'***SR.RADWAV:UNABLE TO FIND SAFE STARTING POINT FOR POWER SERIES'
      WRITE(MW6,*)                                                      &
     &'***SR.RADWAV:FORGOTTEN TO FLAG A RYDBERG ORBITAL?'
      WRITE(MW0,*)                                                      &
     &'***SR.RADWAV:FORGOTTEN TO FLAG A RYDBERG ORBITAL?'
      NF=-1
      GO TO 2200
!
  100 CONTINUE
!
! THESE 3 SETTINGS START AT THE ORIGIN
      IF(L.LT.-9999.OR.N.LT.-9999)THEN
        I0=0
        I1=1
        I2=2
        CLOG=DZERO                   !UN-NORMED A(1)=1
!      elseif(n.lt.10)then            !backwards compatibilty check
!        write(*,*)i0,i1,i2,exp(clog)
!        clog=dzero                   !un-normed a(1)=1
      ENDIF
!
! IF ABOVE COMMENTED-OUT THE BELOW START IN INTERVAL I1 AT PTS I2-1,I2
! AND/OR WE HAVE AN APPROX NORMALIZED START (OPTIMIZED FOR RYD)
!
! EXPAND DPOT(X)=PKOEF(1)/X+PKOEF(2) +..+PKOEF(NC+1)*X**(NC-1)
!
      IF(.NOT.BREL)THEN
!
        NK=5
        NK2=NK-2
        PKOEF(1)=DSIXTH
!
        DO I=1,NK2
          A(I)=(DPOT(I)+VSC(I))*X(I)-Z
          PKOEF(I+1)=PKOEF(I)/X(1)
        ENDDO
!
        PKOEF(1)=Z
        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)
!
        IF(RNUK.GT.DZERO)THEN                 !ADD-IN FINITE NUCLEUS
          PKOEF(1)=ZS0(0)
          DO J=1,JZNM
            I=J+1
            PKOEF(I)=PKOEF(I)+ZS0(J)
          ENDDO
        ENDIF
!
      ENDIF
!
! REPLACE POINT WITH FINITE NUCLEUS (IN POT)
!
      DO I=1,INUK
        T=DPOT(I)-Z/X(I)
        DPOT(I)=DNUK0(I)+T
        DNUK0(I)=T
      ENDDO
!
! CALCULATE A FIRST APPROXIMATION TO THE EIGENVALUE
!
      E=-(ZSC/N)**2
      T=ZN/X(NPRES-5)
      IF(.NOT.BREL.AND.-E.LT.T)E=-T
!
! ADD-IN ANY CORRECTION TO E DUE TO PLASMA POTENTIAL
!
      TE=DZERO
      IF(DENE*ABS(VSC(1)).GT.DZERO)THEN
        MDEN10=MOD(MDEN,ITEN)
  150   IF(MDEN10.EQ.1)THEN
          T=N
          T1=ZN*DEBYE
          T1=T*T/T1
          TE=(ZN/T)**2*(DONE-(DONE-T1)*EXP(-T1))
          GO TO 250
        ENDIF
  200   IF(MDEN10.EQ.2)THEN
          T1=D2PT42*ZN**D2THRD*DENE**D1THRD
          T2=N*N*(5*N*N+1-3*L*(L+1))
          T2=DHALF*T2/(ZN*ZN)
          T2=C3*DENE*T2
! 1.5 TO ALLOW FOR DENSITY DEPENDENT <R**2>
          T2=D1PT5*T2
          TE=T1-T2
          TE=TE+TE
          GO TO 250
        ENDIF
        IF(GAMQ.LT.D2PT5)THEN
          MDEN10=1
          GO TO 150
        ELSE
          MDEN10=2
          GO TO 200
        ENDIF
  250   E=E+TE
        IF(E.GE.DZERO)THEN
          E=E-TE
          TE=TE*D0PT9
          GO TO 250
        ENDIF
      ENDIF
!
      EH=-(Z/N)**2+TE
      IF(EH.GT.DZERO)EH=E+E
      IF(Z.EQ.ZN)EH=D1PT1*EH
      EL=-(ZN/N)**2+TE
      IF(EL.GT.DZERO)EL=DZERO
      IF(Z.EQ.ZN)EL=D0PT9*EL
!
! ADD-IN ANY CORRECTION TO E DUE TO MASS-VELOCITY PLUS DARWIN OPERATORS
!
      Z0=Z
      ZW=ZN
      TLB=TLL
      TLW=TLL
      IF(BREL)THEN
        T=(DFOUR*N/(TL+DHALF)-DTHREE)
        EH=EH-DQUART*DALF*(Z/N)**4*T
        EL=EL-DQUART*DALF*(ZN/N)**4*T
        E=E-DQUART*DALF*(ZSC/N)**4*T
        IF(L.LE.0)THEN
          EH=EH+DALF*(Z/N)**4*N
          EL=EL+DALF*(ZN/N)**4*N
          E=E+DALF*(ZSC/N)**4*N
        ENDIF
      ENDIF
!
      EE=E
!
!-----------------------------------------------------------------------
!
! RE-ENTRY POINTS FOR NEW ESTIMATES OF EL AND EH
!
  300 CONTINUE
!      write(*,*)'e=',e
      IF(E.GE.EL)THEN
        E=(E+EE)/DTWO
        EL=EL/D1PT05
        IF(E.GT.EL)E=EL
      ENDIF
!
  400 CONTINUE
!      write(*,*)'e=',e
      IF(E.LE.EH)THEN
        E=(E+EE)/DTWO
        EH=EH*D1PT05
        IF(E.LT.EH)E=EH
      ENDIF
      EW=E
      EE=E
!
! ASYMPTOTIC MODS DUE TO MASS-VELOCITY OPERATOR
!
      IF(BREL)THEN
        EW=E+DQUART*DALF*E*E
        Z0=Z+DHALF*DALF*Z*E
        ZW=ZN+DHALF*DALF*ZNA*E       !1st IS ZN, NOT ZNA, AS ADDED BELOW
        TLB=TLL-DALF*Z*Z
        TLW=TLL-DALF*ZNA*ZNA          !ZN->ZNA FOR PLASMA NEUTRALIZATION
      ENDIF
!
! CALCULATE JOINING DISTANCE FOR INWARD AND OUTWARD INTEGRATION. WE
! CHOOSE IT AS THE OUTER ONE OF THE TWO POINTS FOR WHICH THE SECOND
! DERIVATIVE OF THE WAVE FUNCTION IS ZERO
! THE SEARCH FOR RJ IS DONE STEP BY STEP FROM X(NPOINT) INWARDS
!
!      X1=ZNA                  !ESTIMATE OF OUTER TURNING POINT (UNUSED)
!      T=ZNA*ZNA+TLL*EW
!      IF(T.GT.DZERO)THEN
!        T=SQRT(T)
!        X1=X1+T
!      ENDIF
!      X1=-X1/EW
!
      JJ=NPOINT
!      ZW0=ZW
!
  500 ZW0=ZW+X(JJ)*VSC(JJ)
      RJ=DZERO
      IF(EW.LT.DZERO)RJ=-ZW0/EW
      IF(X(JJ).LE.RJ)GO TO 700
      T=DTWO*(DPOT(JJ)+VSC(JJ))-TLL/X(JJ)**2+E
      IF(BREL)T=T+PMVDAR(JJ,X(JJ),EE,ZNA,TLL)
      IF(T.LT.DZERO)THEN
        JJ=JJ-1
        IF(JJ.GT.0)GO TO 500
        GO TO 800
      ENDIF
!
  600 RJ=X(JJ)
!
! FIND  THE JOINING POINT.  WE TAKE AS JOINING POINT THE FIRST X
! WHICH IS LARGER THAN THE JOINING DISTANCE.
!
  700 NOUTW=0
!
      rinf2=rj
!
!      rj=min(1.005*rj,x(npoint))
!              write(mw0,*)'rinf2:',rinf2,rj,e
!      write(mw6,1001)nods,jj,x(jj),rj,zn,e,tll,dpot(jj),t
! 1001 format(2i7,7f15.6)
!
!
! RUN THROUGH THE BIG (INDEX I) AND THE SMALL (INDEX J) INTERVALS
!
      DO I=1,NI
        NHI=I
        NC=NTI(I)
        DO J=1,NC
          NOUTW=NOUTW+1
          IF(RJ.LE.X(NOUTW).AND.J.GE.4)THEN
            NTINHI=J
            II=NTI(I)-NTINHI
            IF(I.GT.1)GO TO 1000
            IJPGT=IJPGT-1
            WRITE(MW6,10020)
            JJ=NTI(1)+7
            IF(IJPGT.GT.-10)GO TO 600
            N=0
            GO TO 2200
          ENDIF
        ENDDO
      ENDDO
!
  800 JJ=NPOINT-5
      IJPGT=IJPGT+1
      WRITE(MW6,10010)
      IF(IJPGT.LE.4)GO TO 600
  900 N=-N
      GO TO 2200
!
! SHIFT JOINING POINT IF TOO NEAR TO END OF INTERVAL
! AS WE CALCULATE THE DERIVATIVE WITH 7 POINTS.
!
 1000 IF(II.LT.4)THEN
        NOUTW=NOUTW-(4-II)
        NTINHI=NTINHI+II-4
      ENDIF
!
! DETERMINE THE COEFFICIENTS FOR A SERIES EXPANSION OF
! THE WAVE FUNCTION ABOUT THE ORIGIN
!
      A(1)=DONE
      IF(BREL)THEN
        IF(RNUK.LT.DZERO)THEN                  !POINT
          NK=2
          TQ=DONE+(E+DFOUR/DALF)*X(1)/Z
          TQ=DONE/TQ
          TQ=TQ*TQ
          T=TLL-DALF*Z*Z+D3QRT*TQ
          TLAM=DQUART+T
          TLAM=SQRT(TLAM)-DHALF
          A(2)=(TLAM+DONE)*(TLAM+DTWO)-T
          A(2)=-A(1)*DTWO*Z*(DONE+E*DALF/DTWO)/A(2) !Z=ZS0(0)
          A(3)=A(1)*TLAM/DTWO                       !FOR Q NORM
        ELSE                                   !FINITE
          NK=3
          A(2)=DZERO
!          T=(L+2)*(L+3)-L*(L+1)
          T=4*L+6
          TZE=2*ZS0(1)+E
          TT=DONE+DQUART*DALF*TZE
          TT=-2*ZS0(3)*D3QRT*DALF/TT
          TT=TT-TZE*(DONE+DQUART*DALF)
          A(3)=A(1)*TT/T
        ENDIF
      ELSE
        A(2)=-A(1)*PKOEF(1)/TLP
        DO I=3,NK
          II=I-1
          A(I)=DZERO
          DO K=1,II
            A(I)=A(I)+A(K)*PKOEF(I-K)
          ENDDO
          A(I)=-(DTWO*A(I)+A(I-2)*E)/(II*(2*L+I))
        ENDDO
      ENDIF
!
! CALCULATE FIRST (TWO) POINTS FROM SERIES
! (IF FINITE NUCLEUS THEN THE EXPANSION COEFFICIENTS ARE ONLY VALID
!  INSIDE THE NUCLEUS. CODE TESTS THAT THERE ARE TWO MESH POINTS THERE.)
!
      I2M=I2-1                       !WITHIN THE INTERVAL I1
      J=I2+I0                        !ABSOLUTE POSITION E.G. X(J)
      JM=J-1                         !COULD DO MORE THAN 2 POINTS
!
      DO I=JM,J
        PQ(I)=DZERO                  !CONTAINS THE VALUE OF THE FUNCTION
        DO K=1,NK
          PQ(I)=PQ(I)+A(K)*X(I)**K
        ENDDO
        XLOG=LOG(X(I))
        TXC=CLOG+TL*XLOG
        PQ(I)=PQ(I)*EXP(TXC)
      ENDDO
!
      PQ0=PQ(JM)
      DO I=1,JM-1
        PQ(I)=PQ0
      ENDDO
!
! NOW TRANSFER LAST TWO POINTS FOR NUMEROV INTEGRATION
!
      DO II=2,3
        I=J+II-3
        U(II)=PQ(I)
        IND(II)=I
      ENDDO
!
! CHECK THAT THE FUNCTION DOES NOT CHANGE SIGN BETWEEN THE FIRST TWO
! POINTS. IF IT DOES, THEN PRINT ERROR MESSAGE AND STOP.
! THIS MAY BREAK DOWN AT VERY HIGH-L, C.F. CONTINUUM, SO ONLY TEST AT
! THE INNER TURNING POINT - SEE BELOW.
!  (N.B. DO NOT TEST PRODUCT->UNDER/OVERFLOW)
!
      if(l.lt.30)then
        IF(PQ(JM).GT.DZERO.AND.PQ(J).LT.DZERO.OR.PQ(JM).LT.DZERO.AND.   &
     &     PQ(J).GT.DZERO)THEN
          WRITE(MW6,10060)
          N=0
          GO TO 2200
        ENDIF
      endif
!
! OUTWARD INTEGRATION
!
! NC=NUMBER OF POINTS EXCLUDING THE ORIGIN FOR INTEGRATION.
! XA=START, XB=END OF INTEGRATION
!
      IF(I1.LT.NHI)THEN
        NC=NTI(I1)-I2M
      ELSE                                   !STOP AT MATCHING POINT
        NC=NTINHI+5-I2
      ENDIF
!
      XA=X(JM)
      XB=X(NC+JM)
!
! NODE AT THE ORIGIN DOES NOT COUNT
!
      NODS=1
!
! ESTIMATE INNER TURNING POINT(DON'T START COUNTING NODES UNTIL REACHED)
!
      X0=Z0*Z0+TLB*EW
      IX0=J
!
      if(x0.lt.dzero)then
        WRITE(MW6,*)                                                    &
     &     '*** SR.RADWAV ERROR: NO RADIAL SOLUTION FOR THIS POTENTIAL!'
        WRITE(MW0,*)                                                    &
     &     '*** SR.RADWAV ERROR: NO RADIAL SOLUTION FOR THIS POTENTIAL!'
        l=-999
        go to 2200
      endif
!
      X0=SQRT(X0)+Z0
      X0=TLB/X0
!
! PQ(I) HOLDS THE OUTWARDS INTEGRATION (DP HERE IS JUST WORKSPACE)
! ARRAY INDEX IN NUMEROV MUST INCREASE   (STEPS +1 OF INDEX TO XB)
!
      IND(1)=1
      DO I=I1,NHI
!
        CALL NUMERO(XA,XB,U,IND,NC,EE,ZNA,TLL,DP)
!
        DO II=2,NC
          JM=J
          J=J+1
          PQ(J)=DP(II)
!
!               write(mw13,1111)j,x(j),pq(j)
! 1111          format(i7,1pd15.5,d17.8)
!
! MAKE SURE THE SIGN OF PQ IS ALWAYS WELL DEFINED.
!
          IF(PQ(J).EQ.DZERO)PQ(J)=EMINIM
!
! START COUNTING NODES WHEN FIRST TURNING POINT IS REACHED
!
          IF(X(J).GE.X0)THEN
!
! A NODE IMPLIES A CHANGE OF SIGN IN PQ
!  (N.B. DO NOT TEST PRODUCT->UNDER/OVERFLOW)
!
            IF(PQ(J).GT.DZERO.AND.PQ(JM).LT.DZERO.OR.PQ(J).LT.DZERO.AND.&
     &         PQ(JM).GT.DZERO)NODS=NODS+1
!
! IF NOT YET TOO MANY NODES, OUTWARD INTEGRATION MAY GO ON, BUT
!
            IF(NODS.GT.NODES)THEN            !TOO MANY NODES
!
! THE PRESENT ABSOLUTE OF E THEREFORE REPRESENTS A LOWER LIMIT EL
!
              EL=E
!
!             write(77,*)'el=',e
!             write(77,*)'matching point',noutw,x(noutw),rj
!             do ijk=1,j
!               write(77,*)ijk,x(ijk),pq(ijk)
!              enddo
!             stop
!
! INCREASE THE ABSOLUTE OF E, BUT NOT BY TOO MUCH
!
! test problem cases
!              if(n.lt.10)then         !need small n else too close to 1
!                T=NODS+L                     !T/N>1 AS N=NODES+L
!                T=T/N
!!                T=MAX(T,D1PT1)
!                E=MIN(T,D1PT5)*E
!              else
              E=E*D1PT5
!              endif
!
              IF(L.LT.5)GO TO 400
              X1=-ZN*ZN/TLW
              T=E
              IF(BREL)T=T-D3QRT*DALF*T*T
              IF(T.LT.X1)THEN
                E=DTWO*(T/DTHREE+X1)/DTHREE
                IF(BREL)E=E+D3QRT*DALF*E*E
              ENDIF
              GO TO 400              !START INTEGRATION AGAIN WITH NEW E
            ENDIF
!
          ELSE
!
            IX0=J
!
          ENDIF
!
        ENDDO                                !END OF LOOP OVER POINTS
!
! CALCULATE THE STARTING VALUES FOR NUMEROV FOR THE NEXT INTERVAL
!
        IF(I.LT.NHI)THEN
          U(2)=DP(NC-2)
          U(3)=DP(NC)
          XA=X(J-2)
          IND(2)=J-2
          IND(3)=J
!
! IND(3) GIVES THROUGH X(IND(3)) THE INITIAL POINT OF THE PARTICULAR
! NUMEROV INTEGRATION
!
          IF(I.LT.NHI-1)THEN
            NC=NTI(I+1)+1
          ELSE                               !STOP AT MATCHING POINT
            NC=NTINHI+5
          ENDIF
          XB=X(J+NC-1)
        ENDIF
!
      ENDDO                                  !END OF LOOP OVER INTERVALS
!
! CHECK WHETHER NUMBER OF NODES IS CORRECT
!(IF TOO MANY WE HAVE ALREADY BAILED-OUT)
!
      IF(NODS.LT.NODES)THEN                  !NOT ENOUGH NODES
!
! THE PRESENT ABSOLUTE OF E THEN REPRESENTS AN UPPER LIMIT EH
!
        EH=E
!
! REDUCE THE ABSOLUTE OF E, BUT NOT BY TOO MUCH
!
! test problem cases
!        if(n.lt.10)then              !need small n else too close to 1
!          T=NODS+L
!          T=T/N
!!          T=MIN(T,D0PT95)
!          E=MAX(T,D0PT8)*E                   !T/N<1 AS N=NODES+L
!        else
        E=E/D1PT3
!        endif
!
! START INTEGRATION AGAIN WITH NEW E
!
        GO TO 300
!
      ENDIF
!
! --- WE HAVE OUTWARDS INTEGRATION COMPLETE IN PQ(I).---
!
!      write(77,*)'e=',e
!      do ijk=noutw,npoint
!        write(77,*)ijk,x(ijk),pq(ijk)
!      enddo
!      stop
! --- NOW CARRY-OUT INWARDS INTEGRATION AND HOLD IN DP(I) ---
!
! FIRST FIND STARTING POINT X(NP)
!
      I=NPRES+5
      IF(I.GT.NPOINT)I=NPOINT
      SQRE=SQRT(-E)
      SQRW=SQRT(-EW)
      IF(.NOT.BNORM)PNORM=DONE
      bunder=.false.
!
 1100 NC=I
 1200 NP=I
      XA=X(NP)
      I=I-4
      IF(I.LE.NOUTW)THEN
        WRITE(MW6,10040)MSTEP
!        write(*,*)xa*sqrw,po
        GO TO 900
      ENDIF
!
! THE STARTING VALUES WILL BE CALCULATED WITH A WHITTAKER FUNCTION,
! WHICH MUST NOT BECOME ZERO
!
!OLD      IF(XA*SQRW.GE.DEXP0)GO TO 1000               !CRUDE
!
      ZW0=ZW+X(NP)*VSC(NP)
!
      diffw=dzero
      PO=WHITEX(XA,TL,TLW,EW,ZW0,BNORM,diffw)
!
      if(diffw.gt.dzero)then                          !underflow
        bunder=.true.
        go to 1100
      endif
      if(diffw.lt.dzero)then                          !overflow
        if(bunder)stop 'radwav: mesh too short?'      !should not happen
        np=npoint
      endif
!
      IF(.NOT.BNORM)PNORM=DONE
      PO=ABS(PO)*PNORM
      IF(PO.GE.D1M30)GO TO 1300
      IF(I.GT.MEND)GO TO 1200
      IF(PO.LT.EMINIM)GO TO 1100
!
! THE FUNCTION WILL BE CALCULATED FOR ALL X.LE.X(NP)
!
 1300 NPRES=NP
      IF(BSHORT)THEN
        NP=MEND+5
        IF(NOUTW.GT.MEND)NP=NOUTW+5
        NP=NP+NCORR
        IF(NP.GT.NPRES)NP=NPRES
      ENDIF
!
! CHECK WHETHER NEW STARTING POINT FALLS NOT TOO NEAR TO END OF
! INTERVAL;  PP WILL BE USED FOR DERIVATIVES, NTI(NHI) FOR WEDDLE
!
      II=0
      PP=DXI(NHI)*D840
      DO J=1,NI
        IF(NTI(J).LT.8)GO TO 1400
        NHI=J
        JJ=II+NTI(J)
        IF(JJ.LT.NP)GO TO 1350
        IF(JJ.EQ.NP)GO TO 1500
        IF(NP-II.GE.8)GO TO 1500
        NP=II+8
        IF(NP.LE.NC)GO TO 1500
        NHI=J-1
        NP=II
        II=II-NTI(NHI)
        IF(NOUTW+4.GT.NP)GO TO 1400
        GO TO 1500
 1350   II=JJ
      ENDDO
!
 1400 WRITE(MW6,10030)
      N=0
      GO TO 2200
!
 1500 NTINHI=NTI(NHI)
      NTI(NHI)=NP-II
!
! DP(I) HOLDS THE INWARDS INTEGRATION
! ARRAY INDEX IN NUMEROV MUST DECREASE   (IND(1) NEGATIVE)
!
! OBTAIN THE STARTING VALUES FOR THE NUMEROV INTEGRATION BY
! CALCULATING THE TWO OUTERMOST POINTS WITH THE WHITTAKER FUNCTION
!
!      write(*,*)bshort,diffw
      XA=X(NP)
      ZW0=ZW+X(NP)*VSC(NP)
!
      diffa=dzero          !as earlier call has moved us to a safe start
      DP(NP)=PNORM*WHITEX(XA,TL,TLW,EW,ZW0,BNORM,diffa)
      if(diffa.ne.dzero)write(*,*)'diffa=',diffa       !so very unlikely
!
      I=NP-1
      XB=X(I)
      ZW0=ZW+X(I)*VSC(I)
!
      diffb=diffa                                 !successive points, so
      U(3)=PNORM*WHITEX(XB,TL,TLW,EW,ZW0,BNORM,diffb)
      if(diffb.ne.diffa)write(*,*)'diffb=',diffb      !should not happen
!
      IF(BNORM)GO TO 1700
      U(3)=(U(3)/DP(NP))*D1M30
      DP(NP)=D1M30
      GO TO 1700
!
! A NEW INTERVAL WITH A SMALLER SET UP HAS BEEN ENTERED.
! THE SECOND STARTING POINT HAS TO BE CALCULATED BY AN INTERPOLATION,
! AT 6 EQUIDISTANT POINTS X(J): J=I+3,I+2,I+1,I-1,I-3,I-5.
! INTEGRATE OVER ANOTHER 3 INTERVALS OF THE OLD LENGTH
!
 1600 IND(1)=-2
      I=I-1
      DO J=1,4
        Y(J)=X(I+3-2*J)
      ENDDO
      XB=Y(4)
!
      CALL NUMERO(XA,XB,U,IND,IFOUR,EE,ZNA,TLL,A)
!
      Y(5)=X(I+3)
      Y(6)=X(I+2)
      A(5)=DP(I+3)
      A(6)=DP(I+2)
!
! INTERPOLATE TO GET A FUNCTION VALUE DP(I) AT X(I), THEN PROCEED
! TO USE NUMERO
!
      U(3)=DZERO
      DO II=1,6
        XA=DONE
        XB=DONE
        DO JJ=1,6
          IF(JJ.NE.II)THEN
            XA=XA*(X(I)-Y(JJ))
            XB=XB*(Y(II)-Y(JJ))
          ENDIF
        ENDDO
        U(3)=A(II)*XA/XB+U(3)
      ENDDO
!
 1700 DP(I)=U(3)
!
! ASSIGN STARTING VALUES FOR THE CONTINUATION OF THE NUMEROV
! INTEGRATION
!
      U(2)=DP(I+1)
!
! INTEGRATE INWARDS TO THE MATCHING POINT
!
 1800 IND(2)=I+1
      IND(3)=I
! N.B. THE  U(2),U(3)  ALREADY CONTAIN THEIR PROPER VALUES.
      XA=X(I+1)
!
! DETERMINE NEW I AND INTERVAL
! INDEX I SHALL GIVE THE ARRAY INDEX OF XB
!
      DO J=2,12
!     IF THE END HAS NOT BEEN REACHED YET, CONTINUE WITH THE INTEGRATION
        IF(I.LE.NOUTW-4)THEN
          IF(J.EQ.2)GO TO 2000
          GO TO 1900
        ENDIF
!     CHECK WHETHER THE NEW STEP HAS THE SAME LENGTH AS THE PREVIOUS ONE
        IF(X(I+1)-X(I).GT.(X(I)-X(I-1))*D1PT05)THEN
          IF(J.EQ.2)GO TO 1600
          GO TO 1900
        ENDIF
        I=I-1
        NC=J
      ENDDO
!
 1900 IND(1)=-1
      XB=X(I)
!
      CALL NUMERO(XA,XB,U,IND,NC,EE,ZNA,TLL,A)
!
! STORE RESULT IN DP
!
      DO J=2,NC
        II=I+NC-J
        DP(II)=A(J)
      ENDDO
      GO TO 1800
!
! IF INWARD AND OUTWARD FUNCTIONS HAVE DIFFERENT SIGNS, CHANGE
! THE SIGN OF THE INWARD FUNCTION.
! SCALE OUTWARD AND INWARD FUNCTION TO PQ(NOUTW)=DP(NOUTW)=1.*SIGN(P)
!
 2000 RJ=DONE/ABS(DP(NOUTW))
!     write(mw6,1003)pq(noutw),dp(noutw)
!1003 format(13f10.4)
      IF(PQ(NOUTW)*DP(NOUTW).LT.DZERO)RJ=-RJ
      II=NOUTW-4
      DO I=II,NP
        DP(I)=DP(I)*RJ
      ENDDO
      DQUOT=ABS(DONE/PQ(NOUTW))
      JJ=NOUTW+4
      DO I=1,JJ
        PQ(I)=PQ(I)*DQUOT
      ENDDO
!     write(mw6,1003)(pq(j3),j3=noutw-4,noutw+4)
!     write(mw6,1003)(p(j3),j3=noutw-4,noutw+4)
!1003 format(13f10.4)
!
! CALCULATE DERIVATIVES XB AND XA OF INWARD AND OUTWARD FUNCTIONS
!
      I=NOUTW
      XB=(672*(DP(I+1)-DP(I-1))-168*(DP(I+2)-DP(I-2))                   &
     &   +32*(DP(I+3)-DP(I-3))-3*(DP(I+4)-DP(I-4)))/PP
!
      XA=(672*(PQ(I+1)-PQ(I-1))-168*(PQ(I+2)-PQ(I-2))                   &
     &   +32*(PQ(I+3)-PQ(I-3))-3*(PQ(I+4)-PQ(I-4)))/PP
!
! CALCULATE DP(X)*DP(X), INTEGRATE THAT FUNCTION AND CALCULATE
!                      THE ENERGY CORRECTION ACCORDING TO HARTREE
      PO=DZERO
      DO I=1,NOUTW
        DP(I)=PQ(I)
        IF(ABS(DP(I)).GT.PO)PO=ABS(DP(I))
        PQ(I)=PQ(I)*PQ(I)
      ENDDO
!
      DPMIN=PO*EMINIM
      IF(DP(NOUTW).LT.DZERO)DPMIN=-DPMIN
      POO=PO*D1M30
      DO I=NOUTW,NP
        IF(ABS(DP(I)).LT.POO)DP(I)=DPMIN
        PQ(I)=DP(I)*DP(I)
      ENDDO
!
! INTEGRATE DP(X)*DP(X) AND CORRECT ASYMPTOTICALLY; RESTORE NTI(NHI)
!
      CALL WEDDLE(DZERO,PQ,PP,NTI,DXI,NHI,NP)
!
      NTI(NHI)=NTINHI
      PO=PQ(NP)/(DTWO*SQRW)
      PP=PP+PO
!                           write(mw6,*)pp-po,po,pp,noutw,p(noutw),xa,xb
!
! ENERGY CORRECTION:
!
      DE=DP(NOUTW)*(XB-XA)/PP
!
!      if(itera*2.ge.maxit.and.abs(de).gt.abs(de0))de=sign(de0,de)
!      de0=de
!
!      write(mw0,1001)itera,xa,xb,e,de
!                   ,x(noutw),x(np),dp(noutw),pp!,dp(noutw)/pp
! 1001 format(i3,1p,7e14.5)
!
! ENERGY CORRECTION;  E MUST NOT BECOME POSITIVE
!
      IF(E.GE.DE)DE=E/D1PT5                                 !AS E<0
!
! MORE GENERALLY, E SHOULD NOT EXCEED EL BY A LARGE AMOUNT IN LATER
! STAGES OF ITERATION, IF SO, THEN FAILING SO TRY AND KICK-START
! (E.G. LANTHANIDE/ACTINIDE 4F/5F-ORBITAL COLLAPSE.)
!
      IF(N.GT.1.AND.ITERA*2.LT.MAXIT.AND.E-DE.GT.EL)THEN
        deold=de
        DE=E-EL*1.05
!        write(66,*)el,e,de
        if(abs(de).lt.d1m12)de=deold/2
        itera=itera+1
      ENDIF
!
!
! ENERGY CORRECTION;  E MUST NOT BECOME SO NEGATIVE THAT THERE CAN
! NO OUTWARD TURNING POINT.
!
      IF(L.GE.5)THEN
        XB=-ZN*ZN/TLW
        T=E-DE
        IF(.NOT.BREL)THEN
          IF(T.LT.XB)DE=DTWO*(E-XB)/DTHREE
        ELSE
          T=T-D3QRT*DALF*T*T
          IF(T.LE.XB)THEN
            TT=E-D3QRT*DALF*E*E
            T=(TT+DTWO*XB)/DTHREE
            DE=E-(T+D3QRT*DALF*T*T)
          ENDIF
        ENDIF
      ENDIF
!
! THE APPROXIMATION IS TERMINATED WHEN THE RELATIVE CORRECTION TO
! THE EIGENVALUE IS SMALLER THAN TOL, AND .NOT. BSHORT.
!
      XB=ABS(DE/E)
!                      write(mw6,*)itera,nods,n,l,e,de,xb,bshort,x(np)
      IF(.NOT.BSHORT)THEN
!t        t=log10(-e-1)-.7 !D0PT7
!t        it=nint(t/2,sp)
!        write(mw6,*)it
        IF(XB.LT.TOL)GO TO 2100                         !/10**it
      ENDIF
!
      ITERA=ITERA-1
      IF(XB.LT.D99*TOL.OR.ITERA*2.LT.MAXIT)BSHORT=.FALSE.
!TEST
!T      IF(ABS(DE).GT.5*ABS(DE0)+D1M3)THEN !CORRECTN GROWING, NOT CONVRG
!T        E=E0
!T        DE=DE0/DTWO
!Tc        ITERA=ITERA+1
!T      ELSE
!T        E0=E
!T      ENDIF
!T      DE0=DE
!                                                   write(mw6,*)n,l,e,de
!
! FORM NEW EPSILON
!
!        write(66,11111)itera,e,de
!11111   format(i5,1p,2e17.5)
!
      E=E-DE
!
      IF(PO.GT.D1M3*PP)NCORR=NCORR+10
      PNORM=ABS(RJ)*PNORM
      IF(ITERA.GE.0)GO TO 300
!
      WRITE(MW6,10070)E,DE,MAXIT,N,L
      IF(XB.GT.D99*TOL)THEN
!        if(n.gt.10)then
!          e=e+de
!        else
        WRITE(MW6,*)'***SR.RADWAV ERROR: RADIAL FUNCTION TOO INACCURATE'
        WRITE(MW0,*)'***SR.RADWAV ERROR: RADIAL FUNCTION TOO INACCURATE'
        L=-999
        GO TO 2200
!        endif
      ENDIF
!
! WE ARE DONE
!
 2100 CONTINUE
!
! NORMALIZE THE FUNCTION
! SET ALL FUNCTION VALUES FOR X.GE.X(NP) TO DZERO
!
      PNORM=DONE/SQRT(PP)
      IF(DP(IX0).LT.DZERO)PNORM=-PNORM
      DPMIN=DPMIN*PNORM
      DO I=1,NPOINT
        IF(I.GT.NP)DP(I)=DPMIN
        DP(I)=DP(I)*PNORM
      ENDDO
      PO=DPOT(NP)*X(NP)
!
! Suppress pesky 1s since mesh is large enough, rather 1s is too
! compact in heavy atoms to get outside the charge cloud. Nothing
! to be done and 1s is deep closed-shell core.
!
      IF(NP.LE.MEND.and.K0.GT.MB)THEN
        T=ABS(PO-ZN)
        IF(T.GT.D1M3)WRITE(MW6,10050)NP,X(NP),PO,ZN,N,L
      ENDIF
!
! DP0 CONTAINS THE CORRECT ANORM FOR THE STARTING EXPANSION
!
      IF(PNORM.LT.DZERO)PNORM=-PNORM
      DP0=PNORM*DQUOT*EXP(CLOG)                  !*A(1)=1
      PKOEF(2)=DPOT(1)-Z/X(1)                    !ELECTROSTATIC POT ONLY
      DQ0=(DTWO*PKOEF(2)+E)*DP0                          !NOT USED BY AS
!
! CALCULATE THE CORRECT SCREENING VALUE
!
      EA=E
      SCREEN=Z-N*SQRE
!
      pnorm=done
!
! NORMALIZE TRANSFORMED RELATIVISTIC SOLUTION
!
      IF(BREL)THEN
!
        DO I=1,NP
          DQ(I)=DPOT(I)+VSC(I)
          PQ(I)=DP(I)*DP(I)*DQ(I)
        ENDDO
!
        CALL WEDDLE(DZERO,PQ,PP,NTI,DXI,NHI,NP)
!
        PNORM=DONE+DQUART*DALF*(E+DTWO*PP)
        PNORM=DONE/SQRT(PNORM)
!      w=done                !standard Darwin
!      if(kappa.ne.0)w=-2.   !see also pmvdar
        DO I=1,NP
          PP=DONE+DQUART*DALF*(E+DTWO*DQ(I))
          pp=abs(pp)
          DQ(I)=PP
          PP=SQRT(PP)
!        pp=pp**(w/dtwo)
          DP(I)=DP(I)*PNORM*PP
!        pq(i)=p(i)*p(i)
        ENDDO
!
!      call weddle(dzero,pq,pp,nti,dxi,nhi,np)!further renorm for w.ne.1
!      pp=done/sqrt(pp)
!      pnorm=pnorm*pp
!      do i=1,np
!        p(i)=p(i)*pp
!      enddo
!      write(mw0,*)l,pp
!
        PP=DONE
        IF(RNUK.GT.DZERO)PP=PP+DQUART*DALF*(E+DTHREE*Z/RNUK)
        PP=SQRT(PP)
        DP0=DP0*PNORM*PP
!
!2      DQ0=DQ0*PNORM*PP
!
!      IF(BREL2)THEN
        DQ0=DHALF*DFSC*DP0
        IF(L.EQ.0)DQ0=DQ0*DTWO*A(3)
        IF(L.GT.0)DQ0=DQ0*TL
!
! note. kappa is set in radial
        tkap=-1
        if(kappa.ne.0)tkap=kappa
!
        CALL DIFF(DP,PQ,NTI,DXI,NI)
!
        DO I=1,NP
          DQ(I)=DHALF*DFSC*(PQ(I)+tkap*DP(I)/X(I))/DQ(I)
!t          q(i)=dzero
          PQ(I)=DQ(I)*DQ(I)
        ENDDO
!
        CALL WEDDLE(DZERO,PQ,PP,NTI,DXI,NHI,NP)
!
        PNORM=DONE+PP
        PNORM=DONE/SQRT(PNORM)
        if(brel2)then
          DO I=1,NP
            DQ(I)=DQ(I)*PNORM
            DP(I)=DP(I)*PNORM
          ENDDO
          DP0=DP0*PNORM
          DQ0=DQ0*PNORM
!
          IF(NPOINT.GT.NP)THEN
            DQMIN=PNORM*DPMIN*DQ(IX0)/DP(IX0)
            DO I=NP,NPOINT
              DQ(I)=DQMIN
            ENDDO
          ENDIF
        ENDIF
!
! ESTIMATE SCREENING COMARED TO (RELATIVISTIC) HYDROGENIC FORM
!
        T=-DQUART*DALF*(DFOUR*N/(TL+DHALF)-DTHREE)
        IF(L.EQ.0)T=T+DALF*N
        TT=DONE+DFOUR*T*E
        TT=SQRT(TT)
        TT=(DONE-TT)/(DTWO*T)
        SQRE=SQRT(TT)
        SCREEN=Z-N*SQRE
!
      ENDIF
!
! PUT BACK POINT NUCLEUS
!
      DO I=1,INUK
        T=DPOT(I)
        DPOT(I)=DNUK0(I)+Z/X(I)
        DNUK0(I)=T-DNUK0(I)
      ENDDO
!
!-----------------------------------------------------------------------
!
 2200 CONTINUE
!
! LOCAL
      DEALLOCATE(PQ,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RADWAV: DE-ALLOCATION FAILS FOR PQ'
        NF=0
      ENDIF
!
!      write(*,"(2i5,2f6.1,1p2e12.1)")n,l,screen0,screen,exp(clog0),dp0
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(' SR.RADWAV: JOINING DISTANCE GT LIMIT')
10020 FORMAT(' SR.RADWAV: JOINING POINT LIES IN FIRST INTERVAL ---',    &
     &       ' HAS CHARGE Z GONE OUT OF HAND?')
!                            (Z WRONG, OR SIGMA0 POORLY SPECIFIED)
10030 FORMAT(' SR.RADWAV: MIXUP IN JOINING AREA, CHECK NTI-INPUT FIRST')
10040 FORMAT(' SR.RADWAV: WHITEX ALWAYS ZERO --- TRY BIGGER INTEGRATION'&
     &       ,' RANGE - MORE POINTS (INCREASE MAXB1 2) OR LONGER STEPS '&
     &       ,'(DECREASE MSTEP IN NAMELIST SMINIM)'/' CURRENTLY, MSTEP='&
     &       ,I3)
10050 FORMAT(' RADWAV-WARNING:  INWARD-INTEGRATION STARTED AT X(',I5,   &
     &       ') =',F7.3,': Z(X)-ZN =',F10.6,'  -',F3.0,5X,              &
     &       'FOR  (N L) =',2I3)
10060 FORMAT(' SR.RADWAV: CHANGE OF SIGN AT BEGINNING')
10070 FORMAT(' SR.RADWAV GIVES UP WITH (E,DE)=',1P,2E15.7,' AFTER',I3,  &
     &       ' ITERATIONS OF (N,L)=',2I3,                               &
     &       ' CHECK WHETHER PRECISION GOOD ENOUGH')
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE RADWAV
!
!                             *******************
!
      SUBROUTINE RADWIN(MAXPS)
!
!-----------------------------------------------------------------------
!
!  SR.RADWIN READS RADIAL FUNCTION INPUT AND PROCESSES IT FOR
!  ORBITALS K MARKED BY SIGMA(K).GE.999 & .LT. 5999. IT EXPECTS INPUT
!  IN COLLALG/IMPACT FORMAT -- UNLESS KEY.NE.-9 IN (T1,I5) OF FIRST C
!  AFTER A HEADING CARD WITH KEY.GE.0, THIS VERSION OF SR.RADWIN
!  READS HARTREE-FOCK-FROESE FUNCTIONS P(N,L) AND Q(N,L) AS PROVIDED
!  BY H.SARAPH OR D.C.GRIFFIN FROM CHARLOTTE FROESE'S PROGRAM AT
!  THE USUAL RADII. PROGRAM ASSUMES THESE ARE BOUND FUNCTIONS.
!  USE KEY .EQ. -20 TO READ IN CONTINUUM FUNCTIONS (FORMAT SAME AS
!  OUTPUT RADIAL FUNCTIONS PRODUCED BY AUTOSTRUCTURE).
!  NOTE KEY CAN BE REDEFINED BETWEEN ORBITALS SO A MIXTURE OF BOUND AND
!  CONTINUUM FUNCTIONS CAN BE READ IN. ALTERNATIVE BRANCHES MAY BE
!  INSERTED USING KEY.
!  EXTENDED SO AS TO READ AND PROCESS STO INPUT IF KEY=-10.
!
!  IT IS CALLED BY:
!    SR.RADIAL
!
!  IT CALLS:
!    SR.QEDINT
!    SR.STOPOT
!    SR.TFDAPO
!    SR.WEDDLE
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DMQSS3, ONLY: NL000=>NL,NL=>NL000
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_GENINF, ONLY: SCALER
      USE COMMON_JSPOR,  ONLY: NJO,NLEV,NRR,NT,JN,NGR
      USE COMMON_MISC,   ONLY: NF0,BNAME
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG,MXPIN
      USE COMMON_REL,    ONLY: DMASS,DCD,D2LL
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBDQE, ONLY: DQNL,MXQIN
      USE COMMON_NRBINT, ONLY: DRLI,DYY,IYY,NRLI,MENG,NREL,NLAG,NLAGP   &
     &                        ,BLAG,BBC2
      USE COMMON_NRBOLP, ONLY: OVLPGR,OVLPCF,IPAIR
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
      USE COMMON_NRBPOT, ONLY: POTHAM,MPSEUD
      USE COMMON_NRBQED, ONLY: VPINT,SLFINT,QED
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBSHF, ONLY: DSHIFT,MSHIFT,KSHIFT,MKMAX,MXEP
      USE COMMON_NRBSTO, ONLY: ALF,TEL,MSHELL,MCFSTO,MC,MCFMX,MEXPOT    &
     &                        ,NOCC,NLSTOE,BFIX,BSTO,MXSHLL
      USE COMMON_NRBVAL, ONLY: IVAL,BJUMP,IRAD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (OVRLP=2*D1M6)
      PARAMETER (ID=4)
      PARAMETER (CON1=85.196_WP)
!
      CHARACTER(LEN=4) MBLNK,MHEAD
      CHARACTER(LEN=1) CARD(28)
!
      ALLOCATABLE :: DH(:),DY(:),DP(:),DQ(:),KHLP(:)
      ALLOCATABLE :: DWRK1(:),DWRK2(:)
      ALLOCATABLE :: DOVLP(:),DORIGZ(:)
!
      ALLOCATABLE :: JRADZ(:),ZE(:),CJ(:)
!
      NAMELIST/SRADWIN/ACE,KEY,IREAD                              !,MDUM
!
      DATA MBLNK/'    '/                                  !,MXPIN/MAXB1/
!
!-----------------------------------------------------------------------
!
      IF(IEQ(0).GT.0)THEN                     !NOT A GOOD IDEA ANYWAY...
        WRITE(MW0,*)'*** SR.RADWIN NOT CODED TO READ RELAXED ORBITALS!'
        WRITE(MW6,*)'*** SR.RADWIN NOT CODED TO READ RELAXED ORBITALS!'
        NF=-1
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
! LOCAL
!
! HISTORICALLY, MXPIN AND MXQIN COULD BE USED TO SWITCH-OFF MEMORY USE
! ASSOCIATED WITH RADWIN. NOW UNNECESSARY. CURRENTLY THEY ARE SET
! EQUAL TO MAXRS IN SR.MINIM, WHICH IS THE DPNL, DQNL ALLOCATION.
!
!      MXQIN=SIZE(DQNL,IONE)           !PASSED VIA MODULE
!      MXPIN=SIZE(DPNL,IONE)           !PASSED VIA MODULE
      MXBUF=2*MXPIN
!
      ALLOCATE(DH(MXBUF),DY(0:MXBUF),DP(MXBUF),DQ(MXBUF),KHLP(MAXRS),   &
     &         STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RADWIN: ALLOCATION FAILS FOR DH,DY,DP,DQ,KHLP'
        NF=0
        RETURN
      ENDIF
!
      ALLOCATE(DWRK1(MXPIN),DWRK2(MXPIN),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RADWIN: ALLOCATION FAILS FOR DWRK1,DWK2'
        NF=0
        RETURN
      ENDIF
!
      ALLOCATE(DOVLP(MXORB),DORIGZ(MXORB),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RADWIN: ALLOCATION FAILS FOR DOVLP,DORIGZ'
        NF=0
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
      BMVDR=ALLOCATED(DCD)
      B2LL=ALLOCATED(D2LL)
!
!-----------------------------------------------------------------------
!
! SOME INITIALIZATIONS
!
      IREAD=MR5
      IPMX=0
      DY(0)=DZERO
      MHLP=0
      BLAG=.FALSE.
      BPRNT=JPRINT.NE.-3
      MINK=0
      MSHIFT=10000
      KEY=0
      IORB=0
      SKREEN=DONE
      DZ=NZION
      BORT=MORT.LT.0
      IF(.NOT.BORT)WRITE(MW6,10020)
      K00=1000
      KST=1
!
      IF(NF.GT.0)THEN
        DO K=1,MXORB
          DORIGZ(K)=DZERO
          IF(DEY(K).EQ.DZERO)GO TO 50
          IF(SCREEN(K).GE.D999.AND.SCREEN(K).LT.D5999)GO TO 50
          DORIGZ(K)=DORIG(K)*DZ
   50   ENDDO
        II=1
      ENDIF
!
  100 MXP=MXBUF                                    !MXPIN
!
      IF(BNAME)THEN
        MRR=IREAD
        IREAD=0
!        MDUM=0
        ACE=DZERO
        KEY0=KEY
        KEY=-9
        IF(KEY0.NE.-9)THEN
!
          REWIND(MRR)                  !CASE USER NAMELISTS OUT OF ORDER
!
          READ(MRR,SRADWIN,END=3300,ERR=3300)  ! <------------- NAMELIST
!
          KEY0=KEY
          IF(KEY.EQ.-15)KEY=-9
        ENDIF
        IF(KEY.EQ.-10.AND.IREAD.EQ.0)IREAD=MRR
        MORE=IREAD
        IF(ACE.LT.D1M4)ACE=D1P10
      ELSE
        IF(KEY.NE.-9)READ(IREAD,10100)KEY,MORE,ACE   !,MDUM
      ENDIF
!
      IF(KEY.GE.0.AND.KEY.LT.10)BPRNT=.FALSE.
      IF(MORE.GT.0)IREAD=MORE
      IF(MORE.LE.0)IREAD=MR12
      IF(IREAD.NE.MR5)THEN
        IF(IUNIT(IREAD).EQ.0)THEN
          WRITE(MW6,*)"MISSING INPUT FILE='radwin'..."
          WRITE(MW0,*)'MISSING FILE ON UNIT=',IREAD
          GO TO 3500
        ENDIF
        REWIND(IREAD)
      ENDIF
!
      MXORBI=0
      MPS=0
!
      IF(KEY.EQ.-9)THEN                       !CHECK FIELD USED FOR MPMX
        READ(IREAD,10090,END=3400,ERR=3400)CARD
        BACKSPACE(IREAD)
        IF(CARD(24).EQ.' ')THEN                     !<I5
          READ(IREAD,10091)KEY,MXORBI,MPS,MPMX
        ELSE
          DO I=20,23
            IF(CARD(I).EQ.'.')THEN                  !<=I5
              READ(IREAD,10091)KEY,MXORBI,MPS,MPMX
              GO TO 150
            ENDIF
          ENDDO
          READ(IREAD,10092)KEY,MXORBI,MPS,MPMX      !SAFE-ISH FOR I9
        ENDIF
      ENDIF
!
 150  IF(MXORBI.LE.0)MXORBI=MXORB
      IF(ABS(MPSEUD).GT.0.AND.MPS.NE.ABS(MPSEUD))THEN
        WRITE(MW6,*)'CLOSED-SHELL POTENTIAL INPUT TO RADWIN NOT',       &
     &              ' CONSISTENT WITH CLOSED-SHELL DEFINITION IN ALGEB',&
     &              MPS,MPSEUD
        WRITE(MW0,*)'CLOSED-SHELL POTENTIAL INPUT TO RADWIN NOT',       &
     &              ' CONSISTENT WITH CLOSED-SHELL DEFINITION IN ALGEB'
        GO TO 3500
      ENDIF
!
      J=KEY
      IF(KEY.NE.-20)GO TO 600
      IF(MODE.EQ.1)MODE=2
!     IF(MDUM.GT.0)MODE=MDUM
      IF(MODE.GT.0.AND.MODE.LT.4)GO TO 200
      WRITE(MW6,10130)MODE
      GO TO 3500
!
  200 IF(MHLP.NE.0)GO TO 400
      IF(ACE.LT.D1M4)ACE=D1P10
      IF(BPRNT)WRITE(MW6,10120)KEY,MODE,ACE
!
!
! FOR CONTINUUM WAVEFUNCTION WE DROP ALL POINTS PAST INPUT MAXPS
! SINCE ALL INTEGRALS P*F, P*P SHOULD HAVE CONVERGED BY THEN,
! UNLESS GOING INTO SR.RADCON NEXT.
!
      MAXRS0=MAXRS
      IF(MAUTO.NE.0)THEN                     !IF(MAUTO.EQ.0)MAXTS=MAXRS0
        MAXTS=MAXPS
        if(maxps.eq.0)maxts=maxrs
        MJH0=MJH
        MAXRS=0
        DO I=1,MJH0
          MAXRS=MNH(I)+MAXRS
          MJH=I
          IF(MAXRS.EQ.MAXTS)GO TO 300
          IF(MAXRS.GT.MAXTS)THEN
            MAXRS=MAXRS-MNH(I)
            MNH(I)=MAX(MAXTS-MAXRS,ININE)
            MAXRS=MAXRS+MNH(I)
            GO TO 300
          ENDIF
        ENDDO
      ENDIF
!
  300 IF(BPRNT)WRITE(MW6,10030)MAXRS,MAXRS0
!
! RE-ENTRY POINT TO READ ORBITALS
!
  400 IF(KEY.NE.-20)GO TO 1100
!
      READ(IREAD,10110)MYN,MYL,DDY,MPMX,MHEAD,MP
!
! PROGRAM ASSUMES SAME ENERGY FOR EACH CONTINUUM ORBITAL, WILL PUT DDY
! IN DYY(NREL) FOR NOW WHERE NREL=1 IS DEFAULT SET IN SR.RADIAL,
! NO DSHIFT AND NO INTERPOLATION POSSIBLE.
!
!   MP .GT. 0 PRINTS OUT INPUT FUNCTION AS INTERPOLATED ONTO
!   SUPERSTRUCTURE GRID. MP .GT. 5 PRINTS OUT CONTIUUM FUNCTION ON
!   ORIGINAL GRID
!
      IF(MYL.LT.0)GO TO 3000
      IF(MPMX.GT.0)GO TO 500
      IF(MPMX.EQ.0)GO TO 3000
      MHLP=1
      GO TO 100
  500 IF(DDY.LT.DZERO)WRITE(MW6,10340)DDY
!
      DO I=1,MXP                          !MPMX
!        IF(I.LE.MXP)THEN
        READ(IREAD,10350)L,DY(I),DP(I),DQ(I)
        IF(MP.GT.5)WRITE(MW6,10350)L,DY(I),DP(I),DQ(I)
!        ENDIF
      ENDDO
!
      DP0=DZERO
      IF(DY(1).GT.DZERO)DP0=DP(1)/DY(1)**(MYL+1)
      IF(MHLP.GE.0)GO TO 800
      GO TO 2100
!
  600 IF(BPRNT)WRITE(MW6,10030)MAXRS,MAXRS
      DP0=DZERO
      DDY=DZERO
      IF(KEY.EQ.-9)GO TO 1800
      IF(KEY.EQ.-10)GO TO 1100
!
! ASSUME MXP.LE.MXPIN POINTS DY FOR (HARTREE-FOCK-FROESE) CARD INPUT
! (ADDITIONAL CARDS WILL BE SKIPPED-DO49; 2 POINTS PER CARD)
!
      DM=DONE/(DFOUR*DFOUR)
      DD=-DFOUR
!
      DO I=1,MXP
        DY(I)=EXP(DD)/DZ
        DD=DD+DM
      ENDDO
      GO TO 800
!
! ADDRESS ARRAY KHLP WILL HELP TO INTERP. DY ONTO DX
!
  700 MXP=IPMX
  800 II=1
      MHLP=-1
      DO K=1,MAXRS
        KHLP(K)=0
        GO TO 900
  850   II=II+1
  900   IF(II.GT.MXP)GO TO 1000
        IF(II.EQ.MXP)GO TO 950
        IF(DY(II+1)+DY(II).LT.DX(K)*DTWO)GO TO 850
  950   IF(DX(K).GT.DY(MXP))GO TO 850
        KHLP(K)=II
 1000 ENDDO
!
      IF(KEY.EQ.-20)GO TO 2100
 1100 MYN=0
      N=0
      NSTO=0
      DP0=DZERO
      IORB=IORB+1
      IF(IORB.GT.MXORBI)GO TO 3000
      IF(KEY.GE.0)GO TO 1700
!
      READ(IREAD,10070,END=3000)J,N,MYN,MYL,DDY,MPMX,MHEAD,MP
!
      IF(J.EQ.0)GO TO 3000
      IF(J.EQ.-5)GO TO 3000
      SKREEN=DZERO
      MPMX=MPMX*2
      DDY=-ABS(DDY)                   !COMPENSATE FOR MCHF
      IF(KEY.GE.-9)GO TO 1800
      IF(J.LE.0)GO TO 1800
!
!-----------------------------------------------------------------------
!
! COMPUTE SLATER TYPE ORBITALS FROM INPUT IN RMATRX/STG1 FORMAT,
!              I.E. READ  ISTO(K),ZESTO(K),CSTO(K), WHEN KEY=-10.
!
      MPMX=0
      MP=0
      MHEAD=MBLNK
      DY(1)=DZERO
      INORM=N
      N=J
!
      ALLOCATE(JRADZ(0:N),ZE(0:N),CJ(0:N))
!
      READ(IREAD,*)(JRADZ(K),K=1,N)
      READ(IREAD,*)(ZE(K),K=1,N)
      READ(IREAD,*)(CJ(K),K=1,N)
!
      NSTO=N
!
! COMPUTE P AND Q BAR0, AND SATISFY CUSP CONDITION IF SO TOLD BY MYN
!
 1200 K=1
 1300 L=JRADZ(K)
      DM=DZERO
      DD1=DZERO
      DP0=DZERO
      DD2=DZERO
      DQ0=DZERO
      DO K=1,N
        IF(JRADZ(K).LT.L)GO TO 1300
        IF(JRADZ(K).EQ.L)THEN
          IF(ZE(K).GT.DM)DM=ZE(K)
          DP0=CJ(K)+DP0
          DD=ZE(K)*CJ(K)
          DD1=DD+DD1
          DQ0=(DZ*2-(2*L+1)*ZE(K))*DD+DQ0
        ELSEIF(JRADZ(K).EQ.L+1)THEN
          DD2=CJ(K)+DD2
          DQ0=((L*2+1)*ZE(K)-DZ)*2*CJ(K)+DQ0
        ENDIF
      ENDDO
!
      JRADZ(0)=L
      if(myn.le.0)MYL=L-1
      MYN=-1                                                !**** NRB
      CJ(0)=DZERO
      ZE(0)=DZ
!
! TRY  IF(ZE(0).LE.DM*1.1)MYN=-2
!   MODIFY  Z(0) FOR CUSP CORRECTION IF REQUIRED.
!
      DDY=DZERO
      IF(MYN+1.NE.0)THEN
        IF(MYN+1.LT.0)ZE(0)=-MYN*DM
        DD=(DD2-DD1)*L+DZ*DP0
        IF(ABS(DD).LT.D1M5)GO TO 1400
        IF(L*ZE(0).LE.DZ)ZE(0)=(DZ+DONE)/L
        CJ(0)=DD/(L*ZE(0)-DZ)
        DP0=CJ(0)+DP0
        DDY=(DZ*2-(2*L+1)*ZE(0))*ZE(0)*CJ(0)+DQ0
      ENDIF
      DQ0=DDY
!
 1400 SKREEN=CJ(0)
!      ######   POSSIBLY TEMPORARY, FOR PRINTING C(0) CUSP CORRECTION.
!      DDY=-ZE(0)
      DDY=DZERO
!
      DO K=1,MXORB
        IF(2*MYL.NE.QL(K))GO TO 1500
        IF(DEY(K).EQ.DZERO)GO TO 1500
        IF(DORIGZ(K).NE.DZERO)GO TO 1500
        MYN=MOD(INT(QN(K),SP),I70)
        GO TO 1600
 1500 ENDDO
!
      WRITE(MW6,10220)
      GO TO 400
!
! COMPUTE SLATER TYPE ORBITAL AT THE INTERNAL GRID POINTS (I=1,MAXRS)
!
 1600 MYLLP=MYL*(MYL+1)                       !CASE PSEUDO, NOT X**(L+1)
      DO I=1,MAXRS
        DD1=DX(I)
        J=L
        DD2=DD1**J
        DM=(MYLLP/DD1-2*DZ)/DD1
        DP(I)=DZERO
        DQ(I)=DZERO
        DO K=0,N
          IF(ZE(K)*DD1.LT.CON1)THEN
            IF(JRADZ(K).NE.J)DD2=DD1**JRADZ(K)
            J=JRADZ(K)
            DD=CJ(K)*DD2*EXP(-ZE(K)*DD1)
            DP(I)=DD+DP(I)
            DQ(I)=(((1-J)/DD1+ZE(K)*2)*J/DD1-ZE(K)*ZE(K)+DM)*DD+DQ(I)
          ENDIF
        ENDDO
      ENDDO
!
      J=KEY
      GO TO 2200
!
! END OF STO EXTENSION
!-----------------------------------------------------------------------
!
 1700 READ(IREAD,10140,END=3000)MYN,MYL,J,N,DDY,SKREEN,MPMX,DP0,DM,     &
     &                          MHEAD,MP
!
! A BLANK (P/Q) HEADING CARD SERVES AS A DATA INPUT TERMINATOR.
!
 1800 IF(MPMX.LT.0)GO TO 100
      IF(MPMX.EQ.0)GO TO 3000
!
! DO 49 PROCESSES A RANDOM ORDERED SET THAT MAY EXCEED BUFFER SIZES.
!
      DO I=1,MPMX,2
!
        READ(IREAD,10140)L,L,L,I1,DD1,DD,I2,DD2,DM
!
        I2=I1+1
        IF(J.NE.-9)GO TO 1900
        IF(I1.GT.MXP)GO TO 2000
        IF(I1.EQ.MXP)GO TO 1850
        DY(I2)=DD2
        DH(I2)=DM
 1850   DY(I1)=DD1
        DH(I1)=DD
        GO TO 2000
 1900   IF(I1.GT.MXP)GO TO 2000
        IF(I1.EQ.MXP)GO TO 1950
        DP(I2)=DD2
        DQ(I2)=DM
 1950   DP(I1)=DD1
        DQ(I1)=DD
 2000 ENDDO
!
      IF(DP0.EQ.DZERO.AND.DY(1).GT.DZERO)DP0=DP(1)/DY(1)**(MYL+1)
      IF(DDY.GT.DZERO)WRITE(MW6,10330)DDY
!
 2100 IF(NF.LE.0)GO TO 400
      IF(MXQIN.EQ.1)GO TO 400
      IPMX=MIN(MPMX,MXP)
      IF(J.EQ.-9)GO TO 700
!     IF(N.LE.-MPSEUD)GO TO 72 ! POTENTIAL DERIVATIVE
      IF(MPSEUD.LT.0.AND.N.LE.ABS(MPSEUD))GO TO 400
                                                   !CASE N=0 & MPSEUD=0
! REQUIRES A CONSISTENT ORBITAL NUMBER BE READ-IN.
      IF(KEY.NE.-20)THEN
        L=MPMX-IPMX
        IF(MPMX.GT.MXP+1)WRITE(MW6,10080)L,MPMX,MXPIN,MXP,DY(IPMX),     &
     &                                   DP(IPMX)
      ENDIF
!
 2200 II=MAXRS-2
      IF(BPRNT)WRITE(MW6,10010)DDY,MHEAD,MP,MYN,MYL
      IF(KEY.NE.-20.AND.DDY.EQ.DZERO)DDY=-D1M10
      IF(MPSEUD.GT.0.AND.N.LE.MPSEUD)GO TO 2400
                                              ! DITTO N=0
!
      DO K=1,MXORB
        IF(2*MYL.NE.QL(K))GO TO 2300
        IF(DORIGZ(K).NE.DZERO)GO TO 2300
        IF(DEY(K).EQ.DZERO)GO TO 2300
!       IF(K.LE.ABS(MPSEUD))GO TO 68
        N=K
        IF(N.LT.K00)K00=N
        MQN=MOD(INT(QN(K),SP),I70)
        IF(MQN.NE.ABS(MYN))THEN
!          if(mqn.gt.myl)go to 68 !trust n-label, but dangerous for KCOR
          WRITE(MW6,10250)K,MYN
          WRITE(MW0,10260)MYL,K,MQN,MYN
!          GO TO 99
        ENDIF
        IF(QN(K).LT.80.AND.QN(K).GT.69)QN(K)=INT(ABS(MYN),QP)
        IF(KEY.GE.0.AND.JPRINT.NE.-3)WRITE(MW6,10320)QN(N),MYL
        IF(DDY.LT.DZERO)GO TO 2400
        QN(N)=-QN(N)
        IYY(N)=1
        IYY(IEQ(N))=1                       !CASE NOT IN GROUP 1
        DYY(NREL)=DDY
! N.B.DYY CONTAINS INTERPOLATION ENERGIES. PROGRAM ASSUMES SAME
!     INTERPOLATION ENERGY FOR EACH CONTINUUM ORBITAL.
        GO TO 2400
 2300 ENDDO
!
      WRITE(MW6,10220)
      WRITE(MW0,10230)MYN,MYL
      GO TO 400
!
 2400 IF(DP0.NE.DZERO)GO TO 2500
      DP0=DP(1)
      DP(1)=DZERO
      DQ(1)=DZERO
!
! ALLOW FOR CONTINUUM ELECTRON WITH ZERO ENERGY
! NEW IF(DP(IPMX).EQ.DZERO)  IPMX=IPMX-1
! LAGRANGE INTERPOLATION (ID+1 POINTS) FROM ARGUMENTS DY TO DX(L)
! FOR E>=0 FUNCTION VALUES BEYOND THE SUPPLIED AND HELD RANGE ARE SET =0
! FOR E<0  THE FUNCTION VALUES ARE EXTENDED USING ASYMPTOTIC FORMS
!
 2500 LM=MAXRS
      DO L=1,MAXRS
        DD1=DP(L)
        DD2=DQ(L)
        DD3=DZERO
        IF(NSTO.NE.0)GO TO 2550
        DD1=DZERO
        DD2=DZERO
        IF(DX(L).GT.DY(IPMX))THEN                       !BEYOND SUPPLIED
          IF(DDY.GE.DZERO)GO TO 2550
          LM=L-1
          TE=SQRT(-DDY)
          TXM=DX(LM)
          DPNORM=DPNL(LM,N)
          IF(L.LE.MXQIN)THEN
            IF(DPNORM.EQ.DZERO)THEN
              DQNORM=DZERO
            ELSE
              DQNORM=DQNL(LM,N)/DPNORM-DDY
              DQNORM=DQNORM*TXM                         !=-2*MION
            ENDIF
          ENDIF
          IF(MPSEUD.NE.0)DD3=POTHAM(LM)*TXM
          GO TO 2600
        ENDIF
!
        M=KHLP(L)-ID/2
        I1=MAX(M,IONE)
        I2=I1+ID
        IF(I2.GT.IPMX)I2=IPMX
        DO I=I1,I2
          DD=DONE
          DM=DONE
          DO J=I1,I2
            IF(J.NE.I)THEN
              DM=(DX(L)-DY(J))*DM
              DD=(DY(I)-DY(J))*DD
            ENDIF
          ENDDO
          DD1=DP(I)*DM/DD+DD1
          DD2=DQ(I)*DM/DD+DD2
          DD3=DH(I)*DM/DD+DD3
        ENDDO
        J=KHLP(L)
        IF(MP.GT.0)WRITE(MW6,10360)L,DX(L),J,I1,I2,DY(J),DD1
!
 2550   IF(ABS(DD1).LT.D1M70)THEN
          IF(DD1.NE.DZERO)DD2=DD2/DD1
          DD1=SIGN(D1M70,DD1)
          DD2=DD2*DD1
        ENDIF
        DPNL(L,N)=DD1
        IF(L.LE.MXQIN)DQNL(L,N)=DD2
        IF(MPSEUD.NE.0)POTHAM(L)=DD3/DX(L)
        IF(ABS(DD1).GT.D1M6)MAXPS=MAX(MAXPS,L)
      ENDDO
!
! EXTEND BOUND FUNCTIONS
!
 2600 DO L=LM+1,MAXRS
        TXL=DX(L)
        T=TXL-TXM
        DD1=DPNORM*EXP(-TE*T)
        IF(ABS(DD1).LT.D1M70)DD1=SIGN(D1M70,DD1)
        DPNL(L,N)=DD1
        IF(L.LE.MXQIN)THEN
          DD2=DQNORM/TXL+DDY
          DQNL(L,N)=DD2*DD1
        ENDIF
        IF(MPSEUD.NE.0)POTHAM(L)=DD3/TXL
        IF(ABS(DD1).GT.D1M6)MAXPS=MAX(MAXPS,L)
      ENDDO
!
      DD3=DZERO
      DORIG(N)=DP0
      DORIGZ(N)=DP0*DZ
      IF(N.LE.MPSEUD)GO TO 400                ! BLUME  & WATSON
!     IF(MPSEUD.GT.0.AND.N.LE.MPSEUD)GO TO 72  ! BLUME & WATSON
!
! GENERATE A Q-FUNCTION INTERNALLY IF NONE SUPPLIED (KEY=-15)
! E.G. IF INPUT FROM GRASP.
!
      IF(KEY0.EQ.-15)THEN
        DTOL=D1M2
        TOL=D1M7
        MPP=1
        IORT=ABS(MORT)
        DHNS0=DHNS(1)
        DJ=DADJUS(N)
        DJ0=DJ
        MK=N
        NELC=MION                 !-MRED
        DS=DZ
        IF(DJ.GT.DZERO)GO TO 2650
        IF(IORT.EQ.2)GO TO 2650
        IF(BREL)GO TO 2650
!
        IF(IORT.LT.4)DS=-DJ*DZ                !HYDROGENIC WAVE FUNCTIONS
        IF(IORT.EQ.4)DS=-QN(MK)*(NZION-NELC+1)*DJ/DTWO    !PSEUDO-STATES
        IF(IORT.EQ.5)DS=-(NZION-NELC+1)*DJ              !BOX-STATE BASIS
!
        NELC=1
        DJ0=DONE
!
 2650   IF(.NOT.BSTO)CALL TFDAPO(DS,NELC,MK,DJ0,DONE,DONE,DHNS0,MAXRS,  &
     &                           MJH,MNH,DX,DWRK1,TOL,MEND,CRRCT1,      &
     &                           CRRCT2)                          !,DHNS
!
        IF(BSTO)CALL STOPOT(DS,NELC,MK,DJ0,DHNS0,MAXRS,MJH,MNH,DHNS,DX, &
     &                      DWRK1,DTOL,MEND,MPP)
!
        IF(DHNS(1).NE.DHNS0)THEN
          WRITE(MW6,*)'***ERROR SR.RADWIN: UNABLE TO DETERMINE ',       &
     &                'POTENTIAL INTERNALLY...'
          WRITE(MW0,*)'***ERROR SR.RADWIN: UNABLE TO DETERMINE ',       &
     &                'POTENTIAL INTERNALLY...'
          GO TO 3500
        ENDIF
!
        IF(MPP.EQ.1)THEN
          IF(BORT)THEN
            IF(.NOT.BSTO)WRITE(MW6,10170)QN(MK),MYL,DJ,MEND,DX(MEND)
            IF(BSTO)WRITE(MW6,10180)QN(K),MYL,MCFSTO(MK),DJ,MEND,       &
     &                              DX(MEND)
          ELSE
            IF(.NOT.BSTO)WRITE(MW6,10190)MYL,DJ,MEND,DX(MEND)
            IF(BSTO)WRITE(MW6,10200)MYL,DJ,MEND,DX(MEND)
          ENDIF
        ENDIF
        DO I=1,MAXRS
          DQNL(I,N)=DPNL(I,N)*((DWRK1(I)-DZ/DX(I))*DTWO+DDY)   !DDY(RYD)
        ENDDO
      ENDIF
!
! ORTHONORMALIZE (SCHMIDT PROCEDURE DO63, NORMALIZATION DO64-65)
! ONLY ATTEMPT TO ORTHOG TO FUNCTIONS K .LT. N IF BORT TRUE
!
      K0=MXORB
 2700 IF(BORT)THEN
        K0=N
        IF(MORT.EQ.-3.AND.IRLX.NE.2)KST=N+1
      ENDIF
!      DD=DZERO
!
      DO K=KST,K0
!
        DD=DZERO     !INITIALIZE ALL FOR SAFETY AS NANs CAN BE ALLOCATED
!
        IF(QL(N).NE.QL(K))GO TO 2750
        IF(SCREEN(K).GE.D999)GO TO 2750
        IF(DEY(K).EQ.DZERO)GO TO 2750
!       IF(K.LE.ABS(MPSEUD))GO TO 63
        IF(QN(K).LT.0)GO TO 2750    !AVOID TRYING TO ORTHOG TO CONTINUUM
        IF(MORT.LT.0.AND.IRLX.NE.2.AND.N.NE.K.AND.QN(N).EQ.QN(K))       &
     &     GO TO 2750                                        !FOR SAFETY
!        IF(MORT.LE.-4.AND.N.NE.K.AND.QN(N).EQ.QN(K))GO TO 63   !BOX/LPS
!
        DO I=1,MAXPS
          DWRK1(I)=DPNL(I,K)*DPNL(I,N)
        ENDDO
!
        CALL WEDDLE(DZERO,DWRK1,DD,MNH,DHNS,MJH,MAXPS)
!
        IF(K.LT.N)THEN
          L1=N
          L2=K
        ELSE
          L1=K
          L2=N
        ENDIF
!
        IF(JPRINT.NE.-3)WRITE(MW6,10280)QN(L1),MYL,QN(L2),MYL,DD
!
        IF(MORT.LE.-4)THEN                 !BOX/LPS
          IF(IVAL(L1).EQ.1)THEN
            NN=QN(L2)
            IF(DADJUS(L2).LT.DZERO)NN=-NN
            WRITE(MW16,10210)QL(L1)/2,QN(L1),NN,DD
            IF(QN(L1).LE.NN)THEN
              WRITE(MW6,10160)L1,QN(L1),NN,L2
!              GO TO 99                    !ERROR: VALENCE N .LE. CORE N
              DD=DZERO
              GO TO 2750
            ENDIF
            IF(DADJUS(L2).LT.DZERO)GO TO 2750
!         ELSE
!           IF(DADJUS(L1)*DADJUS(L2).LT.DZERO)THEN
!             NN=QN(L1)
!             IF(DADJUS(L1).LT.DZERO)NN=-NN
!             WRITE(MW16,795)QL(L2)/2,QN(L2),NN,DD
!           ENDIF
          ENDIF
        ENDIF
!
        IF(IRLX.EQ.2)THEN
          KK=((L1-1)*(L1-2))/2+L2
          OVLPGR(KK)=DD
          GO TO 2750
        ENDIF
!
        DO I=1,MAXRS
          IF(I.LE.MXQIN)DQNL(I,L1)=DQNL(I,L1)-DD*DQNL(I,L2)
          DPNL(I,L1)=DPNL(I,L1)-DD*DPNL(I,L2)
        ENDDO
!
        DORIG(L1)=DORIG(L1)-DD*DORIG(L2)
!
 2750   DOVLP(K)=DD
!
!       DD3=DZERO FOR MODES 1&2,=SUM OVERLAP**2 FOR MODE GT 3(CONTINUUM)
        IF(K.LT.N.AND.QN(N).LT.0.AND.MODE.GT.2)DD3=DD3+DD*DD
!
      ENDDO                                                          !63
!
!
!TEST WRITE(MW6,100) DDY,M,MP, MYN,MYL
!
! AVOID  RE-NORMALISATION OF CONTINUUM FUNCTION
!
      if(nf.gt.1.and.skreen.eq.dzero.and.ddy.lt.dzero)then
        skreen=dz-qn(n)*sqrt(-ddy)
!        write(*,*)n,qn(n),dz,ddy,skreen
      endif
!
      SCREEN(N)=SKREEN
!
      DO K=N,K0
!
        IF(QL(N).NE.QL(K))GO TO 2800
        IF(SCREEN(K).GE.D999)GO TO 2800
        IF(DEY(K).EQ.DZERO)GO TO 2800
!       IF(K.LE.ABS(MPSEUD))GO TO 86
        IF(QN(K).LT.0)GO TO 2800
        IF(MORT.LT.0.AND.IRLX.NE.2.AND.N.NE.K.AND.QN(N).EQ.QN(K))       &
     &     GO TO 2800                                        !FOR SAFETY
!        IF(MORT.LE.-4.AND.N.NE.K.AND.QN(N).EQ.QN(K))GO TO 86   !BOX/LPS
!
!        DM=DONE
!        IF(K.EQ.N.AND.DD.EQ.DZERO)GO TO 15    !ONLY IF INPUT NORMALIZED
!
        DO I=1,MAXPS
          DWRK1(I)=DPNL(I,K)*DPNL(I,K)
        ENDDO
!
        CALL WEDDLE(DZERO,DWRK1,DD,MNH,DHNS,MJH,MAXPS)
!
        IF(DD.LT.OVRLP.AND.NSTO.LE.0)THEN  !IGNORE NEAR-IDENTICAL FUNCTN
          WRITE(MW6,10150)OVRLP
          GO TO 400
        ENDIF
!
        DM=DONE/SQRT(DD)
!
! THIS TEST IS ALSO SUPRESSED IN THE ORIGINAL VERSION OF SS.
! IF(DORIG(K).LT.DZERO)DM=-DM   !EVENTUALLY POSITIVE SLOPE AT ORIGIN R=0
!
!  15    CONTINUE
!
        DO M=1,MAXRS
          DD1=DM*DPNL(M,K)
          IF(ABS(DD1).GT.D1M6)MAXPS=MAX(M,MAXPS)
!                        =DEL
          IF(I.LE.MXQIN)DQNL(M,K)=DM*DQNL(M,K)
          DPNL(M,K)=DD1
        ENDDO
        DORIG(K)=DORIG(K)*DM
!
 2800 ENDDO
!
! NOW DETERMINE ONE-BODY ENERGY INTEGRALS
!
      INN=ICOL(N,N,IZERO)
!
      DO K=1,K0
!
        DD2=DZERO    !INITIALIZE ALL FOR SAFETY AS NANs CAN BE ALLOCATED
!
        IF(QL(K).NE.QL(N))GO TO 2850                                 !94
        IF(SCREEN(K).GE.D999)GO TO 2850                              !94
        IF(DEY(K).EQ.DZERO)GO TO 2850                                !94
!       IF(K.LE.ABS(MPSEUD))GO TO 93                                !94
        IF(QN(K).LT.0.AND.QN(N).LT.0.AND.MODE.LE.2)GO TO 2850
!
        DO I=1,MAXPS
          DWRK1(I)=DZERO
          IF(I.LE.MXQIN)THEN
            DWRK1(I)=DQNL(I,N)*DPNL(I,K)
!TEST                         DWRK1(I) =(DPNL(I,K)*DQNL(I,N)+DWRK1(I))/2
            IF(MPSEUD.NE.0)DWRK1(I)=DWRK1(I)+DTWO*DPNL(I,N)*DPNL(I,K)   &
     &                              *(DZ/DX(I)-POTHAM(I))
          ENDIF
        ENDDO
!
        CALL WEDDLE(DZERO,DWRK1,DD,MNH,DHNS,MJH,MAXPS)
!
        DD2=DD/DTWO
        DD2=DD2*SCALER                   !C.F. COWAN SLATER SCALE FACTOR
!
 2850   KX=MIN(N,K)
        KY=MAX(N,K)
        IN=ICOL(KX,KY,IZERO)
!
        DUY(IN)=DD2
!
        IF(K.GT.N)THEN
          INK=ICOL(K,K,IZERO)
          DE=DEY(K)-DUY(INK)
          DUY(INK)=DUY(INK)-DOVLP(K)*DUY(IN)*DTWO+DUY(INN)*DOVLP(K)**2
          DEY(K)=DUY(INK)+DE
        ENDIF
!
      ENDDO
!
      IF(QN(N).GT.0)THEN
        DUY(INN)=DUY(INN)-DDY*SCALER/DTWO
        DEY(N)=DUY(INN)+DDY/DTWO
!        DM=DONE                           !ONLY IF INPUT NORMALIZED
        IF(IRAD(N).GT.0)GO TO 3000
        GO TO 2900
      ENDIF
!
      MINK=0
      DD1=-MSHIFT*MINK
      DM=DZERO
      DEY(N)=DUY(INN)+DD1+DDY*(DONE+DD3)/DTWO
      IF(DEY(N).EQ.DZERO)DEY(N)=D1M10
      DUY(INN)=DUY(INN)+DDY*DD3/DTWO
!
 2900 IF(BPRNT)WRITE(MW6,10040)N,QN(N),MYL,MION,NZION,SKREEN,IREAD,     &
     &                         DORIG(N),DY(IPMX),DM,                    &
     &                         (DPNL(I,N),I=II,MAXRS),DEY(N)
      IF(KEY.NE.-10)GO TO 400
! STO
      IF(ABS(DM-DONE).LT.3*D1M1.OR.INORM*NSTO.GT.0)THEN
        DEALLOCATE(JRADZ,ZE,CJ)
        GO TO 1100
      ENDIF
!
      WRITE(MW6,10270)
      DORIGZ(N)=DZERO
      SCREEN(N)=D3999
      IF(NSTO.LE.0)THEN
        WRITE(MW6,*)'CONFUSION OVER NORMALIZATION FOR ORBITAL:',N
        WRITE(MW0,*)'CONFUSION OVER STO/CLEMENTI NORMALIZATION'
        GO TO 3500
      ENDIF
      DO J=1,NSTO
        DD=ZE(J)*DTWO
        DO K=1,2*JRADZ(J)
          DD=ZE(J)*DD*DTWO/K
        ENDDO
        CJ(J)=SQRT(DD)*CJ(J)
      ENDDO
      N=NSTO
      NSTO=-N
      GO TO 1200
!
 3000 IF(BORT.and.(MORT.ne.-3.or.IRLX.ne.2))THEN
        KST=K00
        IF(N.GT.0)IRAD(N)=0
!
        DO K57=K00,MXORB
          IF(IRAD(K57).NE.0)THEN
            N=K57
            MYL=QL(N)/2
            INN=ICOL(N,N,IZERO)
            DDY=(DEY(N)-DUY(INN))*DTWO          !EPS(RYD)
            SKREEN=SCREEN(N)
            SCREEN(N)=3999
            GO TO 2700                          !RE-ORTHONORMALIZE
          ENDIF
        ENDDO
      ENDIF
!
      IF(NF.LE.0)GO TO 3200
!
! CHECK COMPLETENESS OF RADIAL FUNCTION SET
! COMPUTE RELATIVISTIC INTEGRALS (MASS AND DARWIN TERM, EJN-EQ.60)
!
!      MP=MYN
!      IF(MAUTO.EQ.0)GO TO 56       !ALL DONE IN RADCON
!
      MP=0
      DO K=1,MXORB
!
        IF(DEY(K).EQ.DZERO)GO TO 3100
!       IF(K.LE.ABS(MPSEUD))GO TO 52
!
        MP=K
        IF(SCREEN(K).LT.D999.or.screen(k).gt.D5999)GO TO 3050    !RADCON
        IF(SCREEN(K).NE.D999)THEN
          WRITE(MW6,10300)K
          DEY(K)=DZERO
          NF=-1
          GO TO 3100
        ENDIF
        WRITE(MW6,10290)K
 3050   IF(NJO.LE.0.AND..NOT.BMVD.or.qn(k).lt.0)GO TO 3100
!
        DORIGZ(K)=DORIG(K)*DZ
        DX1=DZERO
        IF(MODE.GT.2.AND.IYY(K).GT.0)DX1=DYY(NREL)
!
        DO L=1,K
!
          DP0=DZERO  !INITIALIZE ALL FOR SAFETY AS NANs CAN BE ALLOCATED
          DD=DZERO
          DM=DZERO
!
          IF(DEY(L).EQ.DZERO)GO TO 3060                              !53
!         IF(L.LE.ABS(MPSEUD))GO TO 54                               !53
          IF(QL(K).NE.QL(L))GO TO 3060                               !53
          IF((BREL.OR..NOT.BMVD).AND.NL.LE.NL000)GO TO 3060
          IF(MODE.LE.2.AND.(QN(K).LT.0.OR.QN(L).LT.0))GO TO 3060
!
          DX2=DZERO
          IF(MODE.GT.2.AND.IYY(L).GT.0)DX2=DYY(NREL)
!
          DO I=1,MAXPS
            DWRK1(I)=DZERO
            DWRK2(I)=DZERO
            IF(I.LE.MXQIN)THEN
              DD3=2*DZ/DX(I)
              DD2=DPNL(I,L)*(DD3+DX2)+DQNL(I,L)
              DD1=DPNL(I,K)
              DWRK1(I)=(DD1*(DD3+DX1)+DQNL(I,K))*DD2
              DWRK2(I)=DD1*DD2
              IF(QN(K).LT.0.AND.QN(L).LT.0)THEN
                DD0=DX2*DPNL(I,L)*DPNL(I,K)
                DWRK1(I)=DWRK1(I)-DX1*DD0
                DWRK2(I)=DWRK2(I)-DD0
              ENDIF
            ENDIF
          ENDDO
!
          CALL WEDDLE(DZERO,DWRK2,DP0,MNH,DHNS,MJH,MAXPS)
!
          IF(K.EQ.L)DP0=DP0+DX2
!
          IF(BREL.OR..NOT.BMVD)GO TO 3060                            !53
!
          IF(QL(K).EQ.0)DD=DORIGZ(K)*DORIGZ(L)
          DD3=DD*DFOUR
!
          CALL WEDDLE(DD3,DWRK1,DM,MNH,DHNS,MJH,MAXPS)
!
          IF(L.EQ.K)DM=DM+DX1*DX2
          DM=-DM*DALF/DEIGHT
          DD=DD*DALF/(DZ*DEIGHT)
!
 3060     IN=ICOL(L,K,IZERO)
!
          IF(BMVDR)DMASS(IN)=DM
          IF(BMVDR)DCD(IN)=DD
          IF(B2LL)D2LL(IN)=DP0                                       !53
!
        ENDDO
!
 3100 ENDDO
!
      IF(BREL)THEN
        IF(ABS(IREL).EQ.2)THEN
          DO K=1,MXORB
            IF(DEY(K).NE.DZERO)THEN
              DO I=1,MAXRS
                DQNL(I,K)=DZERO                     !LARGE CPT ONLY READ
              ENDDO
            ENDIF
          ENDDO
!                COULD CONTINUE ZEROED OUT, TBD: ESTIMATE FROM LARGE CPT
          WRITE(MW6,*)'***SR.RADWIN: SMALL COMPONENT NOT AVAILABLE!'
          WRITE(MW0,*)'***SR.RADWIN: SMALL COMPONENT NOT AVAILABLE!'
          GO TO 3500
        ENDIF
      ENDIF
!
! DETERMINE QED CONTRIBUTIONS (ALL ORBITALS)
!
      IF(QED.NE.QZERO)CALL QEDINT(MAXPS)
!
!  56  CONTINUE
      IF(BPRNT.AND.II.GT.1)WRITE(MW6,10050)(DX(I),I=II,MAXRS)
      IF(MAXPS.GT.MXQIN)WRITE(MW6,10060)MXQIN,MAXPS,DX(MXQIN)
!
! TERMINATOR CARD (READ AT 72 READ 570/600) ALLOWS TO SPECIFY PRINTOUT
!
      N=MIN(MYN,MP)
      IF(N.GT.0)THEN
        WRITE(MW6,10310)
        M=MIN(MAXPS,MXQIN)
        DO L=1,M
          WRITE(MW6,10240)L,DX(L),(DPNL(L,I),DQNL(L,I),I=1,N)
        ENDDO
      ENDIF
!
!-----------------------------------------------------------------------
!
 3200 DEALLOCATE(DH,DY,DP,DQ,KHLP)
      DEALLOCATE(DWRK1,DWRK2)
      DEALLOCATE(DOVLP,DORIGZ)
      IF(ALLOCATED(JRADZ))DEALLOCATE(JRADZ,ZE,CJ)
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
 3300 WRITE(MW6,10370)
      WRITE(MW0,*)'*** SR.RADWIN: ERROR READING NAMELIST SRADWIN!'
                                                                  !FATAL
      GO TO 3500
 3400 WRITE(MW6,10380)
      WRITE(MW0,*)'*** SR.RADWIN: ERROR READING radwin FILE!'     !FATAL
!
 3500 NF=-1
      GO TO 3200
!
!-----------------------------------------------------------------------
!
10010 FORMAT(27X,F13.5,30X,A4,I4,I3,I2)
10020 FORMAT(//' ****WARNING IN SR.RADWIN, YOU ARE ASSUMING ORTHOGONAL',&
     &       ' ORBITALS, ERRORS MAY ARISE')
10030 FORMAT(/'GAM ( N,  L,NION, Z, DEL/PI)    OLDEPS/RY OF RADIAL ',   &
     &       'INPUT-FUNCTIONS',4X,                                      &
     &       '(ORIGIN  N L)  FNORM, 3 LAST P, <NL!H1!NL>',';STPS/PTS=', &
     &       I5,'/',I5)
10040 FORMAT(I3,I4,I4,I4,I4,F9.5,13X,I4,1X,F11.5,F10.3,17X,F8.3,1X,     &
     &       3E9.2,F12.4)
10050 FORMAT(38X,'READ("")     PBAR0      RPEND',15X,'3 LAST R:',3F9.4, &
     &       4X,' (H1/2RY)'/)
10060 FORMAT(' SR.RADWIN: P/Q DATA READ WHILE  MAXB2=',I3,' -- SHOULD ',&
     &       'BE .GE.MAXPS=',I5/12X,                                    &
     &       'RESULTS INVOLVING Q(N,L) MAY BE POOR - ','R(MAXB2)/A0 =', &
     &       F9.3)
10070 FORMAT(3I5,I3,7X,F12.6,I6,29X,A4,I4)
10080 FORMAT(66X,'**WARNING**   FOR THE FOLLOWING FUNCTION P'/68X,I3,   &
     &       ' OF THE IPMX=',I4,' INPUT VALUES P/Q HAVE BEEN IGNORED',  &
     &       /68X,'EITHER BECAUSE BUFFER(MXPIN=',I5,                    &
     &       ') CANNOT HOLD THEM'/68X,'OR ',                            &
     &       'BECAUSE ARGUMENTS R HAVE BEEN READ IN FOR ONLY MXP=',I4,  &
     &       ' POINTS'/68X,'-- CUT-OFF RADIUS ',F6.2,'*A0,  P(RCUT) =', &
     &       E10.2)
10090 FORMAT(28A1)
10091 FORMAT(3I5,8X,I5)
10092 FORMAT(3I5,4X,I9)
10100 FORMAT(2I5,5X,F8.4)
10110 FORMAT(2I2,F10.4,I4,A4,I4)
10120 FORMAT(/'   KEY=',I3,2X,'MODE=',I2,2X,'ACCURACY OF ENERGY',       &
     &       ' CONSERVATION=',F8.4,' A.U.',4X,                          &
     &       'CONTINUUM FUNCTIONS IN USE;',' MODES 2 TO 3'/)
10130 FORMAT('  YOUR VALUE OF',I3,' FOR MODE IN SR.RADWIN IS NOT',      &
     &       ' WITHIN THE CURRENT VALID RANGE')
10140 FORMAT(I2,I1,I2,2(I4,2E14.7),3X,A4,I4)
10150 FORMAT(84X,'WILL BE SKIPPED,  OVERLAP .LT.',1PE8.1)
10160 FORMAT(' WARNING: ORBITAL',I3,' HAS VALENCE N=',I3,               &
     &       ' .LE. CORE N=',I3,' OF ORBITAL',I3)
10170 FORMAT(23X,'NL =',I3,I2,'    S.M.-POTENTIAL V(NL) WITH SCALE',    &
     &       ' FACTOR',F10.5,';  COULOMBIC BEYOND R(IEND=',I5,') =',    &
     &       F10.6)
10180 FORMAT(2X,'NL =',I3,I2,'    STO.-POTENTIAL CF=',I3,' WITH SCALE', &
     &       ' FACTOR',F10.5,';  NON-COULOMB POT .LT. 1% OF COULOMBIC', &
     &       ' BEYOND R(IEND=',I5,') =',F10.6)
10190 FORMAT(24X,'LL =',I2,',..   S.M.-POTENTIAL V(LL) WITH SCALE',     &
     &       ' FACTOR',F10.5,';  COULOMBIC BEYOND R(IEND=',I5,') =',    &
     &       F10.6)
10200 FORMAT(3X,'LL =',I2,',..   STO.-POTENTIAL V(LL) WITH SCALE',      &
     &       ' FACTOR',F10.5,';  NON-COULOMB POT .LT. 1% OF COULOMBIC', &
     &       ' BEYOND R(IEND=',I5,') =',F10.6)
10210 FORMAT(3I5,1PE13.4)
10220 FORMAT(84X,'WILL BE SKIPPED,  BECAUSE NO MORE FUNCTIONS ARE'/77X, &
     &       'SPECIFIED BY SIGMA.GE.999 & .LT. 5999 FOR THIS ORBITAL L')
10230 FORMAT(' SR.RADWIN: EXTERNAL ORBITAL BEING SKIPPED FOR N L=',2I2)
10240 FORMAT(I5,(7F18.6))
10250 FORMAT(' SR.RADWIN: MIS-MATCH FOR ORBITAL',I3,' FILE N=',I3)
10260 FORMAT(' SR.RADWIN: MIS-MATCH OF L=',I2,                          &
     &       ' ORBITALS?'/' FOR ORB K=',I3,2X,'INTERNAL N=',I2,         &
     &       ' WHILE EXTERNAL N=',I2)
10270 FORMAT(' REPEAT SINCE NORM INDICATES CLEMENTI TYPE INPUT FORMAT:')
10280 FORMAT('       OVERLAP INTEGRAL',4X,I3,I2,' WITH',2I2,' =',       &
     &       1PE12.4)
10290 FORMAT(61X,"P/Q-INPUT FOR ORBITAL K=",I2," MISSING, S.M. USED - ",&
     &       "ORBITALS MAY"/89X,                                        &
     &       "NOT BE ORTHOGONAL TO INPUT-PNL'S WITH SAME L")
10300 FORMAT(61X,'P/Q-INPUT FOR ORBITAL K=',I2,' MISSING (OR MAXB2 TOO',&
     &       ' SMALL), CASE FAILS')
10310 FORMAT(/" OPTIONAL PRINTOUT OF  I, R(I), N P(I) AND Q(I)'S:"/)
10320 FORMAT(10X,'NL =',I3,I2,4X,'HARTREE-FOCK FROZEN-CORE P-Q INPUT')
10330 FORMAT(' *****WARNING IN SR.RADWIN, YOU HAVE SPECIFIED A BOUND',  &
     &       ' ORBITAL WITH POSITIVE ENERGY=',1PE14.7)
10340 FORMAT(' *****WARNING IN SR.RADWIN, YOU HAVE SPECIFIED A',        &
     &       ' CONTINUUM ORBITAL WITH NEGATIVE ENERGY=',F10.4)
10350 FORMAT(I5,3F18.6)
10360 FORMAT(5X,I4,E14.7,14X,3I4,2E14.7)
10370 FORMAT('*** SR.RADWIN: ERROR READING NAMELIST SRADWIN!'/4X,       &
     &       'IF PRESENT, CHECK FOR ILLEGAL OR MISTYPED VARIABLE NAMES')
10380 FORMAT('*** SR.RADWIN: ERROR/END-OF-FILE READING FILE radwin...')
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE RADWIN
!
!                             *******************
!
      SUBROUTINE REDSS(MAM,QLMC,QBML,QBMS,JYI,JYF,MAXEL)           !,NAM
!
!-----------------------------------------------------------------------
!
!  SR.REDSS REDUCES THE TARGET SLATER SLATE EXPANSION TO THE MINIMUM
!  REQUIRED BY THE COLLISION PROBLEM (IDW.NE.0).
!  CURRENT OPTIONS:
!     ALL M_S.LT.0, AS USED BY AN IC TARGET, ARE RESTRICTED
!     TO  M_S.GE.-NF+2*(NF/2), FOR A BP COLLISION PROBLEM
!     WITH SOME/ALL TARGET CONFIGS OMITTING 2-BODY FINE STRUCTURE.
!     (NOTE: THE LS PROBLEM HAS ALREADY BEEN RESTRICTED BY SR.VCG.)
!
!  IT IS CALLED BY:
!    SR.ALGEB
!
!  IT CALLS:
!    SR.DISKDC
!
!-----------------------------------------------------------------------
!
      USE COMMON_ALGEB,  ONLY: MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD     &
     &                        ,KFBUFF
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_DC,     ONLY: BFAST,DC,IDC
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
      USE COMMON_QTG,    ONLY: MTGD,NXLL,NTT,NTG,JTGD,QTGS,QTGL,QTGD
!
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,INAST0=>NASTB                            &
     &                        ,INASTJ0=>NASTJB,LFACT,JFACT              &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBGCF, ONLY: KGSL,KGCF,NKSL
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION MAM(*),JYI(*),JYF(*)                            !,NAM(*)
      DIMENSION QLMC(MAXEL,*),QBML(*),QBMS(*)
!
!-----------------------------------------------------------------------
!
      IF(ABS(MODD).GT.1)RETURN           !SINCE LS COUPLING, DONE IN VCG
!
      IEND=MTGD
      MTGD1=MTGD+1
!
      MKT=KUTSSX
      IF(MKT.EQ.-1937)MKT=-1             !AS KUTSSX UNSET BY USER
      IF((MKT+3)/2.EQ.1)MKT=1+MKT        !ALIGNS DEFAULT KUTSSX=0 AND -1
!
      IF(-MKT.LT.KMAX)THEN               !SET COLLISION 2FS CFGS
        MKT=ABS(MKT)
      ELSE
!        MKT=0                         !JUST SUPPRESS NOT INIT. WARNINGS
        RETURN                           !SINCE 2FS ON ALL TARGET CFGS
      ENDIF
!
! INITIALIZE (OPEN) WRITE REDUCED DC ARRAY TO DUMP DSKDMP (UNIT33).
! WILL THEN MOVE BACK TO PERMANENT DISKDC (UNIT32)
!
      BDISK=KUTDSK.LT.KMAX               !USE DISKDC
!
      IF(BDISK)THEN
        MOLD=MDCBUF                      !HOLD OLD BUFFER FOR READS
        MNEW=0                           !DETERMINE REDUCED BUFFER
        CALL DISKDC(MRW33,IZERO,IZERO,IZERO,IZERO,IZERO,IZERO)
        IUD=MRW33                        !POINT TO DSKDMP
        MDCF8=0
        MDCFT8=0
      ENDIF
!
! STRIKE OUT SLATER STATES WITH M_S .LT. MSMIN
!
      MSMIN0=-NF+2*(NF/2)
!
      JM0=0
      LB=JYI(1)-1
      M=0
      K1=0                               !FOR BFAST
!
      DO KF=1,KMAX
!
        BDISK=KF.GT.KUTDSK               !USE DISKDC
!
        IF(KF.GT.MKT)THEN                !CAN RESTRICT
          MSMIN=MSMIN0
        ELSE                             !CANNOT AS 2-FS PRESENT
          MSMIN=-999
        ENDIF
!
        JA=JYI(KF)
        JYI(KF)=LB+1
        JB=JYF(KF)
!
        JM=0
        L=JA-1
!
!                               write(mw6,*)'kf=',kf
        DO J=JA,JB
!
          I=L+1
          ML=QBML(J)
          MS=QBMS(J)
!
          IF(MS.GE.MSMIN)THEN
!
            L=I
            LB=L-JM0
!
            QBML(LB)=INT(ML,QP)
            QBMS(LB)=INT(MS,QP)
!                               write(mw6,*)lb,ms,ml
!
            MAM(J)=LB
!
            DO I=1,NF
              QLMC(I,LB)=QLMC(I,J)
            ENDDO
!
          ELSE
!
            MAM(J)=-1
            JM=JM+1
!
          ENDIF
!
        ENDDO
!
!         write(mw0,*)'ss reduction for configuration',kf,':',jyf(kf),lb
        JYF(KF)=LB
        JM0=JM0+JM
!
! NOW STRIKE-OUT CORRESPONDING VCC'S
!
        M1=M+1
        N=NTG(KF-1)
        KSL0=KGCF(KF)-KGCF(KF-1)
!
        DO K0=1,KSL0
!
          IF(BDISK)THEN                                        !READ OLD
            MDCBUF=MOLD
            ISTRT=MTGD1
            CALL DISKDC(MRW32,ISTRT,IEND,KF,K0,IONE,IZERO)
            IF(IEND.LT.0)GO TO 100
          ENDIF
!
          KTT=NKSL(K0,KF)
!
          IF(BFAST)THEN    !ORIGINAL FAST ACCESS, WITHOUT MEMORY POINTER
!
            DO KT=1,KTT
              N=N+1
              I=JTGD(N)
              JTGD(N)=M-JYI(KF)+1
!                               write(mw6,*)'n,jd=',n,jtgd(n)
!
              DO J=JA,JB
                IF(MAM(J).GT.0)THEN
                  M=M+1
                  DC(M)=DC(J+I)
!                               write(mw6,*)j-ja+jyi(kf),j+jd,dc(j+jd)
                ENDIF
              ENDDO
            ENDDO
!
          ELSE                           !MEMORY EFFICIENT OPTION IN USE
!
            DO KT=1,KTT
!
              N=N+1
!
              K2=JTGD(N)                     !absolute end flagged
              IF(K2.LT.0)THEN                !bdisk first so KT=1...
                K2=-K2
                K1=MTGD
              ENDIF
              K1=K1+1
!
!                               write(mw6,*)'n,jd=',n,m+1
              DO K12=K1,K2
                J=IDC(K12)
                IF(MAM(J).GT.0)THEN
                  M=M+1
                  DC(M)=DC(K12)
                  IDC(M)=MAM(J)
!                               write(mw6,*)mam(j),m,dc(m)
                ENDIF
              ENDDO
!
              K1=K2
              JTGD(N)=SIGN(M,JTGD(N))
!
            ENDDO
!
          ENDIF
!
          IF(BDISK)THEN                                       !WRITE NEW
            MDCBUF=MNEW
            ISTRT=M1
            IFIN=M
            CALL DISKDC(MRW33,ISTRT,IFIN,KF,K0,-IONE,IZERO)
            MNEW=MDCBUF
            M=M1-1
          ENDIF
!
        ENDDO
!
      ENDDO
!                              write(mw0,*)'total ss reduction:',jbf,lb
!                              write(mw0,*)'total vcc reduction:',mtgd,m
      MTGD=M
      MTGD1=MTGD+1                      !shouldn't be necess.
!
!                               write(mw6,*)'lb,mtgd=',lb,mtgd
!
! JUGGLE FILES...
!
      IF(BDISK)THEN
        MDCFT8=MDCFT8+MDCF8               !pick-up final config
        WRITE(MW6,10010)MDCFT8
        IF(KUTDSK.LT.KFBUFF)THEN                      !TBD
          write(mw0,*)'kutdsk.ge.1000 not yet coded for idw.ne.0'
          write(mw6,*)'kutdsk.ge.1000 not yet coded for idw.ne.0'
          nf=-1
! note:old mdcbuf2,3 no help since likely will store multiple target slp
!       per total LSP. Ditto, 2FS. So,
!          MDCBUF=MAXDC                    !SINCE UNKNOWN AHEAD OF TIME
!          IF(MDCFT8.LE.MAXDC)THEN
!            M=INT(MDCFT8,SP)
!            MDCBUF=MIN(MDCBUF,MTGD+M)     !FOR SUBSEQUENT ALLOCATE
!          ENDIF
        ELSE
          MDCBUF=MNEW
          MDCBUF=MDCBUF+MDCBUF+MTGD       !SINCE NEED TO HOLD TWO SLICES
!          IF(MDCBUF.GT.MAXDC)THEN        !not poss. since mnew.lt.mold
!            WRITE(MW6,140)MDCBUF
!            NF=-1
!          ENDIF
        ENDIF
! CLOSE/DELETE DISKDC
        CALL DISKDC(MRW32,IZERO,IDW,IZERO,IZERO,IZERO,IZERO)
!        write(mw0,*)mold,mdcbuf
      ENDIF
!
  100 IF(IEND.LT.0)NF=-1
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(/47X,"TOTAL NUMBER OF VCC'S STORED ON DISK:",I12/)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE REDSS
!
!                             *******************
!
      SUBROUTINE RES1(QLMC,MAXEL,MAM,NAM)
!
!-----------------------------------------------------------------------
!
!  SR.RES1 CALCULATES THE ALGEBRA OF THE MATRIX ELEMENTS OF THE
!  SPIN-SPIN MUTUAL SPIN-ORBIT AND SPIN-OTHER ORBIT INTERACTION
!  BETWEEN A PAIR OF STATES OF THE TYPE !CBSLJ MJ), WHERE C =
!  CONFIGURATION, B=DEGENERACY PARAMETER OF TERM S,L AND J, MJ =
!  TOTAL ANGULAR MOMENTUM AND ITS AZIMUTHAL COMPONENT.
!  ORIGINAL ROUTINE WRITTEN BY MICHAEL JONES,
!  REFERENCES: JONES,M., J.PHYS.B.:ATOM.  MOLEC.PHYS. VOL. 4(1971).
!  ***THIS VERSION EVALUATES THE SLATERSTATE INTERACTIONS ONLY - NRB
!
!  IT IS CALLED BY:
!    SR.ALGEB3
!
!  IT CALLS:
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!    FN.VCC
!
!  IT CONTAINS:
!    FN.MVC
!
!-----------------------------------------------------------------------
!
      USE COMMON_ALGEB,  ONLY: MPRINT
!!      COMMON /BASIC/NF,KF,KG,JA,JB,JAP,JBP,MGAP(5)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,JA=>IBSK4,JB=>IBSK5            &
     &              ,JAP=>IBSK6,JBP=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9    &
     &              ,IBSK10=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_CFCT,   ONLY: VCA,VCB,MXLL,MAXLL0,MAXLL1,BVC,BDLBD
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DMQSSS, ONLY: DSSS,MSSS,QSSS
      USE COMMON_DMQSSS, ONLY: IRSS,IRSS0,NLS,NLS00
      USE COMMON_NSTS2,  ONLY: NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2
!
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL2, ONLY: MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBAL3, ONLY: MCFSS,KCFSS,KUTSS,KUTSO,QQCUT
      USE COMMON_NRBAL3, ONLY: DVC12,ICLRS,ICLRR,BLX
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M6)
      PARAMETER (TTYNY=10*TYNY)
      PARAMETER (FSTYNY=10*TTYNY)
!
      DIMENSION QLMC(MAXEL,*),MAM(*),NAM(*)
      DIMENSION Q1(2,2),Q2(2,2),Q3(2,2),Q4(2,2),VC(2),VK(2,3)           &
     &         ,JSS(4),IGAM(5),NEN(2,2),NES(2),NEK(2)
!
      ALLOCATABLE :: IGRGR(:)
!
!-----------------------------------------------------------------------
!
      BPLANT2=MXORB.LT.37.OR.SP.EQ.8
      BSKP=MXLL.EQ.-1
!
      NLS01=NLS00+1
      IF(ICLRR.LT.0)GO TO 600
!
      MXLAM=ABS(MAXLAM)                             !MAX MULTIPOLE VALUE
      NMULT=NMULTE-1                              !LIMIT NO OF MULIPOLES
!
      IDIR=0                             !DIRECT SET=0/1 TO INCLUDE/DROP
      IXCH=0                           !EXCHANGE SET=0/1 TO INCLUDE/DROP
!
      ALLOCATE(IGRGR(MXORB))
!
      DO I=1,MB                                                     !MB0
        IGRGR(I)=I
      ENDDO
!
      NEK(1)=KF
      NEK(2)=KG
!
      IF(QQCUT.EQ.1)THEN
        BSS=.TRUE.          !101
        BSO=.TRUE.
        BSOO=.TRUE.
      ELSEIF(QQCUT.EQ.2)THEN
        BSS=.FALSE.         !102
        BSO=.TRUE.
        BSOO=.FALSE.
      ELSEIF(QQCUT.EQ.3)THEN
        BSS=.FALSE.         !103
        BSO=.FALSE.
        BSOO=.TRUE.
      ELSEIF(QQCUT.EQ.4)THEN
        BSS=.TRUE.          !104
        BSO=.FALSE.
        BSOO=.FALSE.
      ELSEIF(QQCUT.EQ.5)THEN
        BSS=.FALSE.         !105
        BSO=.FALSE.
        BSOO=.FALSE.
      ELSEIF(QQCUT.EQ.6)THEN
        BSS=.TRUE.          !106
        BSO=.FALSE.
        BSOO=.TRUE.
      ELSEIF(QQCUT.EQ.7)THEN
        BSS=.TRUE.          !107
        BSO=.TRUE.
        BSOO=.FALSE.
      ELSEIF(QQCUT.EQ.8)THEN
        BSS=.FALSE.         !108
        BSO=.TRUE.
        BSOO=.TRUE.
      ENDIF
!
! IN LOOPS J1,J2 SCAN THROUGH SLATER STATES IN INITIAL AND
! FINAL STATES RESP., AND CALCULATE CONTRIBUTIONS DUE TO EACH PAIR.
!
      DO J1=JA,JB
!
        JC=MAM(J1)
        NES(1)=JC
!
        DO J2=JAP,JBP
!
          JD=NAM(J2)
!
! THIS NEXT STATEMENT RESOLVES INTERACTIONS BY SLATER STATE
!OLD      IRSS00=IRSS+1
!
          DO I=NLS01,NLS
            IORIG2(I)=0
          ENDDO
!
          NES(2)=JD
          NK=0
!
! NOW COMPARE INITIAL AND FINAL SLATER STATES AND SELECT ONLY THE
! ONES WHICH DIFFER IN NK=TWO, ONE, OR NO SETS OF QUANTUM NUMBERS
!
          MEN=0
          IF(JD.EQ.JC)GO TO 60
!
! FIND THE POSITIONS OF THE ELECTRONS WITH DIFFERING QUANTUM NUMBERS
! STORE THESE IN THE ARRAY NEN
!
          DO I=1,NF
            KB=QLMC(I,JC)
            KA=QCG(I,KF)
            KAC=IEQ(KA)
            DO L=1,NF
              IF(QLMC(L,JD).NE.KB)GO TO 10
              IF(IEQ(QCG(L,KG)).NE.KAC)GO TO 10
              LP=L
              IGRGR(KA)=QCG(L,KG)
              GO TO 20
   10       ENDDO
            NK=NK+1
            IF(NK.GT.2)GO TO 550
            NEN(1,NK)=I
            MEN=I+MEN
            LP=0
   20       QLMC(I,1)=INT(LP,QP)
          ENDDO
!
          K=0
          DO L=1,NF
            DO I=1,NF
              IF(QLMC(I,1).EQ.L)GO TO 40
            ENDDO
            K=K+1
            NEN(2,K)=L
            MEN=L+MEN
            IF(K.EQ.NK)GO TO 60
   40     ENDDO
!
   60     II=0
   80     II=II+1
          IF(II.GT.NF)GO TO 540
          IF(NK.EQ.1.AND.II.EQ.NEN(1,1))GO TO 80
          KK=0
  100     KK=KK+1
          IF(KK.GE.II.AND.NK.EQ.0)GO TO 80
!
! THE ELECTRON LABELLED BY (K1,K2) BELONGS TO THE CONFIGURATION KX
! AND TO THE SLATER STATE KY. K1=NO. OF ELECTRON WITHIN A PAIR AND
! K2=NO. OF PAIR.
!
          IMT=0
          DO K2=1,2
            KP=II
            IF(NK.EQ.0.AND.K2.EQ.2)KP=KK
            DO K1=1,2
!
              NI=K1
              IF(NK.LT.1)GO TO 110
              IF(NK.GT.1)GO TO 105
              IF(K2.EQ.1)GO TO 105
              NI=1
              GO TO 110
!
  105         KP=NEN(K1,K2)
  110         KX=NEK(NI)
              KY=NES(NI)
!              WRITE(MW0,*)KP
!              IF(KP.LE.0)THEN
!                WRITE(MW0,*)'KP.LE.0'
!                NF=-1
!                GO TO 999
!              ENDIF
              IH=QCG(KP,KX)
              IF(QN(IH).GE.90)IMT=IMT+1
              IF(IMT.GT.1)GO TO 520
              MU=QLMC(KP,KY)
              ML=((100+MU)/2)*2-100
              Q1(K1,K2)=QL(IH)
              Q2(K1,K2)=INT(IH,QP)
              Q3(K1,K2)=INT(ML,QP)
              Q4(K1,K2)=INT((MU-ML)*2-1,QP)
!
            ENDDO
          ENDDO
!
          IF(NK.EQ.1)Q2(2,2)=INT(IGRGR(Q2(2,2)),QP)
!
! INITIALIZE DATA FOR LAMBDA-LOOP
!
          VK(1,2)=DZERO
          VK(1,3)=DZERO
          VK(2,2)=DZERO
          VK(2,3)=DZERO
          DV2=DZERO
          DV3=DZERO
          NI=0
!
! NEED TWO INDEXES TO SWITCH BETWEEN DIRECT AND EXCHANGE SINCE THE
! 2FS INTEGERALS DO NOT HAVE THE SYMMETRY OF THE SLATER ONES.
!
! KC.EQ.KB DIRECT PAIR; KC.NE.KB EXCHANGE PAIR
!           ORBITAL CYCLE
!  0    0 : 1,2,3,4
!  0    1 : 1,2,4,3
!  1    1 : 2,1,4,3
!  1    0 : 2,1,3,4
!
          KC=0
  120     KB=0
!
  140     L1=Q1(1,1+KC)
          L2=Q1(1,2-KC)
          IF(L1+L2.EQ.0)GO TO 520                 !NONE
          L3=Q1(2,1+KB)
          L4=Q1(2,2-KB)
          IF(L3+L4.EQ.0)GO TO 520                 !NONE
!
          IF(IDIR.EQ.1.AND.KB.EQ.KC)GO TO 500     !NO EXCHANGE
          IF(IXCH.EQ.1.AND.KB.NE.KC)GO TO 500     !NO EXCHANGE
!
          MU=MIN(L1+L3,L2+L4)
          MP=MOD(MU/ITWO+MXLAM,ITWO)              !ALIGN
          MU=MIN(MU,ITWO*(MXLAM-MP))              !MAX LAM
          MLAM2=MAX(ABS(L1-L3),ABS(L2-L4))        !MIN LAM
          MU=MIN(MU,MLAM2+IFOUR*NMULT)            !LIMIT NUMBER
          MLAM0=MLAM2-4
          IF(MLAM2.GT.0)MLAM2=MLAM0
          MLAM0=MLAM0-4              !FIX SPIN-SPIN NRB FROM PETE FEB 90
          IF(MLAM2.GT.MU)GO TO 500
!
          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)
!
!OLD      BLOGJ=JSS(2).LE.JSS(1).OR.JSS(3).NE.JSS(2).OR.JSS(4).NE.JSS(1)
!OLD         =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),WP))                &
     &        *REAL(MOD(ABS((KB+KC+MEN)*2+MLAM2-ML1-ML2),IFOUR)-1,WP)   &
     &        *DVC12
!
          BSPN=.FALSE.
          IF(BSKP)GO TO 160
!
          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(IONE,ITWO,IONE,M3,MD1,M1)
          DV2=VCC(IONE,ITWO,IONE,M4,MD2,M2)
!
! SPIN-SPIN
!
          DD1=DZERO
          IF(BSS)DD1=-VCC(ITWO,ITWO,IFOUR,MD1,MD2,MST)                  &
     &               *DV1*DV2*DTHREE/(DTWO*SQRT(DFIVE))
!
          M1=MVC(L1,-ML1)
          M2=MVC(L2,-ML2)
          M3=MVC(L3,ML3)
          M4=MVC(L4,ML4)
!
          DDR1=DZERO
          DDR2=DZERO
          IF(MD1*MD2.NE.0)BSPN=.TRUE.
          IF(MD2.EQ.0)THEN
            IF(BSO)DDR1=DV1
            IF(BSOO)DDR2=DV1+DV1
          ENDIF
          IF(MD1.EQ.0)THEN
            IF(BSOO)DDR1=DV2+DV2+DDR1
            IF(BSO)DDR2=DV2+DDR2
          ENDIF
!
! BEGIN LAMBDA LOOP
!
  160     MLAM=MLAM2
          IF(MLAM.GT.MU)GO TO 500
!
          DSJ=-DSJ
  180     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)=DZERO
          VK(2,3)=DZERO
          DV1=DV2
          DV2=DV3
          DV3=DZERO
!
          IF(MLAM1.LT.NI)GO TO 280
          BLMM=MOD(MU-MLAM0,IFOUR).NE.0
          IF(BLMM)GO TO 280
!
          BLH=L1+L3.LT.MLAM1
          BLN=L2+L4.LT.MLAM1
          BLK=MLAM0.LT.0.OR.MLAM0.NE.MLAM
          DD=DONE
!
          IF(BSKP)GO TO 280
!
! THE N-CASE MLAM=-2 (AND ALSO MLAM0.LT.MLAM)
!
          KP=MLAM1/4
          K1=KP+1
          IF(.NOT.BVC)THEN
            IF(L1.GT.MXLL)GO TO 200
            IF(L3.GT.MXLL)GO TO 200
          ENDIF
          IF(.NOT.BLK)THEN
            VC(1)=VCB(M1,M3,KP)
            IF(BLH)GO TO 220
          ENDIF
          VK(1,3)=VCA(M1,M3,K1)
          GO TO 220
!
  200     IF(.NOT.BLK)THEN
            VC(1)=VCC(L1,L3,MLAM0,IZERO,IZERO,IZERO)                    &
     &            *VCC(L1,L3,MLAM2,-ML1,ML3,-MDIFF1)
            IF(BLH)GO TO 220
          ENDIF
          VK(1,3)=VCC(L1,L3,MLAM1,IZERO,IZERO,IZERO)                    &
     &            *VCC(L1,L3,MLAM1,-ML1,ML3,-MDIFF1)/REAL(MLAM1+1,WP)
!
  220     IF(.NOT.BVC)THEN
            IF(L2.GT.MXLL)GO TO 240
            IF(L4.GT.MXLL)GO TO 240
          ENDIF
          IF(.NOT.BLK)THEN
            VC(2)=VCB(M2,M4,KP)
            IF(BLN)GO TO 280
          ENDIF
          VK(2,3)=VCA(M2,M4,K1)
          GO TO 260
!
  240     IF(.NOT.BLK)THEN
            VC(2)=VCC(L2,L4,MLAM0,IZERO,IZERO,IZERO)                    &
     &            *VCC(L2,L4,MLAM2,-ML2,ML4,-MDIFF2)
            IF(BLN)GO TO 280
          ENDIF
          VK(2,3)=VCC(L2,L4,MLAM1,IZERO,IZERO,IZERO)                    &
     &            *VCC(L2,L4,MLAM1,-ML2,ML4,-MDIFF2)/REAL(MLAM1+1,WP)
!
  260     IF(.NOT.BLH)DV3=VK(1,3)*VK(2,3)                               &
     &                    *VCC(MLAM1,MLAM1,ITWO,MDIFF1,MDIFF2,-MST)
!
! NOW MLAM2=MLAM+2
! AND MLAM1=MLAM+4
!
  280     MLAM0=MLAM2                                       !NEXT LAMBDA
          IF(MLAM0.LE.MLAM)GO TO 180
          IF(MLAM1.LT.NI)GO TO 160
!
          IF(BLMM)GO TO 400
          DDR=DZERO
          ML=MLAM+200
          IF(BLK)GO TO 360
          IF(ABS(L4-L2).GT.MLAM)GO TO 340
          IF(BLH)GO TO 300
          IF(BSKP)GO TO 440
!
! FOLLOWING STATEMENT: SPIN-SPIN; THEREAFTER: MUTUAL SPIN-ORBIT.
!
          DDR=SQRT(REAL((MLAM+5)*MLAM1*(MLAM+3)*MLAM2*(MLAM+1),WP))     &
     &        *DD1*VCC(MLAM1,MLAM,IFOUR,MDIFF1,MDIFF2,-MST)*VK(1,3)     &
     &        *VK(2,1)
!
          IF(BSPN)GO TO 380
!
          MD2=(MLAM2-L4+L2)*(MLAM2-L2+L4)*(L2-MLAM+L4)
          IF(MD2.EQ.0)GO TO 300
!ORWE IF(MLAM2.LT.ABS(L2-L4))GO TO 4503-*4502
!
! 2ND V2
!
          DDR=DDR-VCC(MLAM1,MLAM2,ITWO,MDIFF1,MDIFF2,-MST)              &
     &        *SQRT(REAL((MLAM1+L2+L4)*(MLAM+5)*MD2,WP)                 &
     &        /REAL((MLAM+1)*MLAM1*32,WP))*DDR2*VC(2)*VK(1,3)
!
  300     IF(BSPN)GO TO 160                                 !NEXT LAMBDA
!
          IF(ABS(L3-L1).GT.MLAM)GO TO 340
          MD1=(MLAM2-L3+L1)*(MLAM2-L1+L3)*(L3-MLAM+L1)
          IF(MD1.EQ.0)GO TO 320
          IF(BSKP)GO TO 440
!
! 1ST V2
!
          DDR=SQRT(REAL((MLAM1+L1+L3)*MD1,WP)/(32*MLAM2))*VC(1)*VK(2,1) &
     &        *DDR1*VCC(MLAM2,MLAM,ITWO,MDIFF1,MDIFF2,-MST)+DDR
!
  320     IF(MLAM.EQ.0)GO TO 340
          IF(BSKP)GO TO 440
!
!**********************************************************************
! 1ST V3  , POS SIGN IN 1ST AND 2ND V3 GIVE M.JONES TABLE 2 -WERNER
!          , HOWEVER THEY DO NOT GIVE SAME RESULTS FOR CLOSED SHELL
!          , WHEN TREATED AS OPEN (2-BODY F.S.) AS CLOSED (BLUME-WATSON)
!          , SO STAY WITH MINUS FOR NOW. - NRB
!**********************************************************************
!
          DDR=DDR-SQRT(REAL((MLAM+1)*MLAM,WP)/REAL(64*MLAM2,WP))        &
     &        *REAL((L1*(L1+2)-L3*(L3+2)-MLAM*MLAM2),WP)*DDR1*DV1
!
  340     IF(BLH)GO TO 380
          IF(BLN)GO TO 380
  360     IF(BSPN)GO TO 160                                 !NEXT LAMBDA
!
          IF(BSKP)GO TO 440
!
!**********************************************************************
! 2ND V3  , POS SIGN IN 1ST AND 2ND V3 GIVE M.JONES TABLE 2 -WERNER
!          , HOWEVER THEY DO NOT GIVE SAME RESULTS FOR CLOSED SHELL
!          , WHEN TREATED AS OPEN (2-BODY F.S.) AS CLOSED (BLUME-WATSON)
!          , SO STAY WITH MINUS FOR NOW. - NRB
!**********************************************************************
!
          DDR=DDR-DDR2*DV3*SQRT(REAL((MLAM+5)*(MLAM+6),WP)              &
     &        /REAL(64*MLAM1,WP))                                       &
     &        *REAL((L2*(L2+2)-L4*(L4+2)-(MLAM+6)*MLAM1),WP)
!
  380     DD=DDR*DSJ
          GO TO 420
!
  400     IF(BSPN)GO TO 160                                 !NEXT LAMBDA
          ML=MLAM+100
          IF(BSKP)GO TO 440
!
          DD=SQRT(REAL(((MLAM+3)*MLAM2*MLAM1)/4,WP))*DV2*DDR1*DSJ
  420     IF(ABS(DD).LT.TTYNY)GO TO 160                     !NEXT LAMBDA
!
  440     IGAM(5)=ML
!
! IMPOSE V(AB;CD)=V(AD;CB)
! IMPOSE N(AB;CD)=N(AD;CB)=N(CD;AB)=N(CB;AD)
! BY WAY OF FALLING ORDER - NRB
!
          IF(BLMM)THEN
            DO K1=1,3,2
              IGAM(K1)=JSS(K1)
            ENDDO
            K11=2
          ELSE
            K11=1
          ENDIF
          DO K1=K11,2
            IF(JSS(K1).LT.JSS(K1+2))THEN
              KP=2
              JP=0
            ELSE
              KP=0
              JP=2
            ENDIF
            IGAM(K1)=JSS(K1+KP)
            IGAM(K1+KP+JP)=JSS(K1+JP)
          ENDDO
!
! test suppress falling-order
!          do j=1,4
!            igam(j)=jss(j)
!          enddo
!OLD
!          DO K1=1,4
!            KP=K1
!            IF(.NOT.BLMM.AND..NOT.BLOGJ)THEN
!              KP=K1-2
!              IF(KP.LE.0)KP=K1+2
!            ENDIF
!            IGAM(K1)=JSS(KP)
!          ENDDO
!
! STORE CONTRIBUTION TO (EXISTING) COEFFICIENT
!
          IF(BPLANT2)IPLANT=IGAM(5)                                     &
     &                      +((((IGAM(4)*MXORB+IGAM(3))*MXORB+IGAM(2))  &
     &                      *MXORB)+IGAM(1))*1000
!
! test - exclude "core"
!          imt=0
!          do i=1,4
!            if(qn(igam(i)).lt.80)imt=imt+1
!          enddo
!          if(imt.gt.2)go to 267
!
          DO J=NLS01,NLS
            IF(.NOT.BPLANT2)THEN
              DO I=5,1,-1                                    !1,5 SLOWER
                IF(QSSS(I,J).NE.IGAM(I))GO TO 460
              ENDDO
            ELSE
              IF(IPLANT.NE.JORIG2(J))GO TO 460
            ENDIF
            L=J
            I=IORIG2(L)
            IF(I.GT.0)THEN
              DSSS(I)=DSSS(I)+DD
              GO TO 160                                     !NEXT LAMBDA
            ENDIF
            GO TO 480
  460     ENDDO
!
! CANNOT FIND OLD SET OF ARGUMENTS, SO START CONSTRUCTING A NEW SET
!
          L=NLS+1
          IF(L.GT.IXS2I)THEN
!
            IXXX=7*(IXS2I/5+1)
!
            WRITE(MW6,*)'*** RES1: increasing MXS2I from ',IXS2I,       &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** RES1: increasing MXS2I from ',IXS2I,       &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC2(QSSS,IONE,IFIVE,IONE,IXS2I,IFIVE,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'RES1: RE-ALLOCATION FAILS FOR QSSS'
              NF=0
              GO TO 900
            ENDIF
!
            IXXX0=MAX(IXS2I,IAXMI)
            IXXX2=MAX(IXXX,IAXMI)
            IF(IXXX2.GT.IXXX0)CALL RE_ALLOC(IORIG2,IONE,IXXX0,IXXX2,    &
     &         IERR)
            CALL RE_ALLOC(JORIG2,IONE,IXS2I,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'RES1: RE-ALLOCATION FAILS FOR IORIG2,JORIG2'
              NF=0
              GO TO 900
            ENDIF
!
            IXS2I=IXXX
!
          ENDIF
!
          NLS=L
          DO I=1,5
            QSSS(I,L)=INT(IGAM(I),QP)
          ENDDO
          IF(BPLANT2)JORIG2(L)=IPLANT
!
  480     IRSS=IRSS+1
          IF(IRSS.GT.IXS2C)THEN
!
            IXXX=7*(IXS2C/5+1)
!
            WRITE(MW6,*)'*** RES1: increasing MXS2C from ',IXS2C,       &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** RES1: increasing MXS2C from ',IXS2C,       &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC(DSSS,IONE,IXS2C,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'RES1: RE-ALLOCATION FAILS FOR DSSS'
              NF=0
              GO TO 900
            ENDIF
!
            CALL RE_ALLOC(MSSS,IONE,IXS2C,IXXX,IERR)
            CALL RE_ALLOC(NSTJ2,IONE,IXS2C,IXXX,IERR)
            CALL RE_ALLOC(NSTJ2D,IONE,IXS2C,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'RES1: RE-ALLOCATION FAILS FOR MSSS,NSTJ2'
              NF=0
              GO TO 900
            ENDIF
!
            IXS2C=IXXX
!
          ENDIF
!
          IORIG2(L)=IRSS
          MSSS(IRSS)=L
          DSSS(IRSS)=DD
          NSTJ2(IRSS)=JC
          NSTJ2D(IRSS)=JD
!
          GO TO 160                  !NEXT LAMBDA
!
! CYCLE TO NEXT DIRECT/EXCHANGE PAIR
!
  500     IF(KB.NE.0)THEN
            IF(KC.NE.0)GO TO 120
            KC=1
            GO TO 140
          ENDIF
          KB=1
          IF(KC.EQ.0)GO TO 140
!
! END CYCLE
!
  520     IF(NK.LT.1)GO TO 100
          IF(NK.EQ.1)GO TO 80
  540     CONTINUE
!
  550   ENDDO                 !END SCAN OF INITIAL SLATER STATES
!
      ENDDO                 !END SCAN OF FINAL SLATER STATES
!
!
      IF(BLX)GO TO 900                                  !RETURN
!
!     ELIMINATE COEFFICIENTS /DSSS/.LT.TYNY AND ARGUMENTS QSSS THAT HAVE
!     BEEN LISTED BEFORE IN THE REFERENCE LIST
!
  600 ICLRR=0
      IF(IRSS.LT.IRSS0)GO TO 900                        !RETURN, AS NONE
!
      K=IRSS0-1
      KP=0
      DO I=NLS01,NLS
        IORIG2(I)=0
      ENDDO
!
      DO I=IRSS0,IRSS
        JD0=MSSS(I)
        JD=ABS(JD0)
        IF(ABS(DSSS(I)).LT.FSTYNY)THEN
          IF(IORIG2(JD).GT.0)GO TO 800
          JD0=0               !RE-INDEX QSSS AS MAY OCCUR LATER
          GO TO 650
        ENDIF
        K=K+1
        DSSS(K)=DSSS(I)
        NSTJ2(K)=NSTJ2(I)
        NSTJ2D(K)=NSTJ2D(I)
!
  650   IF(JD.LE.NLS00)THEN
          WRITE(MW6,*)'RES1: INFORM NRB OF STOP HERE'
          WRITE(MW0,*)'RES1: INFORM NRB OF STOP HERE'
          NF=-1
          GO TO 900
!        LP=JD
!        GO TO 92
        ENDIF
!
        IF(IORIG2(JD).EQ.0)THEN
          LP=JD-KP
          DO L=1,NLS00
            DO J=1,5
              IF(QSSS(J,JD).NE.QSSS(J,L))GO TO 660
            ENDDO
            KP=KP+1
            IORIG2(JD)=L
            LP=L
            GO TO 700
  660     ENDDO
        ELSE
          LP=IORIG2(JD)
          GO TO 700
        ENDIF
!
        IORIG2(JD)=LP
        DO J=1,5
          QSSS(J,LP)=QSSS(J,JD)
        ENDDO
!
  700   IF(JD0.NE.0)THEN
          MSSS(K)=LP
!          IF(JD0.LT.0)MSSS(K)=-MSSS(K)
        ENDIF
!
  800 ENDDO
!
      NLS=NLS-KP
      IRSS=K
!
!-----------------------------------------------------------------------
!
  900 IF(ALLOCATED(IGRGR))DEALLOCATE(IGRGR)
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION MVC(MLX,MLY)
!
      INTEGER(SP) MLX,MLY,MVC
!
      MVC=((MLX+2)*MLX/2+MLY)/2+1
!
      END FUNCTION MVC
!-----------------------------------------------------------------------
!
      END SUBROUTINE RES1
!
!                             *******************
!
      SUBROUTINE RES2(mam,nam,KK)
!
!-----------------------------------------------------------------------
!
!  SR.RES2 EVALUATES ALGEBRAIC CONTRIBUTIONS TO THE SPIN-ORBIT MATRIX
!  ELEMENTS BY LOOPING OVER ALL SLATER-STATE INTERACTIONS - NRB.
!
!  IT IS CALLED BY:
!    SR.ALGEB3
!
!  IT CALLS:
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!
!-----------------------------------------------------------------------
!
!!      COMMON /BASIC/NF,KF,KG,JGAP(5),NJ2,NJP2,MGAP(2)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,IBSK4=>IBSK4,IBSK5=>IBSK5      &
     &              ,IBSK6=>IBSK6,IBSK7=>IBSK7,IBSK8=>IBSK8,NJ2=>IBSK9  &
     &              ,NJP2=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_DC,     ONLY: BFAST,DC
      USE COMMON_DMQSS3, ONLY: DSS,MSS,QSS
      USE COMMON_DMQSS3, ONLY: IRS,IRS0,NL,NL000
      USE COMMON_DMQSSS, ONLY: DSSS,MSSS,QSSS
      USE COMMON_DMQSSS, ONLY: IRSS,IRSS0,NLS,NLS00
      USE COMMON_NSTS2,  ONLY: NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M7)
      PARAMETER (TTYNY=10*TYNY)
      PARAMETER (FSTYNY=10*TTYNY)
!
      DIMENSION mam(*),nam(*)
!
!-----------------------------------------------------------------------
!
      NL00=NL
!      NL1=NL00+1
!
      DO J=1,NLS
        JORIG2(J)=0
      ENDDO
!
!
!     BEGIN MAIN LOOP 65 OVER SLATER STATE INTERACTIONS
!
      K0=NADS2(KK-1)+1
!
      DO KS=K0,NADS2(KK)
!
        L1=NSTJ2(KS)
        L2=NSTJ2D(KS)
!
        IF(BFAST)THEN
          DDH=DC(L1+NJ2)*DC(L2+NJP2)*DSSS(KS)
        ELSE
          m1=mam(l1)
          if(m1.eq.0)go to 100
          m2=nam(l2)
          if(m2.eq.0)go to 100
          DDH=DC(m1)*DC(m2)*DSSS(KS)
        ENDIF
!
        IF(ABS(DDH).LT.TYNY)GO TO 100
!
        M=MSSS(KS)
        L=JORIG2(M)
        IF(L.GT.0)THEN
          K=IORIG2(L)
          DSS(K)=DSS(K)+DDH
        ELSE
!
!     CANNOT FIND AN OLD SET OF ARGUMENTS EQUAL TO THE NEW SET, SO
!     MUST START CONSTRUCTING A NEW COEFFICIENT.
!
          L=NL+1
          IF(L.GT.IAXMI)THEN
!
            IXXX=7*(IAXMI/5+1)
!
            WRITE(MW6,*)'*** RES2: increasing MAXMI from ',IAXMI,       &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** RES2: increasing MAXMI from ',IAXMI,       &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC2(QSS,IONE,IFIVE,IONE,IAXMI,IFIVE,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'RES2: RE-ALLOCATION FAILS FOR QSS'
              NF=0
              GO TO 300
            ENDIF
!
            IXXX0=MAX(IXS2I,IAXMI)
            IXXX2=MAX(IXS2I,IXXX)
            IF(IXXX2.GT.IXXX0)CALL RE_ALLOC(IORIG2,IONE,IXXX0,IXXX2,    &
     &         IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'RES2: RE-ALLOCATION FAILS FOR IORIG2'
              NF=0
              GO TO 300
            ENDIF
!
            IAXMI=IXXX
!
          ENDIF
!
          IRS=IRS+1
          IF(IRS.GT.IXRSS)THEN
!
            IXXX=7*(IXRSS/5+1)
!
            WRITE(MW6,*)'*** RES2: increasing MXRSS from ',IXRSS,       &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** RES2: increasing MXRSS from ',IXRSS,       &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC(DSS,IONE,IXRSS,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'RES2: RE-ALLOCATION FAILS FOR DSS'
              NF=0
              GO TO 300
            ENDIF
!
            CALL RE_ALLOC(MSS,IONE,IXRSS,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'RES2: RE-ALLOCATION FAILS FOR MSS'
              NF=0
              GO TO 300
            ENDIF
!
            IXRSS=IXXX
!
          ENDIF
!
          NL=L
          DO K=1,5
            QSS(K,L)=QSSS(K,M)
          ENDDO
          JORIG2(M)=L
          IORIG2(L)=IRS
          MSS(IRS)=L
          DSS(IRS)=DDH
!
        ENDIF
!
  100 ENDDO
!
!     CLEAR THE ARRAY OF ZEROS AND ADJUST MSS(K) ACCORDINGLY
!
      IF(IRS.LT.IRS0)RETURN
!
      K=IRS0-1
      KP=0
      DO I=IRS0,IRS
        IF(ABS(DSS(I)).LT.FSTYNY)GO TO 250
        K=K+1
        DSS(K)=DSS(I)
        JD=INT(MSS(I),SP)
        LP=JD-KP
        DO L=1,NL00
          DO J=1,5
            IF(QSS(J,JD).NE.QSS(J,L))GO TO 150
          ENDDO
          LP=L
          GO TO 200
  150   ENDDO
        KP=KP-1
        DO J=1,5
          QSS(J,LP)=QSS(J,JD)
        ENDDO
  200   MSS(K)=LP
  250   KP=KP+1
      ENDDO
!
      NL=NL-KP
      IRS=K
!
!-----------------------------------------------------------------------
!
  300 RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE RES2
!
!                             *******************
!
      SUBROUTINE RESX1(QLMC,NAM,qnf1,MAXEL1)
!
!-----------------------------------------------------------------------
!
!  SR.RESX1 CALCULATES THE SLATER-STATE SPIN-SPIN, MUTUAL SPIN-ORBIT
!  AND SPIN-OTHER ORBIT INTERACTION BETWEEN PAIRS OF ELECTRONS, ONE
!  PAIR BEING CONTINUUM.
!
!  IT IS CALLED BY:
!    SR.ALGXFS
!
!  IT CALLS:
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!    FN.VCC
!
!  IT CONTAINS:
!    FN.MVC
!
!-----------------------------------------------------------------------
!
!!      COMMON /BASIC/NF,KF,KG,JA,JB,MGAP4(4),LI,LF,MGAP1
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,JA=>IBSK4,JB=>IBSK5            &
     &              ,IBSK6=>IBSK6,IBSK7=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9&
     &              ,LI=>IBSK10,LF=>IBSK11,IBSK12=>IBSK12
      USE COMMON_CFCT,   ONLY: VCA,VCB,MXLL,MAXLL0,MAXLL1,BVC,BDLBD
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DMQSSS, ONLY: DSSS,MSSS,QSSS
      USE COMMON_DMQSSS, ONLY: IRSS,IRSS0,NLS,NLS00
!
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDW1, ONLY: MXORB,ma0,mb0
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
      USE COMMON_NRBDW3, ONLY: DVC12O=>DVC12,ICLRR,BLX,BEQUALM
!T      USE COMMON_NRBDWX, ONLY: MAXLX0
      USE COMMON_NSTS2,  ONLY: NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2
      USE COMMON_NRBFL0, ONLY: KINTI,KINTF,KEN2
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M6)
      PARAMETER (TTYNY=10*TYNY)
      PARAMETER (FSTYNY=10*TTYNY)
!
      DIMENSION QLMC(MAXEL1,*),NAM(*),qnf1(*)                           &
     &         ,Q1(2,2),Q2(2,2),Q3(2,2),Q4(2,2),VC(2),VK(2,3)           &
     &         ,JSS(4),IGAM(5),NEN(2,2),NES(2),NEK(2),LLCH(2)
!
      SAVE BSS,BSO,BSOO
      DATA IFIRST/0/
!
!-----------------------------------------------------------------------
!
!t      if(maxlx.ne.maxlx0)stop 'resx1: maxlx...'
!***
      QQCUTX=1                          !TBD (OR COULD USE TARGET QQCUT)
!***
      MXORBC=MXORB+LCONDWJ
      BPLANT2=MXORBC.LT.37.OR.SP.EQ.8
      MPOSC=MXORB+(LCONDWJ+1)/2
!
      BSKP=IDW.LT.0            !MXLL.EQ.-1
!
      NLS01=NLS00+1
      IF(ICLRR.LT.0)GO TO 1300
!
      MXLAM=ABS(MXLAMX)                             !MAX MULTIPOLE VALUE
      NMULT=NMULTX-1                              !LIMIT NO OF MULIPOLES
!
      IDIR=0                             !DIRECT SET=0/1 TO INCLUDE/DROP
      IXCH=0                           !EXCHANGE SET=0/1 TO INCLUDE/DROP
!
      NF1=NF+1
!
      brev=kf.lt.kg
      NEK(1)=KF
      NEK(2)=KG
      LLCH(1)=LI
      LLCH(2)=LF
!
      IF(IFIRST.NE.0)GO TO 100
!
      IF(QQCUTX.EQ.1)THEN
        BSS=.TRUE.          !101
        BSO=.TRUE.
        BSOO=.TRUE.
      ELSEIF(QQCUTX.EQ.2)THEN
        BSS=.FALSE.         !102
        BSO=.TRUE.
        BSOO=.FALSE.
      ELSEIF(QQCUTX.EQ.3)THEN
        BSS=.FALSE.         !103
        BSO=.FALSE.
        BSOO=.TRUE.
      ELSEIF(QQCUTX.EQ.4)THEN
        BSS=.TRUE.          !104
        BSO=.FALSE.
        BSOO=.FALSE.
      ELSEIF(QQCUTX.EQ.5)THEN
        BSS=.FALSE.         !105
        BSO=.FALSE.
        BSOO=.FALSE.
      ELSEIF(QQCUTX.EQ.6)THEN
        BSS=.TRUE.          !106
        BSO=.FALSE.
        BSOO=.TRUE.
      ELSEIF(QQCUTX.EQ.7)THEN
        BSS=.TRUE.          !107
        BSO=.TRUE.
        BSOO=.FALSE.
      ELSEIF(QQCUTX.EQ.8)THEN
        BSS=.FALSE.         !108
        BSO=.TRUE.
        BSOO=.TRUE.
      ENDIF
!
  100 CONTINUE
      IFIRST=1
!
! BEGIN MAIN SLATER-STATE INTERACTION LOOP (J1)
!
      DVC12=DVC12O
!
      DO J1=JA,JB
!
        kk=nam(j1)
        if(brev.or.kk.lt.0)then
          kk=abs(kk)
          i1=2
          i2=1
        else
          i1=1
          i2=2
        endif
        nes(i1)=kinti(kk)
        nes(i2)=kintf(kk)
        jc=nes(1)
        jd=nes(2)
!
!        write(mw6,*)kf,jc,'      ',kg,jd
!
        IF(BEQUALM)THEN
          IF(JD.GT.JC)GO TO 1200
          IF(JD.LT.JC)THEN
            DVC12=2*DVC12O
          ELSE
            DVC12=DVC12O
          ENDIF
        ENDIF
!
        DO I=NLS01,NLS
          IORIG2(I)=0
        ENDDO
!
        NK=1                                !0->1 SINCE CONT-CONT IS ONE
        DO K=1,2                            !INITIALIZE NK=1 CONT-CONT
          NEN(K,1)=NF1
        ENDDO
!
        DDH=DONE                  !PHASE FACTOR FOR REMAINING NF-NK SETS
!
        NU=0
        IF(JD.EQ.JC)GO TO 150                  !SO EQCFS=.TRUE
!
!  NK.EQ.2 HERE
!
        nk=2
        nen2=ken2(kk)
        if(nen2.lt.0)then
          ddh=-ddh
          nen2=-nen2
        endif
        nen(i1,2)=nen2/nf1
        nen(i2,2)=nen2-nen(i1,2)*nf1
!
! test
!        do k=1,2
!          nen(k,1)=nen(k,2)
!          nen(k,2)=nf1
!        enddo
!
        go to 200
!
! NOW NK=1 (CASE JC.EQ.JD ONLY NOW)
!
  150   NU=NU+1
        IF(NU.GT.NF)GO TO 1200
        NEN(1,2)=NU
!
! THE ELECTRON LABELLED BY (K1,K2) BELONGS TO THE CONFIGURATION KX
! AND TO THE SLATER STATE KY. K1=NO. OF ELECTRON WITHIN A PAIR AND
! K2=NO. OF PAIR.
!
  200   DO l=1,2 !=1 FOR SLATER STATES JC (OF KF),=2 FOR JD (OF KG)
          I=L
          DO K=1,2 !=1 FOR FOR FIRST PAIR OF ELECTRON STATES,=2 FOR 2'ND
            IF(NK.LT.K)I=1
            KP=NEN(I,K)
            LP=NES(I)
            MU=QLMC(KP,LP)
            LP=NEK(I)
            LP=QCG(KP,LP)
            IF(LP.GT.MXORB)THEN            !CONTINUUM
              Q1(L,K)=INT(LLCH(L),QP)
!        Q2(L,K)=INT((LLCH(L)-MTJ+1)/2+MPOSC,QP) !wrong llch.lt.mtj even
              Q2(L,K)=INT(LLCH(L)/2-MTJ/2+MPOSC,QP)
!
! now skipped in algxfs
              if(q2(l,k).gt.mxorbc)then     !user has restricted lcondwj
                write(mw0,*)'lmax cont exceeds lcondwj:',mtj,llch(l)
!                go to 1100
              endif
              if(q2(l,k).le.mxorb)then     !user has restricted lcondwj
                write(mw0,*)'lmin cont exceeds lcondwj:',mtj,llch(l)
!                go to 1100
              endif
!
              if(jc.eq.jd.and.l.eq.2)mu=INT(qnf1(jd),SP)
            ELSE
              Q1(L,K)=QL(LP)
              Q2(L,K)=INT(LP,QP)
            ENDIF
!            ML=((100+MU)/2)*2-100       ! 100 -> Q1=QL
            ML=Q1(L,K)
            ML=((ml+MU)/2)*2-ml
            Q3(l,k)=INT(ML,QP)
            Q4(l,k)=INT((MU-ML)*2-1,QP)
          ENDDO
        ENDDO
!
! INITIALIZE DATA FOR LAMBDA-LOOP
!
        VK(1,2)=DZERO
        VK(1,3)=DZERO
        VK(2,2)=DZERO
        VK(2,3)=DZERO
        DV2=DZERO
        DV3=DZERO
        NI=0
!
! NEED TWO INDEXES TO SWITCH BETWEEN DIRECT AND EXCHANGE SINCE THE
! 2FS INTEGERALS DO NOT HAVE THE SYMMETRY OF THE SLATER ONES.
!
! KC.EQ.KB DIRECT PAIR; KC.NE.KB EXCHANGE PAIR
!           ORBITAL CYCLE
!  0    0 : 1,2,3,4
!  0    1 : 1,2,4,3
!  1    1 : 2,1,4,3
!  1    0 : 2,1,3,4
!
        KC=0
  250   KB=0
!
  300   L1=Q1(1,1+KC)
        L2=Q1(1,2-KC)
        IF(L1+L2.EQ.0)GO TO 1100                !NONE
        L3=Q1(2,1+KB)
        L4=Q1(2,2-KB)
        IF(L3+L4.EQ.0)GO TO 1100                !NONE
!
        IF(IDIR.EQ.1.AND.KB.EQ.KC)GO TO 1050    !NO EXCHANGE
        IF(IXCH.EQ.1.AND.KB.NE.KC)GO TO 1050    !NO EXCHANGE
!
        MU=MIN(L1+L3,L2+L4)
        MP=MOD(MU/ITWO+MXLAM,ITWO)              !ALIGN
        MU=MIN(MU,ITWO*(MXLAM-MP))              !MAX LAM
        MLAM2=MAX(ABS(L1-L3),ABS(L2-L4))        !MIN LAM
        MU=MIN(MU,MLAM2+IFOUR*NMULT)            !LIMIT NUMBER
        MLAM0=MLAM2-4
        IF(MLAM2.GT.0)MLAM2=MLAM0
        MLAM0=MLAM0-4
        IF(MLAM2.GT.MU)GO TO 1050
!
        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)
!
        DSJ=SQRT(REAL((L1+1)*(L2+1)*(L3+1)*(L4+1),WP))                  &
     &      *REAL(MOD(ABS((KB+KC)*2+MLAM2-ML1-ML2),IFOUR)-1,WP)         &
     &      *DDH*DVC12
!
        BSPN=.FALSE.
        IF(BSKP)GO TO 350
!
        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(IONE,ITWO,IONE,M3,MD1,M1)
        DV2=VCC(IONE,ITWO,IONE,M4,MD2,M2)
!
! SPIN-SPIN
!
        DD1=DZERO
        IF(BSS)DD1=-VCC(ITWO,ITWO,IFOUR,MD1,MD2,MST)                    &
     &             *DV1*DV2*DTHREE/(DTWO*SQRT(DFIVE))
!
        M1=MVC(L1,-ML1)
        M2=MVC(L2,-ML2)
        M3=MVC(L3,ML3)
        M4=MVC(L4,ML4)
!
        DDR1=DZERO
        DDR2=DZERO
        IF(MD1*MD2.NE.0)BSPN=.TRUE.
        IF(MD2.EQ.0)THEN
          IF(BSO)DDR1=DV1
          IF(BSOO)DDR2=DV1+DV1
        ENDIF
        IF(MD1.EQ.0)THEN
          IF(BSOO)DDR1=DV2+DV2+DDR1
          IF(BSO)DDR2=DV2+DDR2
        ENDIF
!
! BEGIN LAMBDA LOOP
!
  350   MLAM=MLAM2
        IF(MLAM.GT.MU)GO TO 1050
!
        DSJ=-DSJ
  400   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)=DZERO
        VK(2,3)=DZERO
        DV1=DV2
        DV2=DV3
        DV3=DZERO
!
        IF(MLAM1.LT.NI)GO TO 500
        BLMM=MOD(MU-MLAM0,IFOUR).NE.0
        IF(BLMM)GO TO 500
!
        BLH=L1+L3.LT.MLAM1
        BLN=L2+L4.LT.MLAM1
        BLK=MLAM0.LT.0.OR.MLAM0.NE.MLAM
        DD=DONE
!
        IF(.NOT.BSKP)THEN
!
! THE N-CASE MLAM=-2 (AND ALSO MLAM0.LT.MLAM)
!
          KP=MLAM1/4
          K1=KP+1
          IF(.NOT.BVC)THEN
            IF(L1.GT.MXLL)GO TO 420
            IF(L3.GT.MXLL)GO TO 420
          ENDIF
          IF(.NOT.BLK)THEN
            VC(1)=VCB(M1,M3,KP)
            IF(BLH)GO TO 440
          ENDIF
          VK(1,3)=VCA(M1,M3,K1)
          GO TO 440
!
  420     IF(.NOT.BLK)THEN
            VC(1)=VCC(L1,L3,MLAM0,IZERO,IZERO,IZERO)                    &
     &            *VCC(L1,L3,MLAM2,-ML1,ML3,-MDIFF1)
            IF(BLH)GO TO 440
          ENDIF
          VK(1,3)=VCC(L1,L3,MLAM1,IZERO,IZERO,IZERO)                    &
     &            *VCC(L1,L3,MLAM1,-ML1,ML3,-MDIFF1)/REAL(MLAM1+1,WP)
!
  440     IF(.NOT.BVC)THEN
            IF(L2.GT.MXLL)GO TO 460
            IF(L4.GT.MXLL)GO TO 460
          ENDIF
          IF(.NOT.BLK)THEN
            VC(2)=VCB(M2,M4,KP)
            IF(BLN)GO TO 500
          ENDIF
          VK(2,3)=VCA(M2,M4,K1)
          GO TO 480
!
  460     IF(.NOT.BLK)THEN
            VC(2)=VCC(L2,L4,MLAM0,IZERO,IZERO,IZERO)                    &
     &            *VCC(L2,L4,MLAM2,-ML2,ML4,-MDIFF2)
            IF(BLN)GO TO 500
          ENDIF
          VK(2,3)=VCC(L2,L4,MLAM1,IZERO,IZERO,IZERO)                    &
     &            *VCC(L2,L4,MLAM1,-ML2,ML4,-MDIFF2)/REAL(MLAM1+1,WP)
!
  480     IF(.NOT.BLH)DV3=VK(1,3)*VK(2,3)                               &
     &                    *VCC(MLAM1,MLAM1,ITWO,MDIFF1,MDIFF2,-MST)
        ENDIF
!
! NOW MLAM2=MLAM+2
! AND MLAM1=MLAM+4
!
  500   MLAM0=MLAM2                                        !NEXT LAMBDAS
        IF(MLAM0.LE.MLAM)GO TO 400
        IF(MLAM1.LT.NI)GO TO 350
!
        IF(BLMM)GO TO 800
        DDR=DZERO
        ML=MLAM+200
        IF(BLK)GO TO 700
        IF(ABS(L4-L2).GT.MLAM)GO TO 650
        IF(BLH)GO TO 550
        IF(BSKP)GO TO 900
!
! FOLLOWING STATEMENT: SPIN-SPIN; THEREAFTER: MUTUAL SPIN-ORBIT.
!
        DDR=SQRT(REAL((MLAM+5)*MLAM1*(MLAM+3)*MLAM2*(MLAM+1),WP))       &
     &      *DD1*VCC(MLAM1,MLAM,IFOUR,MDIFF1,MDIFF2,-MST)*VK(1,3)       &
     &      *VK(2,1)
!
        IF(BSPN)GO TO 750
!
        MD2=(MLAM2-L4+L2)*(MLAM2-L2+L4)*(L2-MLAM+L4)
        IF(MD2.EQ.0)GO TO 550
!
! 2ND V2
!
        DDR=DDR-VCC(MLAM1,MLAM2,ITWO,MDIFF1,MDIFF2,-MST)                &
     &      *SQRT(REAL((MLAM1+L2+L4)*(MLAM+5)*MD2,WP)                   &
     &      /REAL((MLAM+1)*MLAM1*32,WP))*DDR2*VC(2)*VK(1,3)
!
  550   IF(BSPN)GO TO 350                                  !NEXT LAMBDA
!
        IF(ABS(L3-L1).GT.MLAM)GO TO 650
        MD1=(MLAM2-L3+L1)*(MLAM2-L1+L3)*(L3-MLAM+L1)
        IF(MD1.EQ.0)GO TO 600
        IF(BSKP)GO TO 900
!
! 1ST V2
!
        DDR=SQRT(REAL((MLAM1+L1+L3)*MD1,WP)/(32*MLAM2))*VC(1)*VK(2,1)   &
     &      *DDR1*VCC(MLAM2,MLAM,ITWO,MDIFF1,MDIFF2,-MST)+DDR
!
  600   IF(MLAM.EQ.0)GO TO 650
        IF(BSKP)GO TO 900
!
!**********************************************************************
! 1ST V3  , POS SIGN IN 1ST AND 2ND V3 GIVE M.JONES TABLE 2 -WERNER
!          , HOWEVER THEY DO NOT GIVE SAME RESULTS FOR CLOSED SHELL
!          , WHEN TREATED AS OPEN (2-BODY F.S.) AS CLOSED (BLUME-WATSON)
!          , SO STAY WITH MINUS FOR NOW. - NRB
!**********************************************************************
!
        DDR=DDR-SQRT(REAL((MLAM+1)*MLAM,WP)/REAL(64*MLAM2,WP))          &
     &      *REAL((L1*(L1+2)-L3*(L3+2)-MLAM*MLAM2),WP)*DDR1*DV1
!
  650   IF(BLH)GO TO 750
        IF(BLN)GO TO 750
!
  700   IF(BSPN)GO TO 350                                  !NEXT LAMBDA
!
        IF(BSKP)GO TO 900
!
!**********************************************************************
! 2ND V3  , POS SIGN IN 1ST AND 2ND V3 GIVE M.JONES TABLE 2 -WERNER
!          , HOWEVER THEY DO NOT GIVE SAME RESULTS FOR CLOSED SHELL
!          , WHEN TREATED AS OPEN (2-BODY F.S.) AS CLOSED (BLUME-WATSON)
!          , SO STAY WITH MINUS FOR NOW. - NRB
!**********************************************************************
!
        DDR=DDR-DDR2*DV3*SQRT(REAL((MLAM+5)*(MLAM+6),WP)                &
     &      /REAL(64*MLAM1,WP))                                         &
     &      *REAL((L2*(L2+2)-L4*(L4+2)-(MLAM+6)*MLAM1),WP)
!
  750   DD=DDR*DSJ
        GO TO 850
!
  800   IF(BSPN)GO TO 350                                  !NEXT LAMBDA
!
        ML=MLAM+100
        IF(BSKP)GO TO 900
!
! V1
!
        DD=SQRT(REAL(((MLAM+3)*MLAM2*MLAM1)/4,WP))*DV2*DDR1*DSJ
  850   IF(ABS(DD).LT.TTYNY)GO TO 350                     !NEXT LAMBDA
!
  900   IGAM(5)=ML
!
!-----------------------------------------------------------------------
!
! There is little to be gained here due to the lesser symmetry compared
! to Slater integrals and the fact that we have a continuum pair. Also,
! for l=l' the case of N(C'C;BB)=N(BC;C'B) for Bound and Continuum needs
! a further flag so as to distinguish it from N(C'C;BB)=N(C'B;BC),
! since in the former we need C'=M2 while in the latter C'=M1 for
! distinct energies. The latter case needs its energy indexes to be
! swapped when forming H. If want to implement then see also sr.fsintx
! and sr.dwxbp.
!
! IMPOSE V(AB;CD)=V(AD;CB)
! IMPOSE N(AB;CD)=N(AD;CB)=N(CD;AB)=N(CB;AD)
! BY WAY OF FALLING ORDER - NRB
!
!        IF(BLMM)THEN                     !V
!          DO K1=1,3,2
!            IGAM(K1)=JSS(K1)
!          ENDDO
!          K11=2
!        ELSE                            !N
!          K11=1
!        ENDIF
!        DO K1=K11,2
!          IF(JSS(K1).LT.JSS(K1+2))THEN
!            KP=2
!            JP=0
!          ELSE
!            KP=0
!            JP=2
!          ENDIF
!          IGAM(K1)=JSS(K1+KP)
!          IGAM(K1+KP+JP)=JSS(K1+JP)
!        ENDDO
! so
        do j=1,4
          igam(j)=jss(j)
        enddo
!
!-----------------------------------------------------------------------
!
! STORE CONTRIBUTION TO (EXISTING) COEFFICIENT
!
        IF(BPLANT2)IPLANT=IGAM(5)                                       &
     &                    +((((IGAM(4)*MXORBC+IGAM(3))*MXORBC+IGAM(2))  &
     &                    *MXORBC)+IGAM(1))*1000
!
        DO J=NLS01,NLS
          IF(.NOT.BPLANT2)THEN
            DO I=5,1,-1                                    !1,5 SLOWER
              IF(QSSS(I,J).NE.IGAM(I))GO TO 950
            ENDDO
          ELSE
            IF(IPLANT.NE.JORIG2(J))GO TO 950
          ENDIF
          L=J
          I=IORIG2(L)
          IF(I.GT.0)THEN
            DSSS(I)=DSSS(I)+DD
            GO TO 350                                     !NEXT LAMBDA
          ENDIF
          GO TO 1000
  950   ENDDO
!
! CANNOT FIND OLD SET OF ARGUMENTS, SO START CONSTRUCTING A NEW SET
!
        L=NLS+1
        IF(L.GT.IXS2I)THEN
!
          IXXX=7*(IXS2I/5+1)
!
          WRITE(MW6,*)'*** RESX1: increasing MXS2I from ',IXS2I,' to: ',&
     &                IXXX
          WRITE(MW0,*)'*** RESX1: increasing MXS2I from ',IXS2I,' to: ',&
     &                IXXX
!
          CALL RE_ALLOC2(QSSS,IONE,IFIVE,IONE,IXS2I,IFIVE,IXXX,IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'RESX1: RE-ALLOCATION FAILS FOR QSSS'
            NF=0
            GO TO 1600
          ENDIF
!
          IXXX0=MAX(IXS2I,IAXMI)
          IXXX2=MAX(IXXX,IAXMI)
          IF(IXXX2.GT.IXXX0)CALL RE_ALLOC(IORIG2,IONE,IXXX0,IXXX2,IERR)
          CALL RE_ALLOC(JORIG2,IONE,IXS2I,IXXX,IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'RESX1: RE-ALLOCATION FAILS FOR IORIG2,JORIG2'
            NF=0
            GO TO 1600
          ENDIF
!
          IXS2I=IXXX
!
        ENDIF
!
        NLS=L
        DO I=1,5
          QSSS(I,L)=INT(IGAM(I),QP)
        ENDDO
        IF(BPLANT2)JORIG2(L)=IPLANT
!
 1000   IRSS=IRSS+1
        IF(IRSS.GT.IXS2C)THEN
!
          IXXX=7*(IXS2C/5+1)
!
          WRITE(MW6,*)'*** RESX1: increasing MXS2C from ',IXS2C,' to: ',&
     &                IXXX
          WRITE(MW0,*)'*** RESX1: increasing MXS2C from ',IXS2C,' to: ',&
     &                IXXX
!
          CALL RE_ALLOC(DSSS,IONE,IXS2C,IXXX,IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'RESX1: RE-ALLOCATION FAILS FOR DSSS'
            NF=0
            GO TO 1600
          ENDIF
!
          CALL RE_ALLOC(MSSS,IONE,IXS2C,IXXX,IERR)
          CALL RE_ALLOC(NSTJ2,IONE,IXS2C,IXXX,IERR)
          CALL RE_ALLOC(NSTJ2D,IONE,IXS2C,IXXX,IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'RESX1: RE-ALLOCATION FAILS FOR MSSS,NSTJ2'
            NF=0
            GO TO 1600
          ENDIF
!
          IXS2C=IXXX
!
        ENDIF
!
        IORIG2(L)=IRSS
        MSSS(IRSS)=L
        DSSS(IRSS)=DD
        NSTJ2(IRSS)=JC
        NSTJ2D(IRSS)=JD
!
        GO TO 350                  !NEXT LAMBDA
!
! CYCLE TO NEXT DIRECT/EXCHANGE PAIR
!
 1050   IF(KB.NE.0)THEN
          IF(KC.NE.0)GO TO 250
          KC=1
          GO TO 300
        ENDIF
        KB=1
        IF(KC.EQ.0)GO TO 300
!
! END CYCLE
!
 1100   IF(NK.EQ.1)GO TO 150       !JC=JD ONLY
!
 1200 ENDDO            !END SLATER-STATE LOOP
!
!
      IF(BLX)GO TO 1600                                          !RETURN
!
! ELIMINATE COEFFICIENTS /DSSS/.LT.TYNY AND ARGUMENTS QSSS THAT HAVE
! BEEN LISTED BEFORE IN THE REFERENCE LIST
!
 1300 ICLRR=0
      IF(IRSS.LT.IRSS0)GO TO 1600                       !RETURN, AS NONE
!
      K=IRSS0-1
      KP=0
      DO I=NLS01,NLS
        IORIG2(I)=0
      ENDDO
!
      DO I=IRSS0,IRSS
        JD0=MSSS(I)
        JD=ABS(JD0)
        IF(ABS(DSSS(I)).LT.FSTYNY)THEN
          IF(IORIG2(JD).GT.0)GO TO 1500
          JD0=0               !RE-INDEX QSSS AS MAY OCCUR LATER
          GO TO 1350
        ENDIF
        K=K+1
        DSSS(K)=DSSS(I)
        NSTJ2(K)=NSTJ2(I)
        NSTJ2D(K)=NSTJ2D(I)
!
 1350   IF(JD.LE.NLS00)THEN
          WRITE(MW6,*)'RESX1: INFORM NRB OF STOP HERE'
          WRITE(MW0,*)'RESX1: INFORM NRB OF STOP HERE'
          NF=-1
          GO TO 1600
        ENDIF
!
        IF(IORIG2(JD).EQ.0)THEN
          LP=JD-KP
          DO L=1,NLS00
            DO J=1,5
              IF(QSSS(J,JD).NE.QSSS(J,L))GO TO 1360
            ENDDO
            KP=KP+1
            IORIG2(JD)=L
            LP=L
            GO TO 1400
 1360     ENDDO
        ELSE
          LP=IORIG2(JD)
          GO TO 1400
        ENDIF
!
        IORIG2(JD)=LP
        DO J=1,5
          QSSS(J,LP)=QSSS(J,JD)
        ENDDO
!
 1400   IF(JD0.NE.0)MSSS(K)=LP
!
 1500 ENDDO
!
      NLS=NLS-KP
      IRSS=K
!
!-----------------------------------------------------------------------
!
 1600 RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION MVC(MLX,MLY)
!
      INTEGER(SP) MLX,MLY,MVC
!
      MVC=((MLX+2)*MLX/2+MLY)/2+1
!
      END FUNCTION MVC
!-----------------------------------------------------------------------
!
      END SUBROUTINE RESX1
!
!                             *******************
!
      SUBROUTINE RESX2(iam,ibm,KK)
!
!-----------------------------------------------------------------------
!
!  SR.RESX2 CALCULATES THE LEVEL-RESOLVED SPIN-SPIN, MUTUAL SPIN-ORBIT
!  AND SPIN-OTHER ORBIT INTERACTION BETWEEN PAIRS OF ELECTRONS, ONE
!  PAIR BEING CONTINUUM.
!
!  IT IS CALLED BY:
!    SR.ALGXFS
!
!  IT CALLS:
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!
!-----------------------------------------------------------------------
!
!!      COMMON /BASIC/NF,KF,KG,NJ1,NJ2,NJP1,NJP2,MGAP(5)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,NJ1=>IBSK4,NJ2=>IBSK5          &
     &              ,NJP1=>IBSK6,NJP2=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9  &
     &              ,IBSK10=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_DC,     ONLY: BFAST,DC
      USE COMMON_DMQSS3, ONLY: DSS,MSS,QSS
      USE COMMON_DMQSS3, ONLY: IRS,IRS0,NL,NL000
      USE COMMON_DMQSSS, ONLY: DSSS,MSSS,QSSS
      USE COMMON_DMQSSS, ONLY: IRSS,IRSS0,NLS,NLS00
      USE COMMON_NSTS2,  ONLY: NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2
!
      USE COMMON_NRBDW1, ONLY: MXORB,ma0,mb0
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M6)
      PARAMETER (TTYNY=10*TYNY)
      PARAMETER (FSTYNY=10*TTYNY)
!
      DIMENSION iam(*),ibm(*)
!
!-----------------------------------------------------------------------
!
      NL00=NL
!      NL1=NL00+1
!
      DO J=1,NLS
        JORIG2(J)=0
      ENDDO
!
      IRS0=IRS+1
!
      mtj2=(mtj/2)*2
!
!     BEGIN MAIN LOOP 65 OVER SLATER STATE INTERACTIONS
!
      K0=NADS2(KK-1)+1
!
      DO KS=K0,NADS2(KK)
!
        L1=NSTJ2(KS)
        m1=iam(l1)
        if(m1.eq.0)go to 100
!
        L2=NSTJ2D(KS)
!
        IF(BFAST)THEN
          DDH=DC(m1)*DC(L2+NJP2)*DSSS(KS)               !DC(L1+NJ2)
        ELSE
          m2=ibm(l2)
          if(m2.eq.0)go to 100
          DDH=DC(m1)*DC(m2)*DSSS(KS)
        ENDIF
!
        IF(ABS(DDH).LT.TYNY)GO TO 100
!
        M=MSSS(KS)
        L=JORIG2(M)
        IF(L.GT.0)THEN
          K=IORIG2(L)
          DSS(K)=DSS(K)+DDH
        ELSE
!
!     CANNOT FIND AN OLD SET OF ARGUMENTS EQUAL TO THE NEW SET, SO
!     MUST START CONSTRUCTING A NEW COEFFICIENT.
!
          L=NL+1
          IF(L.GT.IAXMI)THEN
!
            IXXX=7*(IAXMI/5+1)
!
            WRITE(MW6,*)'*** RESX2: increasing MAXMI from ',IAXMI,      &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** RESX2: increasing MAXMI from ',IAXMI,      &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC2(QSS,IONE,IFIVE,IONE,IAXMI,IFIVE,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'RESX2: RE-ALLOCATION FAILS FOR QSS'
              NF=0
              GO TO 300
            ENDIF
!
            IXXX0=MAX(IXS2I,IAXMI)
            IXXX2=MAX(IXS2I,IXXX)
            IF(IXXX2.GT.IXXX0)CALL RE_ALLOC(IORIG2,IONE,IXXX0,IXXX2,    &
     &         IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'RESX2: RE-ALLOCATION FAILS FOR IORIG2'
              NF=0
              GO TO 300
            ENDIF
!
            IAXMI=IXXX
!
          ENDIF
!
          IRS=IRS+1
          IF(IRS.GT.IXRSS)THEN
!
            IXXX=7*(IXRSS/5+1)
!
            WRITE(MW6,*)'*** RESX2: increasing MXRSS from ',IXRSS,      &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** RESX2: increasing MXRSS from ',IXRSS,      &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC(DSS,IONE,IXRSS,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'RESX2: RE-ALLOCATION FAILS FOR DSS'
              NF=0
              GO TO 300
            ENDIF
!
            CALL RE_ALLOC(MSS,IONE,IXRSS,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'RESX2: RE-ALLOCATION FAILS FOR MSS'
              NF=0
              GO TO 300
            ENDIF
!
            IXRSS=IXXX
!
          ENDIF
!
          NL=L
          DO K=1,5
            QSS(K,L)=QSSS(K,M)
          ENDDO
!
          btest1=qss(1,l).gt.mxorb.and.qss(3,l).gt.mxorb
          btest2=qss(2,l).gt.mxorb.and.qss(4,l).gt.mxorb
          if(btest1.or.btest2)then
          else
            qss(5,l)=qss(5,l)-INT(mtj2,QP)              !exchange
          endif
!
          JORIG2(M)=L
          IORIG2(L)=IRS
          MSS(IRS)=L
          DSS(IRS)=DDH
!
        ENDIF
!
  100 ENDDO
!
!     CLEAR THE ARRAY OF ZEROS AND ADJUST MSS(K) ACCORDINGLY
!
      IF(IRS.LT.IRS0)RETURN
!
      K=IRS0-1
      KP=0
      DO I=IRS0,IRS
        IF(ABS(DSS(I)).LT.FSTYNY)GO TO 250
        K=K+1
        DSS(K)=DSS(I)
        JD=INT(MSS(I),SP)
        LP=JD-KP
        DO L=1,NL00
          DO J=1,5
            IF(QSS(J,JD).NE.QSS(J,L))GO TO 150
          ENDDO
          LP=L
          GO TO 200
  150   ENDDO
        KP=KP-1
        DO J=1,5
          QSS(J,LP)=QSS(J,JD)
        ENDDO
  200   MSS(K)=LP
  250   KP=KP+1
      ENDDO
!
      NL=NL-KP
      IRS=K
!
!-----------------------------------------------------------------------
!
  300 RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE RESX2
!
!                             *******************
!
      SUBROUTINE RK1ST(X0,Y0,H,N,X1,Y1)
!
!-----------------------------------------------------------------------
!
!  SR.RK1ST INTEGRATES 1 RUNGE-KUTTA STEP WITH INITIAL VALUES X0,Y0(N).
!  RESULT X1=X+H (H=LENGTH OF STEP), Y1(N)=SOLUTION AT X1.
!  FKT(X,Y,N,Z) REPRESENTS THE SYSTEM TO BE INTEGRATED, Z(N)=
!  DERIVATIVES.
!
!  IT IS CALLED BY:
!    SR.TFDAPO
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION Y0(*),Y1(*),Y(2),A(5),Z(2)
!
!-----------------------------------------------------------------------
!
      X1=X0
      HH=H*DHALF
      A(1)=HH
      A(2)=HH
      A(5)=HH
      A(4)=H
      A(3)=H
      DO K=1,N
        Y(K)=Y0(K)
        Y1(K)=Y0(K)
      ENDDO
!
      DO I=1,4
        Z(1)=Y(2)
        Z(2)=DFOUR*X1*SQRT(Y(1)**3)+Y(2)/X1
        X1=X0+A(I)
        DO K=1,N
          Y(K)=Y0(K)+A(I)*Z(K)
          Y1(K)=Y1(K)+A(I+1)*Z(K)/DTHREE
        ENDDO
      ENDDO
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE RK1ST
!
!                             *******************
!
      SUBROUTINE RK4PI(ICOUNT,N,M80,FR,GR,TM)
!
!-----------------------------------------------------------------------
!
!  SR.RK4PI CALCULATES MULTIPOLE PHOTOIONIZATION INTEGRALS INVOLVING
!  CONTINUUM FUNCTIONS (ORBITAL N) AT THE ICOUNT'TH INTERPOLATION ENERGY
!  INDEXED BY M8.
!
!  IT IS CALLED BY:
!    SR.RADCON
!
!  IT CALLS:
!    FN.SBESS
!    FN.SBESSP
!    SR.ASSX
!    SR.ASS2X
!    SR.DIFF
!    SR.DIPOL
!    SR.FILONW
!    SR.WEDDLE
!
!  IT CONTAINS:
!    FN.ICOL
!    FN.DPOL1
!    FN.DPOL2
!
!-----------------------------------------------------------------------
!
      USE COMMON_ALGEB,  ONLY: BFOT
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL2, ONLY: MDEL,MXORBR,MPOL00,MPOL0,MPOLE,MPOLX,CODE
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBDR,  ONLY: IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR
      USE COMMON_NRBDR,  ONLY: LNEW,LCON,LSUM,LMAX,lcmin,BLOOP
      USE COMMON_NRBINT, ONLY: DRLI,DYY,IYY,NRLI,MENG,NREL,NLAG,NLAGP   &
     &                        ,BLAG,BBC2
      USE COMMON_NRBPOT, ONLY: DERV
      USE COMMON_NRBPOT, ONLY: ALFD,RCUT,ALAV,RCAV,IPOLFN
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBRN2, ONLY: BINDB,MENGB
      USE COMMON_NRBSHF, ONLY: DSHIFT,MSHIFT,KSHIFT,MKMAX,MXEP
      USE COMMON_NRBTS1, ONLY: DFOT,DFOSS,PMIN,NFOSS,IPIG,IGAG,IXD24
      USE COMMON_NRBVAL, ONLY: FACT,IVAL,NNEW,NNOLD,BJUMP,BJUMP2,BRAD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (D8M4=8*D1M4)
      PARAMETER (D4M5=4*D1M5)
!
      DIMENSION FR(*),GR(*)
!
      ALLOCATABLE :: DA(:),DP(:)
!
      DIMENSION CP(100),CM(100),JDUM(100)
!
      DATA BWARN/.TRUE./
!
!-----------------------------------------------------------------------
!      ICOL(ILI,ILF,IONE1)=((ILF-1)*(ILF-2*IONE1))/2+ILI
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!      DPOL1(X)=(DONE-EXP(-(X/RCAV)**3))/X**3
!      DPOL2(X)=DONE/((X*X+RCAV*RCAV)*SQRT(X*X+RCAV*RCAV))
!-----------------------------------------------------------------------
!
      PI=ACOS(-DONE)
      PIH=PI/DTWO
!
! SET RETARDATION
!
      JSWTCH=1
!      brtard=irtard.ne.0                          !only for brel=.true.
      BREL2=ABS(IREL).EQ.2
!
      if(brel2.and.irtard.ne.0)then
!       iswtch=1   !use Grant (1974) integrals - need to set kappa below
        iswtch=0            !use continuity form, e.g. for kappa average
!       iswtch=-1             !ditto, but test use of filon, length only
      else
        iswtch=0                                               !not used
      endif
!
! INITIALIZE
!
      IPOLF2=IPOLFN/10
      MXRM=MAXRS-1
!
      DRY=DYY(ICOUNT)*DTWO
!
      DD=DZERO
      DZA=MION-NZION-1
!
      P100=DONE
      IF(NNEW.GE.NSW)P100=D100
!
      IF(PMIN.GT.DZERO)THEN                         !DETERMINE SAFE IPIG
        L=LNEW
        IF(L.LT.0)L=NNEW-1
        LP=L+1
        DE=DZA/NNEW
        DE=DE*DE+DRY
        E2=DRY/(DZA*DZA)
!
        CALL DIPOL(IONE,NNEW,IZERO,E2,LP,CP,CM,JDUM)
!
        TL=L+L
        TLP=LP+LP
        T=TLP*CP(LP)*D1P10**JDUM(LP)
        IF(L.GT.0)T=T+TL*CM(L)*D1P10**JDUM(L)
        T=T*DE/DZA**4
        IPIG=1
        IF(T.LT.PMIN*P100)THEN                      !LENGTH FAILURE
          IPIG=0
!          write(mw6,*)'switch to velocity, icount=',icount
          IF(T.LT.PMIN*P100/D1P6)THEN               !VELOCITY FAILURE
            IF(BREL)THEN
              IF(BWARN.and.irtard.eq.0)THEN
                WRITE(MW6,10010)DYY(ICOUNT-1)/D1PT05
                WRITE(MW0,10020)DYY(ICOUNT-1)/D1PT05
                BWARN=.FALSE.
              ENDIF
!ABORT      WRITE(MW0,*)'ERROR: CANNOT USE ACC GAUGE FOR PI IN ICR MODE'
!ABORT      GO TO 999                               !RETURN
            ELSE
              IPIG=-1
!              write(mw6,*)'switch to acceleration, icount=',icount
              IF(T.LT.PMIN*P100/(D1P6*D1P6))THEN    !ACC. FAILURE (WARN)
                IF(NNEW.GE.NSW)WRITE(MW6,*)                             &
     &                                'PI ACCELERATION MAYBE INACCURATE'
              ENDIF
            ENDIF
          ENDIF
        ENDIF
        IGAG(ICOUNT)=IPIG
!        write(mw0,*)icount,ipig,t,pmin
      ENDIF
!
      IF(ICOUNT.EQ.NREL)RETURN                    !WAS JUST TO GET GAUGE
!
!-----------------------------------------------------------------------
!
! LOCAL
      ALLOCATE(DA(MAXRS),DP(MAXRS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RK4PI: ALLOCATION FAILS FOR DA,DP'
        NF=0
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
      DA(MAXRS)=DZERO
      IF(IPIG.EQ.0)CALL DIFF(FR,DA,MNH,DHNS,MJH)    !VELOCITY
!
      IF(IPIG.LT.0)DAX=DZERO                        !ACCELERATION
      IF(IPIG.EQ.0)DAX=D8M4*(DONE-DZA)**2           !VELOCITY
      IF(IPIG.GT.0)DAX=D4M5*(DONE-DZA)**2           !LENGTH
!
! BEGIN INNER ORBITAL LOOP
!
      DO J=1,N
!
        IF(DEY(J).EQ.DZERO)GO TO 200
        IF(BJUMP.AND.IVAL(J).EQ.0)GO TO 200
        IF(IYY(J).GT.0.AND.MODE.LE.2)GO TO 200
        IF(J.GE.MA.AND.J.LE.MB)GO TO 200                        !MA0,MB0
!OLD        IF((QL(J)-QL(N))**2.NE.4)GO TO 332      !DIPOLE ONLY
!
        IN=ICOL(J,N,IZERO)
        LM=ABS(QL(N)-QL(J))/2
        m=max(lm,mpol00/2)
        if(mod(m,itwo).ne.mod(lm,itwo))m=m+1
        mm=m-2
        if(mpol00.gt.0.and.mm.le.mpole/2)then
          if(bindb(in,mm/2))m=mm                           !allow for mk
          if(m.lt.0)m=m+2
        endif
        IF(M.GT.MPOLE/2)GO TO 200
        MM=M
!          M0=M
        LL=(QL(N)+QL(J))/2
        LP=MIN(LL,MPOLE/2)
!p2         if(brel)lp=lp+2                         !for retardation
!p2         if(lp.eq.0.and.igagr.gt.0)lp=2
        if(lp.eq.0)go to 200                        !none (no Born here)
        if(mm.gt.lp)go to 200
!
        brtard=irtard.ne.0.and.qn(j).gt.0         !off for ryd/cont-cont
   50   IF(.NOT.BINDB(IN,mm/2))then
!          write(mw0,*)'No algebra for PI?',j,n,mm
!            m=m+2
          mm=mm+2
          if(mm.le.lp)go to 50
          GO TO 200
        ENDIF
        btest=mm.gt.mkmax.or.icount.gt.mxep
        if(qn(j).lt.0.and.btest)go to 200             !rest upscaled
!
        INJ=ICOL(J,J,IZERO)
        DE=DEY(J)-DUY(INJ)-DRY*DHALF                  !A.U.
        IF(BREL)THEN
          mp=mm+1
          TE=ABS(DE*DFSC)
          TJ=DONE/TE**mm
          do i=1,mm
            tj=tj*(2*i+1)
          enddo
        ENDIF
        if(mm.eq.0)then                             !skip e0, go to m1
          dd=0
          rem=0
          go to 150
        endif
!
        MN=0
        IF(IPIG.GT.0)MN=mm                            !LENGTH
        IF(IPIG.LT.0)MN=-2                            !ACCELERATION
        IF(QN(J).LT.0.AND.DRY.LE.DAX)MN=-2            !DITTO
        if(mn.eq.-2.and.mm.ne.1)then                  !no acc non-dipole
          mn=0                                        !velocity fallback
          ipig0=0
          if(da(maxrs).eq.dzero)call diff(fr,da,mnh,dhns,mjh)
!          if(qn(j).gt.0)then                         !or zero-out...
!            ist=1
!          else
!            ist=2
!          endif
!          rem=dzero
!          dd=d1m75
!          go to 339
        else
          ipig0=ipig
        endif
!
        IF(MN.EQ.0)THEN                               !VELOCITY
!
          if(ipig0.ne.0)stop 'rk4pi: velocity?'   !not really needed now
          IAP=1
          MN=-1
          dll=((ql(n)/2+1)*ql(n)-(ql(j)/2+1)*ql(j))/2
          mmm=mm-1
          IF(BREL.and.brtard)THEN
            IF(BREL2)THEN
              T=-2*DE*TJ/(2*mm+1)
! ORIGINAL GRANT (1974) WITH KAPPA DEPENDENCE - sync with fcf6/radial
! do *not* use with kappa average.
              if(iswtch.gt.0)then
                tk1=-1
                     !ql(n)/2                  !continuum kappa
                tk2=-1                         !bound s-orbital
                DO I=1,MAXRS
                  TFQ=FR(I)*DQNL(I,J)
                  TGP=GR(I)*DPNL(I,J)
                  TZ=DX(I)*TE
                  TB0=SBESS(mmm,TZ,JSWTCH)
                  TB2=SBESS(mp,TZ,JSWTCH)
                  DP(I)=-(TFQ-TGP)*(TB0+TB2)*mm
                  DP(I)=DP(I)+(tk1-tk2)*(TFQ+TGP)*(TB0-TB2*mm/mp)
                  DP(I)=DP(I)*T
                ENDDO
              elseif(iswtch.eq.0)then
! FOR KAPPA-AVERAGE: USES CONTINUITY TO REMOVE EXPLICIT KAPPA-DEPENDENCE
! AS SUCH IT DIFFERS ONLY TRIVIALLY (A BESSEL RECURRENCE) FROM LENGTH
! kappa dependent gives same answer as above (if continuity satisfied)
                DO I=1,MAXRS
                  TZ=DX(I)*TE
                  TB0=SBESS(mmm,TZ,JSWTCH)
                  TB2=SBESS(mp,TZ,JSWTCH)
                  DP(I)=(DPNL(I,J)*FR(I)+DQNL(I,J)*GR(I))               &
     &                  *TZ*(TB0-TB2*mm/mp)
                  tb1=sbess(mm,tz,jswtch)
                  DP(I)=DP(I)-(FR(I)*DQNL(I,J)-GR(I)*DPNL(I,J))         &
     &                  *tz*tb1*(mm+mp)/mp
                  DP(I)=DP(I)*T
                ENDDO
              else
                write(mw0,*)                                            &
     &                     "Filon's method not coded for Velocity gauge"
                go to 300
              endif
            ELSE
              CALL DIFF(DPNL(1,J),DP,MNH,DHNS,MJH)
              DO I=1,MAXRS
                TZ=DX(I)*TE
                DP(I)=FR(I)*DPNL(I,J)*DLL*SBESS(mm,TZ,JSWTCH)/DX(I)     &
     &                **2+(DA(I)*DPNL(I,J)-FR(I)*DP(I))                 &
     &                *SBESSP(mm,TZ,JSWTCH)*te
                dp(i)=dp(i)*tj
              ENDDO
            ENDIF
          ELSE
            mmm=mm-1
            IF(BREL2.and.qn(j).gt.0)THEN
              T=mm*2/DFSC
              DO I=1,MAXRS
                DP(I)=((FR(I)*DPNL(I,J)+GR(I)*DQNL(I,J))*DLL/DX(I)      &
     &                -(FR(I)*DQNL(I,J)-GR(I)*DPNL(I,J))*T)*dx(i)**mmm
              ENDDO
            ELSE
              ddll=dll+mmm*mm
              DO I=1,MAXRS
                DP(I)=(FR(I)*dDLL/DX(I)+DA(I)*mm*2)*DPNL(I,J)*dx(i)**mmm
              ENDDO
            ENDIF
          ENDIF
!
        ELSE                                        !LENGTH/ACCELERATION
!
          mmm=0
          IAP=0
          DO I=1,MAXRS
            DP(I)=DPNL(I,J)*FR(I)
          ENDDO
          IF(BREL2)THEN
            DO I=1,MAXRS
              DP(I)=DP(I)+DQNL(I,J)*GR(I)
            ENDDO
          ENDIF
          IF(MN.EQ.-2)THEN                                 !ACCELERATION
            DO I=1,MAXRS
              DP(I)=-DP(I)*DERV(I)
            ENDDO
          ELSE                                                   !LENGTH
            if(mn.ne.mm)stop 'rk4pi: length?'
            IF(BREL.and.brtard)THEN
              IF(BREL2)THEN
! ORIGINAL GRANT (1974) WITH KAPPA DEPENDENCE - sync with fcf6/radial
! do *not* use with kappa average.
                if(iswtch.gt.0)then
                  tk1=-1
                       !ql(n)/2                !continuum kappa
                  tk2=-1                       !bound s-orbital
                  DO I=1,MAXRS
                    TFQ=FR(I)*DQNL(I,J)
                    TGP=GR(I)*DPNL(I,J)
                    TZ=DX(I)*TE
                    tb1=sbess(mm,tz,jswtch)
                    DP(I)=DP(I)*tb1
                    TB2=SBESS(mp,TZ,JSWTCH)
                    DP(I)=DP(I)-(TFQ-TGP)*TB2
                    DP(I)=DP(I)-(tk1-tk2)*(TFQ+TGP)*TB2/mp
                    dp(i)=dp(i)*tj
                  ENDDO
                elseif(iswtch.eq.0)then
! FOR KAPPA-AVERAGE: USES CONTINUITY TO REMOVE EXPLICIT KAPPA-DEPENDENCE
! kappa dependent gives same answer as above (if continuity satisfied)
                  DO I=1,MAXRS
                    TZ=DX(I)*TE
                    TB2=SBESS(mp,TZ,JSWTCH)
                    tb1=sbess(mm,tz,jswtch)
                    DP(I)=DP(I)*(tb1-TZ*TB2/mp)
                    DP(I)=DP(I)-(FR(I)*DQNL(I,J)-GR(I)*DPNL(I,J))       &
     &                    *tz*tb1/mp
                    dp(i)=dp(i)*tj
                  ENDDO
                else
! test use of filon's method, not really an issue here since we have a
! grid set-up to describe continuum, unlike bound-bound case, only when
! te.gt.k-momentum does j_l oscillate more rapidly viz 75,000 Ryd.
                  DO I=1,MAXRS
                    TZ=DX(I)*TE
                    TB2=1
                        !SBESS(mp,TZ,JSWTCH)
                    DP(I)=DP(I)*(-TZ*TB2/mp)
                                           !*tj
                  ENDDO
!                call weddle(dzero,dp,fb2,mnh,dhns,mjh,maxrs)
                  call filonw(mp,te,dx,mnh,dhns,mjh,maxrs,dp,fb2,dum)
                  DO I=1,MAXRS
                    TZ=DX(I)*TE
                    tb1=1
                        !sbess(mm,tz,jswtch)
                    DP(I)=DPNL(I,J)*FR(I)+DQNL(I,J)*GR(I)
                    DP(I)=DP(I)*tb1-(FR(I)*DQNL(I,J)-GR(I)*DPNL(I,J))   &
     &                    *tz*tb1/mp
!                  dp(i)=dp(i)*tj
                  ENDDO
!                call weddle(dzero,dp,fb1,mnh,dhns,mjh,maxrs)
                  call filonw(mm,te,dx,mnh,dhns,mjh,maxrs,dp,fb1,dum)
                  fb1=fb1*tj
                  fb2=fb2*tj
                  dd=fb1+fb2
!              write(mw6,*)fb1,fb2,dd,te
                  go to 100
                endif
              ELSE
                DO I=1,MAXRS
                  TZ=DX(I)*TE
                  DP(I)=DP(I)*TJ*SBESS(mm,TZ,JSWTCH)
                ENDDO
              ENDIF
            ELSE
              DO I=1,MAXRS
                DP(I)=DP(I)*DX(I)**mm
              ENDDO
            ENDIF
! ADD-IN 2-BODY POL
            IF(IPOLF2.GT.0.AND.mm.eq.1)THEN       !ipolf2.ge.0 gives v24
              IF(IPOLF2.le.1)THEN               !.le.1 allows v24 result
                DO I=1,MAXRS
                  DP(I)=DP(I)*(DONE-ALAV*DPOL1(DX(I)))
                ENDDO
              ELSEIF(IPOLF2.EQ.2)THEN
                DO I=1,MAXRS
                  DP(I)=DP(I)*(DONE-ALAV*DPOL2(DX(I)))
                ENDDO
              ELSE
                STOP 'SR.RK4PI: HERE BE MONSTERS'
              ENDIF
            ENDIF
          ENDIF
!
        ENDIF
!
!
        CALL WEDDLE(DZERO,DP,DD,MNH,DHNS,MJH,MAXRS)
!
  100   continue
!
! LONG-RANGE INTEGRAL F*G*X**MN (VEL ALSO FP*G) CASE RYD APPROX BY CONT
!
        REM=DZERO
        IST=1
        IF(QN(J).GT.0)GO TO 150
        IST=2
!
        DX1=DX(MAXRS)
        DT=DX(MAXRS)-DX(MXRM)
        ML1=QL(N)/2
        DS=ML1*(ML1+1)
        ML2=QL(J)/2
        DC=ML2*(ML2+1)
        DNORM=-QN(J)
        DNORM=DNORM-SCREEN(J)
        TN=DZA/DNORM
        TN=TN*TN
        DNORM=TN/(PIH*DNORM)
        DNORM=SQRT(DNORM)
        TN=SCREEN(J)
!
        DO IAA=0,IAP
          MN=MN+IAA
          nm=mn+mmm
          F0=FR(MXRM)
          F1=FR(MAXRS)
          G0=DPNL(MXRM,J)
          G1=DPNL(MAXRS,J)
          IF(IAA.EQ.0)THEN
            CALL ASS2X(DX1,DT,DX2,F0,F1,G0,G1,DRY,DZERO,DS,DC,DZERO,    &
     &                 DZERO,DZERO,DZERO,DZA,nm,REM2)
            TMP=TM
!test            rem00=0.                                         !ctest
          ELSE             !VEL: F=A*SIN(B), SO FP=A*BP*COS(B)+ap*sin(b)
            P0=DA(MXRM)
            P1=DA(MAXRS)
            CALL ASS2PX(DX1,DT,DX2,F0,F1,P0,P1,G0,G1,DRY,DZERO,DS,DC,   &
     &                  DZERO,DZERO,DZERO,DZERO,DZA,nm,REM2)
!
!test contribution from ap*sin(b)
!test            rem00=0.
!test            call assx(dx2,nm-2,tm,tn,dry,dzero,dza,ml1,ml2,ds,dc
!test     x                ,dzero,dzero,dzero,dzero,rem00)
!test            rem00=-rem00*dnorm*dza/(dtwo*dry)
!
!test contribution from a*(z/k)*cos(b)/r
!test            rem00=0.
!test            call assx(dx2,nm-1,tm+dhalf,tn,dry,dzero,dza,ml1,ml2,ds
!test     x               ,dc,dzero,dzero,dzero,dzero,rem00)
!test            rem00=-rem00*dnorm*dza/sqrt(dry)
!
            TE=DRY
            TZ=DZA
            IF(BREL)THEN
              TZ=TZ+DHALF*DALF*TZ*TE
              TE=TE+DQUART*DALF*TE*TE
            ENDIF
            PNORM=SQRT(TE)*(done-tz/(te*dx2))       !approx z/r contrib.
            DNORM=DNORM*PNORM                       !NORM*DP
            TMP=TM+DHALF                            !AS ASSX EXPECTS SIN
          ENDIF
!
          REM0=DZERO
!
          CALL ASSX(DX2,nm,TMP,TN,DRY,DZERO,DZA,ML1,ML2,DS,DC,DZERO,    &
     &              DZERO,DZERO,DZERO,REM0)
!
          REM0=REM0*DNORM                           !+rem00       !ctest
!
!          if(iaa.gt.0)then
!            f1=p1
!            f1=f1/pnorm                            !as dry.ne.0 here
!            g1=g1*pnorm
!          endif
!          if(fnorm.ne.dzero)f1=f1/fnorm
!          if(gnorm.ne.dzero)g1=g1/(gnorm*dnorm)
!!
!          write(mw6,*)'*** ',mn,rem2,rem0,f1,g1,dx1,dx2
!
          REM0=REM2+REM0
          IF(MN.EQ.-1)REM0=REM0*dDLL              !dDLL <- dDDL typo
          IF(MN.EQ.0)REM0=REM0*2*mm
          REM=REM+REM0
        ENDDO
!
        IF(MN.EQ.-2)THEN
          REM=-REM*DZA                            !BFOT=.TRUE. HERE
          DE=DONE
        ELSE
          DE=-DHALF*DRY
!WORSE DE=-0.5*(DRY+DSHIFT(J))
        ENDIF
!
! FIND STORE POINTER
!
  150   M8=NFOSS(mm/2,N,J)
        IF(M8.LE.0)THEN
          M80=M80+1
          IF(M80.GT.IXD24)GO TO 200               !MXD24
          M8=M80
          NFOSS(mm/2,N,J)=M8
        ENDIF
!
!        write(mw6,*)m8,j,n,mm,icount,ist,mn,dd,rem,dd+rem,tm,tn
!
        DD=DD+REM
        IF(MN.EQ.-2)DD=DD/DE**2                   !ACC
        IF(MN.EQ.-1.OR.MN.EQ.0)DD=-DD/(2*DE)      !VEL
!
        IF(IST.EQ.1)DFOSS(M8,ICOUNT,1)=DD
        DD=DD*DE**2                               !FOR INTERP
        DFOSS(M8,ICOUNT,2)=DD                     !& for kshift=0 mxep
!
! MAGNETIC
!
        IF(MPOLE.gt.2.and.qn(j).gt.0)THEN         !explicit mk upscaled
          IF(BREL2)THEN
            M8=NFOSS(mm/2,J,N)
            IF(M8.LE.0)THEN
              M80=M80+1
              IF(M80.GT.IXD24)GO TO 200           !MXD24
              M8=M80
              NFOSS(mm/2,J,N)=M8
            ENDIF
!            mp=mm+1
            T=-2/(DFSC*(mp+2))
            IF(brtard)THEN
              T=T*TJ*(2*mp+1)/TE
              DO I=1,MAXRS
                TZ=DX(I)*TE
                TB2=SBESS(mp,TZ,JSWTCH)
                DP(I)=(FR(I)*DQNL(I,J)+GR(I)*DPNL(I,J))*TB2
              ENDDO
            ELSE
              DO I=1,MAXRS
                DP(I)=(FR(I)*DQNL(I,J)+GR(I)*DPNL(I,J))*DX(I)**mp
              ENDDO
            ENDIF
!
            CALL WEDDLE(DZERO,DP,DD,MNH,DHNS,MJH,MAXRS)
!
            DD=DD*T
!            DD=DD+REM
            IF(IST.EQ.1)DFOSS(M8,ICOUNT,1)=DD
            DD=DD*DE**2                           !FOR INTERP
            DFOSS(M8,ICOUNT,2)=DD                 !& for kshift=0 mxep
          ELSE                                    !USE ELECTRIC
            NFOSS(mm/2,J,N)=M8
          ENDIF
        ENDIF
!
!        m=m+2
        mm=mm+2
        if(mm.le.lp)go to 50                     !to next multipole
!
  200 ENDDO                                      !END INNER ORBITAL LOOP
!
!-----------------------------------------------------------------------
!
! LOCAL
      DEALLOCATE(DA,DP,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RK4PI: DE-ALLOCATION FAILS FOR DA,DP'
        NF=0
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
  300 CONTINUE
      M80=-1                                     !FLAG ABORT
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(//'*** SR.RK4PI: ERROR, CANNOT USE ACC GAUGE FOR PI IN',   &
     &       ' ICR MODE, REDUCE EMAX (RYD) TO:',F6.0/4X,                &
     &       'CONTINUING WITH VELOCITY GAUGE, AT YOUR OWN RISK -',      &
     &       ' NO MORE WARNINGS!'/)
10020 FORMAT(/'*** STRONG WARNING: VEL GAUGE LIKELY INACCURATE ***'/,   &
     &       '   (NO ACC GAUGE FOR ICR MODE) YOU ARE ADVISED TO REDUCE',&
     &       ' EMAX(RYD) TO:',F6.0/4X,'PROCEED AT YOUR OWN RISK -',     &
     &       ' NO MORE WARNINGS!'/)
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!-----------------------------------------------------------------------
      FUNCTION DPOL1(X)
!
      REAL(WP) X,DPOL1
!
      DPOL1=(DONE-EXP(-(X/RCAV)**3))/X**3
!
      END FUNCTION DPOL1
!-----------------------------------------------------------------------
      FUNCTION DPOL2(X)
!
      REAL(WP) X,DPOL2
!
      DPOL2=DONE/((X*X+RCAV*RCAV)*SQRT(X*X+RCAV*RCAV))
!
      END FUNCTION DPOL2
!-----------------------------------------------------------------------
!
      END SUBROUTINE RK4PI
!
!                             *******************
!
      SUBROUTINE RKINT(BPRNT0)
!
!-----------------------------------------------------------------------
!
!  SR.RKINT CALCULATES R^K RADIATIVE MULTIPOLE INTEGRALS FOR BOUND-BOUND
!  AND BOUND-FREE TRANSITIONS.
!  OPTIONALLY, CALCULATES FINITE AND/OR INFINITE ENERGY BORN INTEGRALS.
!
!  LENGTH IN LOWER TRIANGLE OF DOSC, VELOCITY IN UPPER.
!  ACCELERATION STORED IN ACC (USES NZION/R FOR THE POTENTIAL).
!
!  IT IS CALLED BY:
!    SR.CARATE
!    SR.DIAGON
!
!  IT CALLS:
!    SR.ASSX
!    SR.ASS2X
!    SR.BORN
!    SR.DIFF
!    FN.SBESS
!    FN.SBESSP
!    SR.WEDDLE
!
!  IT CONTAINS:
!    FN.ICOL
!    FN.DPOL1
!    FN.DPOL2
!
!-----------------------------------------------------------------------
!
      USE COMMON_ALGEB,  ONLY: BFOT
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CACC,   ONLY: ACC
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_INTS,   ONLY: DRL,DOSC,IGAUGE,IXD09,IXD28,IXD29
      USE COMMON_MQVC,   ONLY: NEL,KMAX
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      use common_misc,   only: iw,iwp,btime,btimex
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL2, ONLY: MDEL,MXORBR,MPOL00,MPOL0,MPOLE,MPOLX,CODE
      USE COMMON_NRBAL2, ONLY: MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBDR,  ONLY: IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR
      USE COMMON_NRBINT, ONLY: DRLI,DYY,IYY,NRLI,MENG,NREL,NLAG,NLAGP   &
     &                        ,BLAG,BBC2
      USE COMMON_NRBORN, ONLY: BL,OBO,TM2
      USE COMMON_NRBRN1, ONLY: SBL,DBL                                  &
     &                        ,MB3,MB4,INDX,INDL,INDK,IXD33
      USE COMMON_NRBRN2, ONLY: BINDB,MENGB
      USE COMMON_NRBRN3, ONLY: V0,V1,MV0,MV1,MINFB,MXNXV,MXD21          &
     &                        ,NLAGB,NPDEC,IVV0
      USE COMMON_NRBOLP, ONLY: OVLPGR,OVLPCF,IPAIR
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX                     &
     &                        ,MXBORB,MXVORB,MXFORB,NGRP
      USE COMMON_NRBPOT, ONLY: DERV
      USE COMMON_NRBPOT, ONLY: ALFD,RCUT,ALAV,RCAV,IPOLFN
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBSHF, ONLY: DSHIFT,MSHIFT,KSHIFT,MKMAX,MXEP
      USE COMMON_NRBTS1, ONLY: DFOT,DFOSS,PMIN,NFOSS,IPIG,IGAG
      USE COMMON_NRBVAL, ONLY: FACT,IVAL,NNEW,NNOLD,BJUMP,BJUMP2,BRAD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (PIH=1.5707963_WP)              !HISTORIC, TO BE REMOVED
!
      PARAMETER (DBIG=100)
      PARAMETER (D8M4=8*D1M4)
      PARAMETER (D4M5=4*D1M5)
!
      CHARACTER(LEN=3) PIG
!
      ALLOCATABLE :: LIMR(:),IHAR(:),DDY(:)                       !LOCAL
!
      ALLOCATABLE :: DPA(:),DP(:),TEMP(:)
!
      DIMENSION VV(MXNXV)                        !/NRBRN3/ NOT ALLOCATED
!
      save icore                                        !as in alloc now
!
!-----------------------------------------------------------------------
!      ICOL(ILI,ILF,IONE1)=((ILF-1)*(ILF-2*IONE1))/2+ILI
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!      DPOL1(X)=(DONE-EXP(-(X/RCAV)**3))/X**3
!      DPOL2(X)=DONE/((X*X+RCAV*RCAV)*SQRT(X*X+RCAV*RCAV))
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!
! THE NAMES HERE ARE NOT NECESSARILY SIGNIFICANT THEY ARE COMMON LEGACY.
!
! LOCAL
      ALLOCATE(DPA(MAXRS),DP(MAXRS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RKINT: ALLOCATION FAILS FOR DPA,DP'
        NF=0
        RETURN
      ENDIF
!
      IF(BPRNT0)THEN
        ALLOCATE(TEMP(MXORB),STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'RKINT: ALLOCATION FAILS FOR TEMP'
          NF=0
          RETURN
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
      BACC=ALLOCATED(ACC)
      BVEL=IXD29.EQ.IXD28*2
!
!-----------------------------------------------------------------------
!
      PI=ACOS(-DONE)
!      PIH=PI/DTWO                                 !AS USED ELSEWHERE...
!
! INITIALIZE LOGICALS
!
!      brtard=irtard.ne.0                          !only for brel=.true.
      BREL2=ABS(IREL).EQ.2
      BBORN=MENGB.GE.0
      BFOTJ=.NOT.BFOT.OR..NOT.BLAG
      IF(.NOT.BFOTJ.AND.PMIN.GT.DZERO)IPIG=1
      BORT=MORT.LT.0
!
! SET RETARDATION
!
      JSWTCH=1
!
! SET CHARGES ETC.
!
      NZA=NZION-MION+1
      DZA=-NZA
      DZM=-NZION
      MXRM=MAXRS-1
      mxmm=0
!
! INITIALIZE FOR PI
!
! (WE HAVE NO TEST FOR GAUGE HERE.
!  DEFAULT NREL=1 AND LENGTH.
!  IF USER SETS NREL TOO LARGE THEN SHOULD USE VEL/ACC.
!  ATTEMPT TO IMPROVE-ON DEFAULT BY CHECKING IGAGR FROM RK4PI.)
!
      PIG='   '
      IF(BFOT)THEN
!        write(mw0,*)pig,(igag(i),i=1,meng)
        PIG='VAR'
        IF(IPIG.LT.0)THEN                        !ACCELERATION
          PIG='ACC'
        ELSEIF(IPIG.EQ.0)THEN                    !VELOCITY
          PIG='VEL'
        ELSEIF(IPIG.GT.0)THEN                    !LENGTH
          IF(PMIN.LT.DZERO)PIG='LEN'             !OR VARIABLE
        ENDIF
        IF(BLAG)IPIG=IGAG(NREL)         !DO NOT SET NREL 4PI TOO LARGE
        IF(IPIG.LT.0.AND.PIG.EQ.'VAR')THEN       !FALLBACK TO VELOCITY
!          IF(BREL.OR.MPOLE.GT.2)IPIG=0           !NOW E_K DEPENDENT
        ENDIF
        IF(IPIG.LT.0)DAX=DZERO                   !ACCELERATION
        IF(IPIG.EQ.0)DAX=D8M4*(DONE-DZA)**2      !VELOCITY
        IF(IPIG.GT.0)DAX=D4M5*(DONE-DZA)**2      !LENGTH
!        write(mw0,*)pig,ipig,(igag(i),i=1,meng)
        NAX=0
        IF(BLAG)THEN
          ALLOCATE(DDY(MENG))
          DO I=1,MENG
            IF(DYY(I).LT.DAX)NAX=I
          ENDDO
          NAX=NAX+1
        ELSE
          ALLOCATE(DDY(1))
          DDY(1)=DONE
        ENDIF
      ENDIF
!
      IPIG0=IPIG
!
! INITIALIZE FOR NLAG-POINT LAGRANGE INTERPOLATION FORMULA FOR
!  BOUND-CONTINUUM INTEGRALS.
!  NLAG MUST BE AN EVEN NUMBER .GE. 2 . READ IN SRADCON.
!  DEFAULT:   NLAG=6.
!
!      NLAGP2=NLAGP-2
      NP1=1
      NP2=MAX(IONE,NLAGP)
      NPH=NP2/2
!      BBC1=MENG.LE.NP2
!      IF(BBC1)NP2=MENG
!
! INITIALIZE NLAGB-POINT LAGRANGE INTERPOLATION FORMULA FOR
!  BORN INTEGRALS.
!  NLAGB MUST BE AN EVEN NUMBER, DEFAULT:   NLAGB=4.
!  NPDEC DETERMINES THE NODES AND IS THE NUMBER OF INTERVALS PER
!  DECADE (OF MOMENTUM TRANSFER), DEFAULT: NPDEC=4.
!  THUS, THE VALUES OF NLAGB AND NPDEC ARE INTERTWINED.
!
      IF(MENGB.EQ.0)THEN               !FINITE ENERGY BORN
        MV0=MXD21
        MV1=MXNXV                      !K-SHELL
        IF(MA.EQ.1)THEN                !NO K-SHELL                  !MA0
          MV0=MV0-1
          MV1=MV1-NPDEC
        ENDIF
        IF(NLAGB.GT.MV0)THEN
          WRITE(MW6,*)'NOT ENOUGH K-VALUES FOR MOM. TRANSF. INTERP',MV0,&
     &                NLAGB
          WRITE(MW0,*)'NOT ENOUGH K-VALUES FOR MOM. TRANSF. INTERP'
          GO TO 500
        ENDIF
        DELTA=DONE/NPDEC
        DELTA=10**DELTA
        VV(2)=10**IVV0
        VV(2)=DONE/VV(2)
        MV11=MV1-1
        DO I=3,MV11
          VV(I)=VV(I-1)*DELTA
        ENDDO
        VV(1)=VV(2)/2                 !FIRST POINT
        VV(MV1)=10*VV(MV11)           !INFINITE ENERGY POINT
        MINFB=MV11
        DO I=1,MV1
          V1(I)=VV(I)*NZA
        ENDDO
        DO I=1,MV0
          V0(I)=VV(I)*NZA
          MENGB=MENGB+MV1-I
        ENDDO
      ELSEIF(MENGB.EQ.1)THEN          !INFINITE ENERGY BORN ONLY
        MINFB=1
        V0(1)=DZERO
        V1(1)=DBIG*NZA
      ELSE
        MINFB=1
      ENDIF
!
! INITIALIZE FOR BORN
!
      IF(BBORN)THEN
!
        IF(BPRNT0)THEN
          IF(MENGB.GT.1)THEN
            WRITE(MW6,10060)MV0,MV1,(I,V1(I),I=1,MV1)
            WRITE(MW6,10070)((I,J,J=I+1,MV1),I=1,MV0)
          ENDIF
          WRITE(MW6,10040)
        ENDIF
!
! arguably should be in minim_alloc now, but dimension set-up is messy
!
        if(.not.allocated(bl))then            !case bound-bound ryd loop
!
          if(kutls.le.0)then                    !identify effective core
            icore=0
            do k=1,kmax
              isum=0
              do i=mxorb,1,-1
                isum=isum+nel(i,k)
                if(isum.gt.1)then
                  icore=max(icore,i)
                  go to 10
                endif
              enddo
   10       enddo
!          write(mw0,*)'icore=',icore
          endif
!
! DETERMINE (CLOSE TO?) ACTUAL USAGE
!
          IXD33=0
          IXD34=0
!
          NC=0                            !FIRST DETERMINE IXD33
          DO K=1,MXORB                    !*****BEGIN OUTER ORBITAL LOOP
            IF(DEY(K).NE.DZERO)THEN
              DO J=1,K                      !***BEGIN INNER ORBITAL LOOP
                IF(DEY(J).EQ.DZERO)GO TO 15
                IF(QN(J).LT.0.AND.QN(K).LT.0)GO TO 15       !CONT-CONT
                IF(NSL0.LT.0.AND.J.EQ.K)GO TO 15            !CA
                IF(NW.GT.0)THEN
                  IF(IEQ(J).LE.NNL(NW,1))GO TO 15           !CLOSEDSHELL
                ENDIF
                LL=(QL(K)+QL(J))/2
                LP=MIN(LL,MPOLE/2)
                if(mod(ll,itwo).ne.mod(lp,itwo))lp=lp-1
                IF(BREL)LP=LP+2                       !.and.irtard.eq.0?
                IF(MENGB.EQ.1.AND.LP.EQ.1)GO TO 15
                NC=NC+1
   15         ENDDO
            ENDIF
          ENDDO
!
!          write(mw0,*)'nc=',nc
          IXD33=NC
!
! ALLOCATE MB3,MB4
!
          ALLOCATE(MB3(0:IXD33),MB4(0:IXD33),STAT=IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'RKINT: ALLOCATION FAILS FOR BORN DIMEN MB3,MB4'
            NF=0
            GO TO 400
          ENDIF
!
          N1=1                            !N1=NC FOR CA
          NC=0
          N=0                             !NOW DETERMINE IXD34
          btest=.false.
!
          DO K=1,MXORB                    !*****BEGIN OUTER ORBITAL LOOP
            IF(DEY(K).NE.DZERO)THEN
              DO J=1,K                      !***BEGIN INNER ORBITAL LOOP
                IF(DEY(J).EQ.DZERO)GO TO 20
                IF(QN(J).LT.0.AND.QN(K).LT.0)GO TO 20       !CONT-CONT
                IF(NSL0.LT.0.AND.J.EQ.K)GO TO 20            !CA
                IF(NW.GT.0)THEN
                  IF(IEQ(J).LE.NNL(NW,1))GO TO 20           !CLOSEDSHELL
                ENDIF
!
                LL=(QL(K)+QL(J))/2
                LP=MIN(LL,MPOLE/2)
                if(mod(ll,itwo).ne.mod(lp,itwo))lp=lp-1
                IF(BREL)LP=LP+2                       !.and.irtard.eq.0?
                IF(MENGB.EQ.1.AND.LP.EQ.1)GO TO 20
!
                NC=NC+1
                MB4(NC)=J
                MB3(NC)=K                   !NOT USED BY CARATE
!
                IN=ICOL(J,K,IZERO)
!
                LM=ABS(QL(K)-QL(J))/2
                m=max(lm,mpol00/2)
                if(mod(m,itwo).ne.mod(lm,itwo))m=m+1
                lm=m                                      !hold for Born
                JP=MOD(LM,ITWO)
!
                LL=(QL(K)+QL(J))/2
                LP=MIN(LL,MPOLE/2)
                if(mod(ll,itwo).ne.mod(lp,itwo))lp=lp-1
                IF(BREL)LP=LP+2                       !.and.irtard.eq.0?
                IF(LP.EQ.0.AND.IGAGR.GT.0)LP=2
!
                if(kutls.le.0)then  !mix within a cf only restricts poss
                  if(j.ne.k)then
                    n1=nc
                    btest=.false.
                  else
                    n1=1
                    btest=.true.
                  endif
                endif
                IF(NSL0.LT.0)N1=NC                          !CA
!
                DO ND=N1,NC
                  L=MB3(ND)
                  I=MB4(ND)
                  IF(QN(L).LT.0.AND.QN(I).LT.0)GO TO 16     !CONT-CONT
                  if(btest)then     !mix within a cf only restricts poss
                    if(l.ne.i)then
                      go to 16
                    else
                      if(i.lt.j.and.i.gt.icore)go to 16
                    endif
                  endif
                  KM=ABS(QL(L)-QL(I))/2
                  IP=MOD(KM,ITWO)
                  IF(IP.EQ.JP)THEN
                    KP=(QL(L)+QL(I))/2
                    KM=MAX(KM,LM)
                    IF(MENGB.EQ.1.AND.KM.EQ.1)KM=KM+2       !SKIP DIPOLE
                    KP=MIN(KP,LP)
                    IF(KM.LE.KP)THEN
                      IM=ICOL(I,L,IZERO)
                      DO KAM=KM,KP,2
                        LAM=KAM                !SUPPRESS "UNDEF" WARNING
                        LH=LAM/2
                        IF(BINDB(IN,LH).AND.BINDB(IM,LH))THEN    !NEEDED
                          N=N+1
                          GO TO 16
                        ENDIF
                      ENDDO
                    ENDIF
                  ENDIF
   16           ENDDO
   20         ENDDO
            ENDIF
          ENDDO
!
!      write(mw0,*)'n(b)=',n
!      deallocate(mb3,mb4,stat=ierr)
!
          IXD34=N
!
! MAXIMAL USAGE GREATLY OVERESTIMATES RELAXED CASE, ESPECIALLY RLX
!
          if(ixd33*ixd34.eq.0)then
            mb0=mb
!p            ngrp=1
            if(irlx.lt.0)then
              mb0=0
!p              ngrp=-irlx/100000         !until /nrborb/ in a module
!pc            mxborb=-irlx-100000*ngrp         !not used in sr.rkint
            endif
!
!p            MXVORB=MXORB-MB0*ngrp
            IF(NSL0.GT.0)THEN
              IXD33=(MXVORB*(MXVORB+1))/2
              IXD34=((IXD33+1)*IXD33)/2       !MAXIMAL FOR FULL CI
              if(kutls.le.0)then
                IXD34=2*IXD33     !MIX WITHIN CF MAY NEED INCREASE
              endif
            ELSE                              !CA
              IXD33=(MXVORB*(MXVORB-1))/2
              IXD34=IXD33
            ENDIF
          endif
!
! END MAXIMAL USAGE
!
          IF(MENGB.EQ.1)THEN                  !INF
            IXD38=1
          ELSE
            IXD38=(MXNXV*(MXNXV-1))/2-((MXNXV-MXD21)*(MXNXV-1-MXD21))/2
          ENDIF
!
          LHM=MPOLE/4
!
          ALLOCATE(BL(IXD38,IXD34,0:LHM),OBO(IXD38),TM2(IXD34),         &
     &             STAT=IERR)
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'RKINT: ALLOCATION FAILS FOR BORN'
            NF=0
            GO TO 400
          ENDIF
!
          IF(.NOT.ALLOCATED(MB3))THEN
            ALLOCATE(MB3(0:IXD33),MB4(0:IXD33),STAT=IERR)
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'RKINT: ALLOCATION FAILS FOR BORN MB3, MB4'
              NF=0
              GO TO 400
            ENDIF
          ENDIF
!
          IF(NSL0.GT.0)THEN
            JXD33=IXD33
          ELSE                                !CA
            JXD33=1
          ENDIF
!
          ALLOCATE(SBL(JXD33),INDX(IXD28),INDK(IXD34),INDL(IXD34),      &
     &             STAT=IERR)
!                             ,DBL(IXD33,MXBIF) - SET IN DIAGON/DIAGFS
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'RKINT: ALLOCATION FAILS FOR BORN1'
            NF=0
            GO TO 400
          ENDIF
!
        endif                                       !end skip allocation
!
        iflagb=0                     !counter for born numerical failure
!                                     !BORN INDEX
        N=0                           !WATCH THIS
        NC=0
        MB3(0)=0
!        tt=-done                                  !for logging run only
        DO J=0,LHM
          DO I=1,IXD34
            DO K=1,MENGB
              BL(K,I,J)=DZERO
!              obo(k)=done                         !for logging run only
            ENDDO
          ENDDO
        ENDDO
!
      ENDIF
!
      ALLOCATE(LIMR(MXORB),IHAR(MXORB))                           !LOCAL
!
      N1=1                            !N1=NC FOR CA
      IPOLF2=IPOLFN/10
      btest=.false.
!
      DO K=1,MXORB                        !*****BEGIN OUTER ORBITAL LOOP
!
        IHAR(K)=10000
        IF(DEY(K).EQ.DZERO)GO TO 50
!       IF(K.LE.ABS(MPSEUD))GO TO 825
        IF(.NOT.BJUMP2)THEN
          DO I=1,MAXRS
            DPA(I)=DPNL(I,K)
            IF(ABS(DPA(I)).GT.D1M6)LIMR(K)=I
          ENDDO
          CALL DIFF(DPA,DP,MNH,DHNS,MJH)
        ENDIF
        IHAR(K)=QL(K)/2
        KLAST=K
        INK=ICOL(K,K,IZERO)
!
   50   DO J=1,K                            !***BEGIN INNER ORBITAL LOOP
!
          IF(DEY(J)*DEY(K).EQ.DZERO)GO TO 350
!         IF(J.LE.ABS(MPSEUD))GO TO 350         !IBID
          M=IVAL(K)+IVAL(J)
          IF(BJUMP.AND.M.EQ.0)GO TO 350
!
! DETERMINE MULTIPOLE RANGE
!
          IF(.NOT.BREL.AND.IGAGR.LT.0.AND..NOT.BBORN.AND.QL(K)+QL(J)    &
     &       .EQ.0)GO TO 350                                !827
!
          INJ=ICOL(J,J,IZERO)
          IN=ICOL(J,K,IZERO)
          INV=IXD28+IN
!
          LM=ABS(QL(K)-QL(J))/2
          m=max(lm,mpol00/2)
          if(mod(m,itwo).ne.mod(lm,itwo))m=m+1
          lm=m                                            !hold for Born
          mm=m-2
          if(mpol00.gt.0.and.mm.le.mpole/2)then
            if(bindb(in,mm/2))m=mm                         !allow for mk
            if(m.lt.0)m=m+2
          endif
          IF(M.eq.0.and..not.bborn.and..not.brel2)M=2       !.and.j.eq.k
          IF(M.GT.MPOLE/2)GO TO 350                         !827
          MM=M
          M0=M
          LL=(QL(K)+QL(J))/2
          LP=MIN(LL,MPOLE/2)
          if(mod(ll,itwo).ne.mod(lp,itwo))lp=lp-1
          IF(BREL.and.irtard.gt.0)LP=LP+2
          IF(LP.EQ.0.AND.IGAGR.GT.0)LP=2
!
          IF(BJUMP2)THEN
!
            TM=FACT(K)*FACT(J)
            IF(BACC)ACC(IN)=TM*ACC(IN)
!
            m8=0
            if(mod(ll,itwo).ne.mod(lp,itwo))lp=lp-1  !align to reach m0!
            do m=lp,m0,-2                   !loop high to low, for mxe1!
              DOSC(IN,m/2)=TM*DOSC(IN,m/2)
              IF(BVEL)DOSC(INV,m/2)=TM*DOSC(INV,m/2)
              if(bfot)m8=nfoss(m/2,k,j)
              if(m8.gt.0)then
                if(m.gt.mkmax.or.m.eq.0)then               !all upscaled
                  mxe1=1
                else
                  mxe1=mxep+1
                endif
                do ist=1,2                   !=2 for mxe boundary interp
                  do i=mxe1,meng
                    dfoss(m8,i,ist)=tm*dfoss(m8,i,ist)
                  enddo
                enddo
                do i=1,mxe1-1
                  dfoss(m8,i,2)=tm*dfoss(m8,i,2)
                enddo
                m80=nfoss(m/2,j,k)
                if(m8*m80.ne.m80*m80)then                  !for magnetic
                  do i=1,meng
                    dfoss(m80,i,1)=tm*dfoss(m80,i,1)       !all upscaled
                  enddo
                endif
              endif
            enddo
!
            IF(BFOTJ)GO TO 350
            IF(IYY(J).GT.0.OR.IYY(K).LT.0)GO TO 350             !NOT B-F
            if(mxe1.eq.1)go to 350              !upscale (only) no shift
            lp0=lp
            mm=m0
            GO TO 280
!
          ENDIF
!
! INITIALIZE DOSC TO ZERO
!
          IF(.NOT.BJUMP)THEN
            DO I=0,IXD09
              DOSC(IN,I)=DZERO
              IF(BVEL)DOSC(INV,I)=DZERO
            ENDDO
            IF(BACC)ACC(IN)=DZERO
          ENDIF
!
          DD=DZERO
          DB=DZERO
!
          OVL=DONE
          IF(IRLX.EQ.2)THEN    !OVERLAPS
            KF=IGRCF(J)
            KG=IGRCF(K)
            IF(KF.NE.KG.AND.KF*KG.GT.0)THEN
              K1=MIN(KF,KG)
              K2=MAX(KF,KG)
              KK=((K2-1)*(K2-2))/2+K1
              IF(IPAIR(KK).EQ.1)OVL=OVLPCF(KK)
            ENDIF
          ENDIF
!
! BORN
!
          IF(.NOT.BBORN)GO TO 80
!
          IF(QN(J).LT.0.AND.QN(K).LT.0)GO TO 80             !CONT-CONT
!
          IF(MENGB.EQ.1.AND.LP.EQ.1)GO TO 80                !DIPOLE
          IF(NSL0.LT.0.AND.J.EQ.K)GO TO 80                  !CA
          IF(NW.GT.0)THEN
            IF(IEQ(J).LE.NNL(NW,1))GO TO 80                 !CLOSEDSHELL
          ENDIF
!
          IF(2*LL.GT.MPOLE.AND.NMULTE.GT.100)WRITE(MW6,10050)MPOLE/2
!
          NC=NC+1
          IF(NC.GT.IXD33)GO TO 80
          MB4(NC)=J
          MB3(NC)=K                         !NOT USED BY CARATE
!          IN=ICOL(J,K,IZERO)
          INDX(IN)=NC
          JP=MOD(LM,ITWO)
!
          if(kutls.le.0)then        !mix within a cf only restricts poss
            if(j.ne.k)then
              n1=nc
              btest=.false.
            else
              n1=1
              btest=.true.
            endif
          endif
          IF(NSL0.LT.0)N1=NC                                !CA
!
          DO ND=N1,NC
            L=MB3(ND)
            I=MB4(ND)
            IF(QN(L).LT.0.AND.QN(I).LT.0)GO TO 60           !CONT-CONT
            if(btest)then           !mix within a cf only restricts poss
              if(l.ne.i)then
                go to 60
              else
                if(i.lt.j.and.i.gt.icore)go to 60
              endif
            endif
            KM=ABS(QL(L)-QL(I))/2
            IP=MOD(KM,ITWO)
            IF(IP.EQ.JP)THEN
              KP=(QL(L)+QL(I))/2
              KM=MAX(KM,LM)
              IF(MENGB.EQ.1.AND.KM.EQ.1)KM=KM+2             !SKIP DIPOLE
              KP=MIN(KP,LP)
              IF(KM.LE.KP)THEN
                N0=N
                IM=ICOL(I,L,IZERO)
                iflagbb=0
                DO KAM=KM,KP,2
                  LAM=KAM                      !SUPPRESS "DEDEF" WARNING
                  LH=LAM/2
                  IF(BINDB(IN,LH).AND.BINDB(IM,LH))THEN     !NEEDED
                    N0=N+1
                    if(iflagbb.gt.0)then        !as will evntly overflow
                      iflagb=iflagb+1
                      go to 52
                    endif
!
                    CALL BORN(LAM,K,J,L,I,IHAR,LIMR,MENGB,MV0,MV1,V0,V1,&
     &                        OBO,OINT,TT)
!
                    IF(LAM.LT.0)GO TO 500                   !FAILURE
                    IF(LAM.EQ.1)TM2(N0)=TT
                    if(lam.gt.km+4)then
                      btest1=obo(mengb).ge.bl(mengb,n0,lh-1)
                      btest2=obo(mengb).le.dzero
                      if(btest1.or.btest2)then              !inacc
                        iflagb=iflagb+1
                        iflagbb=iflagbb+1
!                        do ie=1,mengb
!                          obo(ie)=dzero
!                        enddo
                        go to 52
                      endif
                    endif
                    DO IE=1,MENGB
                      BL(IE,N0,LH)=OBO(IE)
                    ENDDO
   52               IF(BPRNT0)WRITE(MW6,10010)N0,NC,K,J,L,I,2*LAM,      &
     &                              (BL(IE,N0,LH),IE=1,MENGB)
!           call flush(mw6)
                  ENDIF
                ENDDO
                IF(N0.EQ.N+1)THEN
                  N=N+1
                  if(n.gt.ixd34)then
                    if(kutls.gt.0)then                        !shouldn't
                      write(mw6,*)'born index error,ixd34',n,ixd34
                      write(mw0,*)'born index error,ixd34',n,ixd34
                    else
! can't re-alloc BL(:,:,:) but don't want to inflate wrt CA, so tweak
                      write(mw6,*)                                      &
     &                           'need to increase ixd34 for kutle le 0'
                      write(mw0,*)                                      &
     &                           'need to increase ixd34 for kutle le 0'
                    endif
                    go to 500
                  endif
                  INDL(N)=NC
                  INDK(N)=ND
                ENDIF
              ENDIF
            ENDIF
   60     ENDDO
          IF(QL(K)+QL(J).EQ.0.AND.IGAGR.LT.0)GO TO 350      !827
!                                           .AND.NOT.BREL
! FIND LOWEST ALLOWED MULTIPOLE
!
   80     CONTINUE
!          IN=ICOL(J,K,IZERO)
!
!          write(mw6,*)in,j,k,m,bindb(in,m/2)
  100     IF(.NOT.BINDB(IN,M/2))THEN
            M=M+2
            MM=M
            M0=M
            IF(MM.LE.LP)GO TO 100
            GO TO 350                                       !NONE EXIST
          ENDIF
!
          mp0=m                                             !for m1
          if(m.eq.0)then                                    !for born
            M=M+2
            IF(M.GT.LP)then
              if(brel2)go to 180                            !for m1
              GO TO 350
!            IF(.NOT.BINDB(IN,M/2))GO TO 828
            ENDIF
            MM=M
            M0=M
          endif
!
! MODE .LE. 2  SET CONTINUUM-CONTINUUM TO ZERO
!
          IF(MODE.LE.2.AND.QN(J).LT.0.AND.QN(K).LT.0)GO TO 220
!
! BEGIN MULTIPOLE LOOP
!
! LENGTH
!
  120     BPOL=IPOLF2.GT.0.AND.MM.EQ.1     !ipolf2.ge.0 gives v24 result
!t          m2=mm/2
!t          m1=mod(mm,itwo)
          IF(BREL2)THEN
            DO I=1,MAXRS
              DPA(I)=DPNL(I,K)*DPNL(I,J)+DQNL(I,K)*DQNL(I,J)
              DPA(I)=DPA(I)*DX(I)**MM
            ENDDO
          ELSE
            DO I=1,MAXRS
!t              t1=dx(i)**m2
!t              t2=t1
!t              if(m1.gt.0)t2=t2*dx(i)
!t              DPA(I)=(DPNL(I,K)*t1)*(DPNL(I,J)*t2)
              DPA(I)=DPNL(I,K)*DPNL(I,J)*DX(I)**MM
            ENDDO
          ENDIF
          IF(BPOL)THEN
            if(IPOLF2.le.1)THEN       !.le.1 allows v24 result, if(bpol)
              DO I=1,MAXRS
                DPA(I)=DPA(I)*(DONE-ALAV*DPOL1(DX(I)))
              ENDDO
            ELSEIF(IPOLF2.EQ.2)THEN
              DO I=1,MAXRS
                DPA(I)=DPA(I)*(DONE-ALAV*DPOL2(DX(I)))
              ENDDO
            ELSE
              STOP 'SR.RKINT: HERE BE MONSTERS - 1'
            ENDIF
          ENDIF
!
          CALL WEDDLE(DZERO,DPA,DB,MNH,DHNS,MJH,MAXRS)
!
          DB=DB*OVL
!
!      del=dey(j)-duy(inj)-(dey(k)-duy(ink))  !test use of orb ener a.u.
          IF(MM.GT.0)THEN
!            write(mw0,*)in,j,k,mm,db
!!            if(mm.le.lp)
!            write(mw6,*)in,j,k,mm,bindb(in,mm/2)
            DOSC(IN,MM/2)=DB
            MM=MM+2
!            IF(MM.LE.LP.AND.BINDB(IN,MM/2))GO TO 842
            IF(MM.LE.LP)THEN                       !FOR STUPID COMPILERS
              IF(BINDB(IN,MM/2))GO TO 120             !TO NEXT MULTIPOLE
            ENDIF
          ELSE
!        db=db/del**2                         !test use of orb ener a.u.
            IF(BACC)ACC(IN)=-DB*DZM
            GO TO 140
          ENDIF
!
! ACCELERATION (DIPOLE ONLY)
!
          IF(BACC)ACC(IN)=DZERO
          IF(M.LT.2)THEN
            MM=-2
            IF(.NOT.BFOT)GO TO 120
            IF(BACC)THEN
              IF(BREL2)THEN
                DO I=1,MAXRS
                  DPA(I)=DPNL(I,K)*DPNL(I,J)+DQNL(I,K)*DQNL(I,J)*DERV(I)
                ENDDO
              ELSE
                DO I=1,MAXRS
                  DPA(I)=DPNL(I,K)*DPNL(I,J)*DERV(I)
                ENDDO
              ENDIF
!
              CALL WEDDLE(DZERO,DPA,DB,MNH,DHNS,MJH,MAXRS)
!
              DB=-DB*OVL
              ACC(IN)=DB
            ENDIF
          ENDIF
!
! VELOCITY
!
  140     MM=M
!
! BEGIN MULTIPOLE LOOP
!
  160     IF(BVEL)THEN
            MMM=MM-1
            D2=(IHAR(K)+1)*IHAR(K)-(IHAR(J)+1)*IHAR(J)
            IF(BREL2)THEN
              T=MM*2/DFSC
              DO I=1,MAXRS
                DPA(I)=((DPNL(I,K)*DPNL(I,J)+DQNL(I,K)*DQNL(I,J))       &
     &                 *D2/DX(I)                                        &
     &                 -(DPNL(I,K)*DQNL(I,J)-DQNL(I,K)*DPNL(I,J))*T)    &
     &                 *DX(I)**MMM
              ENDDO
            ELSE
              DD2=D2+MMM*MM
              DO I=1,MAXRS
                DPA(I)=(DPNL(I,K)*DD2/DX(I)+DP(I)*MM*2)*DPNL(I,J)*DX(I) &
     &                 **MMM
              ENDDO
            ENDIF
!
            CALL WEDDLE(DZERO,DPA,DC,MNH,DHNS,MJH,MAXRS)
!
            DC=DC*OVL
!      dc=-dc/(del*2)                        !test use of orb ener a.u.
!
            DOSC(INV,MM/2)=DC
          ELSE
            DC=DZERO
          ENDIF
!
          MM=MM+2
!          IF(MM.LE.LP.AND.BINDB(IN,MM/2))GO TO 741
          IF(MM.LE.LP)THEN                         !FOR STUPID COMPILERS
            IF(BINDB(IN,MM/2))GO TO 160               !TO NEXT MULTIPOLE
          ENDIF
!
! PHOTOIONIZATION
!     (OPTIONALLY, TEST FULL RETARDATION ON B-B)
!
  180     CONTINUE
!
          IF(IYY(K).GT.0)THEN
            DEL=DEY(J)-DUY(INJ)-DYY(NREL)                          !A.U.
          ELSE
            DEL=DEY(J)-DUY(INJ)-DEY(K)+DUY(INK)                    !A.U.
          ENDIF
!
          m=mp0
          M0=M
          MM=M
  200     IPIG=IPIG0
          M8=0
          IF(BFOT)M8=NFOSS(mm/2,K,J)
          IF(M8.GT.0.or.irtard.lt.0.and.qn(j).ne.qn(k))THEN
            IF(IRLX.EQ.2.and.m8.gt.0)THEN
              DO I=1,MENG
                DFOSS(M8,I,1)=DFOSS(M8,I,1)*OVL               !FOR RK4PI
              ENDDO
              M80=NFOSS(mm/2,J,K)
              IF(M8*M80.NE.M80*M80)THEN                    !FOR MAGNETIC
                DO I=1,MENG
                  DFOSS(M80,I,1)=DFOSS(M80,I,1)*OVL           !FOR RK4PI
                ENDDO
              ENDIF
            ENDIF
!
            brtard=irtard.ne.0.and.qn(j).gt.0
!                                                    ALWAYS DO PI LENGTH
            IF(BREL.and.brtard.and.mm.le.ixd09)THEN
              MP=MM+1
              TE=abs(DFSC*DEL)
              TJ=1/TE**MM
              DO I=1,MM
                TJ=TJ*(2*I+1)
              ENDDO
              if(mm.eq.0)go to 210               !m.eq.0 !as no electric
!
              IF(BREL2)THEN
! ORIGINAL GRANT (1974) WITH KAPPA DEPENDENCE - sync with fcf6/radial
! do *not* use with kappa average.
                tk1=ql(k)/2                 !continuum kappa
                tk2=-1                         !bound s-orbital
                DO I=1,-MAXRS
                  TPQ=DPNL(I,K)*DQNL(I,J)
                  TQP=DQNL(I,K)*DPNL(I,J)
                  TZ=DX(I)*TE
                  TB1=SBESS(MM,TZ,JSWTCH)
                  DPA(I)=(DPNL(I,K)*DPNL(I,J)+DQNL(I,K)*DQNL(I,J))*tb1
                  TB2=SBESS(MP,TZ,JSWTCH)
                  DPA(I)=DPA(I)-(TPQ-TQP)*TB2
                  DPA(I)=DPA(I)-(tk1-tk2)*(TPQ+TQP)*TB2/MP
                  DPA(I)=DPA(I)*TJ
                ENDDO
! FOR KAPPA-AVERAGE: USES CONTINUITY TO REMOVE EXPLICIT KAPPA-DEPENDENCE
! kappa dependent gives same answer as above.
                DO I=1,MAXRS
                  TZ=DX(I)*TE
                  TB2=SBESS(MP,TZ,JSWTCH)
                  TB1=SBESS(MM,TZ,JSWTCH)
                  DPA(I)=(DPNL(I,K)*DPNL(I,J)+DQNL(I,K)*DQNL(I,J))      &
     &                   *(TB1-TZ*TB2/MP)
                  DPA(I)=DPA(I)-(DPNL(I,K)*DQNL(I,J)-DQNL(I,K)*DPNL(I,J)&
     &                   )*TZ*TB1/MP
                  DPA(I)=DPA(I)*TJ
                ENDDO
              ELSE
                DO I=1,MAXRS
                  TZ=DX(I)*TE
                  DPA(I)=DPNL(I,K)*DPNL(I,J)*TJ*SBESS(MM,TZ,JSWTCH)
                ENDDO
              ENDIF
              IF(BPOL)THEN
                if(IPOLF2.le.1)THEN   !.le.1 allows v24 result, if(bpol)
                  DO I=1,MAXRS
                    DPA(I)=DPA(I)*(DONE-ALAV*DPOL1(DX(I)))
                  ENDDO
                ELSEIF(IPOLF2.EQ.2)THEN
                  DO I=1,MAXRS
                    DPA(I)=DPA(I)*(DONE-ALAV*DPOL2(DX(I)))
                  ENDDO
                ELSE
                  STOP 'SR.RKINT: HERE BE MONSTERS - 2'
                ENDIF
              ENDIF
!
              CALL WEDDLE(DZERO,DPA,DD,MNH,DHNS,MJH,MAXRS)
!
              DD=DD*OVL
              DOSC(IN,MM/2)=DD
            else
              if(brel.and.brtard)then
                mxmm=max(mxmm,mm/2)
                go to 350
              endif
              dd=dosc(in,mm/2)
            ENDIF
!
            IF(IPIG.gt.0.and.m8.gt.0)THEN                        !LENGTH
              DFOSS(M8,NREL,1)=DD
              DFOSS(M8,NREL,2)=DD*DEL**2     !for kshift=0 mxep boundary
            ENDIF
!
            IF(IPIG.LT.0)THEN                              !ACCELERATION
              IF(BREL)THEN
                IF(PIG.NE.'VAR')THEN
                  WRITE(MW6,*)'***SR.RKINT: ERROR, ACC GAUGE NOT CODED',&
     &                        ' FOR PI WITH RELATIVISTIC ORBITALS'
                  WRITE(MW0,*)'***SR.RKINT: ERROR, ACC GAUGE NOT CODED',&
     &                        ' FOR PI WITH RELATIVISTIC ORBITALS'
                  GO TO 500
                ELSE
                  IPIG=0                              !VELOCITY FALLBACK
                ENDIF
              ENDIF
              if(mm.gt.1)then
                IF(PIG.NE.'VAR')THEN
                  write(mw6,*)'***sr.rkint: error, acc gauge is for ',  &
     &                        'dipole pi only'
                  write(mw0,*)'***sr.rkint: error, acc gauge is for ',  &
     &                        'dipole pi only'
                  go to 500
                ELSE
                  IPIG=0                              !VELOCITY FALLBACK
                ENDIF
              endif
              T=-DONE
              IF(.NOT.BFOT)THEN
                IP=K
                IF(.NOT.BORT)IP=QL(K)/2+1
                IF(DADJUS(IP).LT.DZERO)T=DZA !not if use orb ener. above
                IF(DADJUS(IP).GE.DZERO)T=DZM !not if use orb ener. above
              ENDIF
!              DEL=DEY(J)-DUY(INJ)-DYY(NREL) !not if use orb ener. above
              IF(BACC.AND.M8.GT.0)THEN
                DB=ACC(IN)
                DB=-DB*T/DEL**2              !not if use orb ener. above
                DFOSS(M8,NREL,1)=DB
                DFOSS(M8,NREL,2)=DB*DEL**2   !for kshift=0 mxep boundary
              ENDIF
            ENDIF
!
            IF(IPIG.EQ.0)THEN                                  !VELOCITY
              IF(BREL.and.brtard)THEN
                IF(BREL2)THEN
                  MMM=MM-1
                  T=-2*DEL*TJ/(2*MM+1)
! ORIGINAL GRANT (1974) WITH KAPPA DEPENDENCE - sync with fcf6/radial
! do *not* use with kappa average.
                  tk1=ql(k)/2               !continuum kappa
                  tk2=-1                       !bound s-orbital
                  DO I=1,-MAXRS
                    TPQ=DPNL(I,K)*DQNL(I,J)
                    TQP=DQNL(I,K)*DPNL(I,J)
                    TZ=DX(I)*TE
                    TB0=SBESS(MMM,TZ,JSWTCH)
                    TB2=SBESS(MP,TZ,JSWTCH)
                    DPA(I)=-(TPQ-TQP)*(TB0+TB2)*MM
                    DPA(I)=DPA(I)+(tk1-tk2)*(TPQ+TQP)*(TB0-TB2*MM/MP)
                    DPA(I)=DPA(I)*T
                  ENDDO
! FOR KAPPA-AVERAGE: USES CONTINUITY TO REMOVE EXPLICIT KAPPA-DEPENDENCE
! AS SUCH IT DIFFERS ONLY TRIVIALLY (A BESSEL RECURRENCE) FROM LENGTH
! kappa dependent gives same answer as above.
                  DO I=1,MAXRS
                    TZ=DX(I)*TE
                    TB0=SBESS(MMM,TZ,JSWTCH)
                    TB2=SBESS(MP,TZ,JSWTCH)
                    DPA(I)=(DPNL(I,J)*DPNL(I,K)+DQNL(I,J)*DQNL(I,K))    &
     &                     *TZ*(TB0-TB2*MM/MP)
                    TB1=SBESS(MM,TZ,JSWTCH)
                    DPA(I)=-(DPNL(I,K)*DQNL(I,J)-DQNL(I,K)*DPNL(I,J))   &
     &                     *TZ*TB1*(MM+MP)/MP+DPA(I)
                    DPA(I)=DPA(I)*T
                  ENDDO
                ELSE
                  DD2=(IHAR(K)+1)*IHAR(K)-(IHAR(J)+1)*IHAR(J)
                  CALL DIFF(DPNL(1,J),DPA,MNH,DHNS,MJH)
                  DO I=1,MAXRS
                    TZ=DX(I)*TE
                    DPA(I)=DPNL(I,J)*DPNL(I,K)*DD2*SBESS(MM,TZ,JSWTCH)  &
     &                     /DX(I)**2+(DP(I)*DPNL(I,J)-DPNL(I,K)*DPA(I)) &
     &                     *SBESSP(MM,TZ,JSWTCH)*TE
                    DPA(I)=DPA(I)*TJ
                  ENDDO
                ENDIF
!
                CALL WEDDLE(DZERO,DPA,DC,MNH,DHNS,MJH,MAXRS)
!
                DOSC(INV,MM/2)=DC
              ELSE
                DC=DOSC(INV,MM/2)
              ENDIF
!              DEL=DEY(J)-DUY(INJ)-DYY(NREL)!not if use orb ener. above
              if(m8.gt.0)then
                T=-DC/(DEL*2)               !=dc if use orb. ener. above
                DFOSS(M8,NREL,1)=T
                DFOSS(M8,NREL,2)=T*DEL**2    !for kshift=0 mxep boundary
              endif
            ENDIF
!
  210       IF(MPOLE.GT.2.AND.BREL2)THEN         !WE (MAY) NEED MAGNETIC
              M80=NFOSS(mm/2,J,K)
              IF(M80.GT.0)THEN
                mp=mm+1
                T=-2/(DFSC*(mp+2))
                IF(brtard)THEN
                  T=T*TJ*(2*mp+1)/TE
                  DO I=1,MAXRS
                    TZ=DX(I)*TE
                    TB2=SBESS(mp,TZ,JSWTCH)
                    DPA(I)=(DPNL(I,K)*DQNL(I,J)+DQNL(I,K)*DPNL(I,J))*TB2
                  ENDDO
                ELSE
                  DO I=1,MAXRS
                    DPA(I)=(DPNL(I,K)*DQNL(I,J)+DQNL(I,K)*DPNL(I,J))    &
     &                     *DX(I)**mp
                  ENDDO
                ENDIF
!
                CALL WEDDLE(DZERO,DPA,DD,MNH,DHNS,MJH,MAXRS)
!
                DD=DD*T
                DFOSS(M80,NREL,1)=DD
                DFOSS(M80,NREL,2)=DD*DEL**2  !kshift=0 mxep bndry unused
              ENDIF
            ENDIF
!
! increment multipole
            mm=mm+2
            bpol=.false.                               !as must be first
!            if(mm.le.lp.and.bindb(in,mm/2))then
            if(mm.le.lp)then                       !for stupid compilers
              if(bindb(in,mm/2))go to 200
            endif
!
          ENDIF
          GO TO 350
!
! CASE OF RYDBERG APPROX BY ZERO-ENERGY CONTINUUM
! (NO RETARDATION, SO NEED NREL "SMALL")
!
  220     IF(.NOT.BFOT)GO TO 350
          IF(IYY(J).GT.0.OR.IYY(K).LT.0)GO TO 350
          IF(BACC)ACC(IN)=DZERO                              !DON'T USE
          lp0=lp                                        !sigh...
!          if(kshift.eq.0)then      !always need for magnetic
          tm=nnew
          tm=tm-screen(j)           !can use, as we do have q.d. here
          tn=nnold
          tn=tn-screen(j)           !can use, as we do have q.d. here
          factj=(tn/tm)**3
          factj=sqrt(factj)
!          endif
!
  240     if(mm.gt.mkmax.or.mm.eq.0)then                   !all upscaled
            mxe1=1
          else
            mxe1=mxep+1
          endif
          m8=nfoss(mm/2,k,j)
          if(m8.gt.0)then
            do ist=1,2                       !=2 for mxe boundary interp
              do i=mxe1,meng
                dfoss(m8,i,ist)=factj*dfoss(m8,i,ist)
              enddo
            enddo
            m80=nfoss(mm/2,j,k)
            if(m8*m80.ne.m80*m80)then                      !for magnetic
              do i=1,meng
                dfoss(m80,i,1)=factj*dfoss(m80,i,1)        !all upscaled
              enddo
            endif
          endif
          if(nrel.ge.mxe1)then
            dosc(in,mm/2)=factj*dosc(in,mm/2)
            dosc(inv,mm/2)=factj*dosc(inv,mm/2)
            if(mm.gt.mkmax)go to 320                    !quick/safe exit
            go to 280
          endif
!
          MN=0
          IF(IPIG.GT.0)MN=mm                            !LENGTH
          IF(IPIG.LT.0.OR.DYY(NREL).LE.DAX)then         !ACCELERATION
            MN=-2
            if(mm.ne.1)then                             !zero non-dipole
              rem=dzero
              dd=d1m75
              go to 260
            endif
          ENDIF
          IF(IPIG.EQ.0.AND.MN.EQ.0)THEN                 !VELOCITY
            WRITE(MW6,10080)NREL
            WRITE(MW0,*)'REDUCE NREL FOR FREE-FREE PI VELOCITY GAUGE'
            GO TO 500
!            MN=-1
!            DLL=MAX(QL(J),QL(K))*(QL(K)-QL(J))/2
!            DO I=1,MAXRS
!              DPA(I)=(DPNL(I,K)*DLL/DX(I)+DP(I)*2)*DPNL(I,J)
!            ENDDO
          ELSE                                      !LENGTH/ACCELERATION
            DO I=1,MAXRS
              DPA(I)=DPNL(I,K)*DPNL(I,J)
            ENDDO
            IF(BREL2)THEN
              DO I=1,MAXRS
                DPA(I)=DPA(I)+DQNL(I,K)*DQNL(I,J)
              ENDDO
            ENDIF
            IF(MN.EQ.-2.AND.BFOT)THEN               !ACCELERATION
              DO I=1,MAXRS
                DPA(I)=-DPA(I)*DERV(I)
              ENDDO
            ELSE
              IF(MN.EQ.1.AND.ALAV*RCAV.NE.DZERO)THEN      !2-BODY POL
                IF(IPOLF2.EQ.1)THEN
                  DO I=1,MAXRS
                    DPA(I)=DPA(I)*(DONE-ALAV*DPOL1(DX(I)))
                  ENDDO
                ELSEIF(IPOLF2.EQ.2)THEN
                  DO I=1,MAXRS
                    DPA(I)=DPA(I)*(DONE-ALAV*DPOL2(DX(I)))
                  ENDDO
                ELSE
                  STOP 'SR.RKINT: HERE BE MONSTERS - 3'
                ENDIF
              ENDIF
              DO I=1,MAXRS
                DPA(I)=DPA(I)*DX(I)**MN
              ENDDO
            ENDIF
          ENDIF
!
          CALL WEDDLE(DZERO,DPA,DD,MNH,DHNS,MJH,MAXRS)
!
          REM=DZERO
          IF(MN.EQ.0)GO TO 260                      !VELOCITY
!
!      EVALUATE LONG-RANGE INTEGRAL
!
          DTH=DX(MAXRS)-DX(MXRM)
          DD1=DPNL(MXRM,K)
          DD2=DPNL(MAXRS,K)
          DD3=DPNL(MXRM,J)
          DD4=DPNL(MAXRS,J)
          DX1=DX(MAXRS)
          TM=SCREEN(K)
          TN=SCREEN(J)
          DB=DTWO*DYY(NREL)
          DC=-QN(J)
          DC=DC-TN
          DS=DZA/DC
          DS=DS*DS
          DNORM=DS/(PIH*DC)
          DNORM=SQRT(DNORM)
          ML1=QL(K)/2
          DS=ML1*(ML1+1)
          ML2=QL(J)/2
          DC=ML2*(ML2+1)
!
          CALL ASS2X(DX1,DTH,DX2,DD1,DD2,DD3,DD4,DB,DZERO,DS,DC,DZERO,  &
     &               DZERO,DZERO,DZERO,DZA,MN,REM2)
!
          CALL ASSX(DX2,MN,TM,TN,DB,DZERO,DZA,ML1,ML2,DS,DC,DZERO,DZERO,&
     &              DZERO,DZERO,REM)
!
          REM=REM*DNORM
          REM=REM2+REM
!              IF(MN.EQ.-1)REM=REM*DLL
          IF(MN.EQ.-2)REM=-REM*DZA                  !ACCELERATION
!
  260     M8=NFOSS(mm/2,K,J)
          DD=DD+REM
          DD=DD*OVL
!
          IF(MN.gt.0)DD=DD*DYY(NREL)**2             !LENGTH
!WORSE    IF(MN.gt.0)DD=DD*(DYY(NREL)+DSHIFT(J))**2
          IF(MN.EQ.-1)DD=DD*DYY(NREL)/2             !ALT VELOCITY (TEST)
!
          IF(M8.GT.0)THEN
            IF(IRLX.EQ.2)THEN
              DO I=1,MENG
                DFOSS(M8,I,2)=DFOSS(M8,I,2)*OVL
              ENDDO
            ENDIF
            DFOSS(M8,NREL,2)=DD
          ENDIF
!
! LOOP OVER CONTINUUM ENERGIES
!
  280     IF(M8.EQ.0)GO TO 320
!
          IF(DSHIFT(J).EQ.DZERO)THEN               !SHIFT WAS EXPLICIT
            DO I=1,mxe1-1
              DFOSS(M8,I,1)=DFOSS(M8,I,2)/DYY(I)**2
            ENDDO
            GO TO 320
          ENDIF
!
          DO I=1,mxe1-1                            !=mxep if mm.le.mkmax
            TM=DYY(I)+DSHIFT(J)
            XP0=DZERO
!
! USE +1.1 TO EXTRAP HIGH E FROM NEAREST NEIGHEBOUR RATHER THAN INTERP.
!
            IF(TM.LT.-D1PT1*DYY(I).OR..NOT.BLAG)THEN
              DAS=DFOSS(M8,I,2)
              GO TO 310
            ENDIF
            IF(NAX.GT.MENG)THEN
              WRITE(MW6,*)' *** TOO FEW PI ENERGIES FOR FREE-FREE',     &
     &                    ' INTERPOLATION'
              WRITE(MW0,*)' *** TOO FEW PI ENERGIES FOR FREE-FREE',     &
     &                    ' INTERPOLATION'
              GO TO 500
            ENDIF
!NAX            IF(BBC1)GO TO 341
!
            DO L=NAX,MENG
              IF(DYY(L).GE.TM)THEN
                LP=L
                GO TO 290
              ENDIF
            ENDDO
            LP=MENG
!
!343        IF(BBC2)GO TO 344
  290       NP2=LP+NPH-1
            NP1=LP-NPH
            IF(NP1.LT.NAX)THEN
              NP1=NAX
              NP2=NP1+2*NPH-1
              NP2=MIN(NP2,MENG)
              GO TO 300
            ENDIF
            IF(NP2.GT.MENG)THEN
              NP1=NP1-NP2+MENG
              NP2=MENG
              NP1=MAX(NP1,NAX)
            ENDIF
!
!           GO TO 341
!344        NP2=LP
!           NP1=LP-1
!           DO 346 M=1,NLAGP2
!           IF(NP2.EQ.MENG)GO TO 347
!           IF(NP1.LE.1)GO TO 348
!           DD=DYY(NP2+1)-TM
!           DAS=TM-DYY(NP1-1)
!           IF(DD.LE.DAS)NP2=NP2+1
!           IF(DD.GT.DAS)NP1=NP1-1
!346        CONTINUE
!           GO TO 341
!347        NP1=NP2-NLAGP+1
!           GO TO 341
!348        NP2=NLAGP
!           NP1=1
!
  300       DAS=DZERO
            DO L=NP1,NP2
              DD=DONE
              DO M=NP1,NP2
                IF(L.NE.M)THEN
                  DD=DD*(TM-DYY(M))
                  DD=DD/(DYY(L)-DYY(M))
                ENDIF
              ENDDO
              DDY(L)=DD
            ENDDO
!          if(tm.lt.dyy(nax))then         !test forcing zero energy pi=0
!            do l=np1,np2
!              ddy(l)=ddy(l)*tm/dyy(l)
!            enddo
!          endif
!
            IF(TM.LT.DYY(NAX))XP0=D0PT35     !BETTER, BY COMP WITH EXACT
            DO M=NP1,NP2
              DAS=DAS+DDY(M)*DFOSS(M8,M,2)/DYY(M)**XP0
            ENDDO
!
  310       DFOSS(M8,I,1)=DAS*TM**XP0/TM**2    !N.B. TM=DYY(I)+DSHIFT(J)
!
          ENDDO
!
!   END LOOP OVER CONTINUUM ENERGIES
!
!OLD      IF(DYY(1).EQ.DZERO.AND.DSHIFT(J).LT.DYY(2).AND.BLAG
!OLD     X.and.mxe1.gt.1)
!OLD     XDFOSS(M8,1,1)=DFOSS(M8,2,1)*(DONE+DYY(2)/DSHIFT(J))**D1PT5
!
          IF(NREL.GE.mxe1)THEN
!OLD        DDD=DFOSS(M8,NREL,2)
!OLD        IF(MN.EQ.-2)DDD=DDD/(DYY(NREL)+DSHIFT(J))**2
!OLD        IF(MN.EQ.-1)DDD=DDD/(DYY(NREL)+DSHIFT(J))
            DDD=DFOSS(M8,NREL,1)
!
            DOSC(IN,mm/2)=DDD       !NO E SHIFT ON THIS (LENGTH) ELEMENT
            DOSC(INV,mm/2)=DZERO
            if(j.eq.k)stop 'sr.rkint: PI with equal orbs???'
          ENDIF
!
! increment multipole
  320     mm=mm+2
!          if(mm.le.lp0.and.bindb(in,mm/2))then
          if(mm.le.lp0)then                        !for stupid compilers
            if(bindb(in,mm/2))then
              if(bjump2)then
                if(mm.gt.mkmax)go to 350               !already upscaled
                m8=nfoss(mm/2,k,j)
                go to 280
              else
                go to 240
              endif
            endif
          endif
!
!
  350   ENDDO                               ! *** END INNER ORBITAL LOOP
!
      ENDDO                                 ! *** END OUTER ORBITAL LOOP
!
!
      if(mxmm.gt.ixd09)then      !should not happen with ixd09=ixblm/2+1
        write(mw6,10030)mxmm-1,mxmm
      endif
!
      IF(BBORN)THEN
        IF(NC.GT.IXD33)THEN                       !NO LONGER POSSIBLE...
          T=NC
          NU=NINT(SQRT(8*T+1),SP)
          NU=(NU-1)/2
          WRITE(MW6,*)'**SR.RKINT DIMENSION ERROR: INCREASE MXGRB TO: ',&
     &                NU
          WRITE(MW0,*)'**SR.RKINT DIMENSION ERROR: INCREASE MXGRB'
          GO TO 500
        ELSE
          MB3(0)=NC
          MB4(0)=N
        ENDIF
        if(nc.lt.ixd33)then                        !print alloc & usage
          if(bprnt0)write(mw6,*)'ixd33=',ixd33,'  usage=',nc
          if(btime)write(mw0,*)'ixd33=',ixd33,'  usage=',nc
        endif
        if(n.lt.ixd34)then                        !print alloc & usage
          if(bprnt0)write(mw6,*)'ixd34=',ixd34,'  usage=',n
          if(btime)write(mw0,*)'ixd34=',ixd34,'  usage=',n
        endif
        if(iflagb.gt.0)then                      !high multipole failure
          write(mw0,*)'*** attention: ',iflagb,' Born integrals were',  &
     &          ' zeroed-out due to numerical inaccuracy - see olg file'
          write(mw6,*)'*** attention: ',iflagb,' Born integrals were',  &
     &                ' zeroed-out due to numerical inaccuracy'
        endif
      ENDIF
!
      IF(BPRNT0)THEN
        WRITE(MW6,10090)
        M15=MIN(KLAST,I5TEEN)
        WRITE(MW6,10100)(QN(K),IHAR(K),K=1,M15)
        IF(KLAST.GT.M15)WRITE(MW6,10110)(QN(K),IHAR(K),K=M15+1,KLAST)
        DO K=1,KLAST                 !NEED TO MAP BACK FOR MATRIX OUTPUT
          I=0
          DO J=1,K                   !LENGTH
            I=I+1
            IN=ICOL(J,K,IZERO)
            t=dzero
            do m=0,ixblm/2           !find/print lowest multipole
              if(dosc(in,m).ne.dzero)then
                t=dosc(in,m)
                go to 360
              endif
            enddo
  360       TEMP(I)=t
!           write(mw6,10121)'L',k,j,(dosc(in,m),m=0,ixblm/2)
          ENDDO
!10121 format(a3,i4,i3,1x,15f8.4)
          DO J=K+1,KLAST             !VELOCITY
            I=I+1
            t=dzero
            IF(.NOT.BVEL)GO TO 370
            INV=ICOL(K,J,IZERO)  !IONE)
            INV=IXD28+INV
            do m=0,ixblm/2           !find/print lowest multipole
              if(dosc(inv,m).ne.dzero)then
                t=dosc(inv,m)
                go to 370
              endif
            enddo
  370       TEMP(I)=t
!           write(mw6,10121)'V',k,j,(dosc(inv,m),m=0,ixblm/2)
          ENDDO
          WRITE(MW6,10120)QN(K),IHAR(K),(TEMP(I),I=1,M15)
          IF(KLAST.GT.M15)WRITE(MW6,10130)(TEMP(I),I=M15+1,KLAST)
        ENDDO
        IF(.NOT.BFOTJ)THEN
          WRITE(MW6,10140)PIG
          m0=mpol00
          if(brel2)m0=m0-2
          if(m0.lt.0)m0=0
          DO M=m0,MPOLE,2
            MM=M/2
            WRITE(MW6,10150)MM
            if(mm.gt.mkmax)then                            !all upscaled
              mxe1=1
            else
              mxe1=mxep+1
            endif
            md=mod(mm,itwo)
            DO K=1,KLAST
              DO J=1,K-1
                IF(mod(INT((QL(K)+QL(J))/2,SP),itwo).eq.md)THEN
                  M8=NFOSS(mm/2,K,J)    !AS NFOSS ASSUMES CORRECT PARITY
                  IF(M8.GT.0)THEN
                    WRITE(MW6,10020)M8,J,K,(DFOSS(M8,I,1),I=1,MENG)
                    IF(QN(J).LT.0)WRITE(MW6,10020)M8,J,K,               &
     &                                  (DFOSS(M8,I,2),I=1,mxe1-1)
                                                 !/(DYY(I)+DSHIFT(J))**2
                    M80=NFOSS(mm/2,J,K)
                    IF(M8*M80.NE.M80*M80)THEN
                      WRITE(MW6,10020)M80,K,J,(DFOSS(M80,I,1),I=1,MENG)
                    ENDIF
                  ENDIF
                ENDIF
              ENDDO
            ENDDO
          ENDDO
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
  400 CONTINUE
!
! LOCAL
      IF(BFOT)DEALLOCATE(DDY)
      DEALLOCATE(LIMR,IHAR)
!
      DEALLOCATE(DPA,DP,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RKINT: DE-ALLOCATION FAILS FOR DPA,DP'
        IF(NF.GT.0)NF=0
      ENDIF
!
      IF(BPRNT0)THEN
        DEALLOCATE(TEMP,STAT=IERR)
!
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'RKINT: DE-ALLOCATION FAILS FOR TEMP'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
  500 NF=-1
      GO TO 400
!
!-----------------------------------------------------------------------
!
10010 FORMAT(I7,I5,I3,I4,I5,I4,I6,7F14.7,1X/(32X,7F14.7))
10020 FORMAT(I5,I8,I9,10X,1P,7E14.6,1X/(32X,7E14.6))
10030 FORMAT(/' *** full retardation restricted to lambda=',i2,'  set', &
     &       ' (ixd09=)ixblm/2+1=',i2,' to get full expansion.')
10040 FORMAT(/'   N(B)  NC B(A,  B,   C,  D, 2LBD)  = BORN-INTEGRALS')
10050 FORMAT(' *** WARNING: BORN MULTIPOLE EXPANSION BEEN RESTRICTED',  &
     &       ' TO KPOLE=',I3)
10060 FORMAT(/I2,'-',I2,' BORN MOMENTUM TRANSFERS:',1X,10(I3,1PE9.2)    &
     &       /(31X,10(I3,E9.2)))
10070 FORMAT(/31X,7(7X,I3,'-',I3)/(31X,7(7X,I3,'-',I3)))
10080 FORMAT(' *** SR.RKINT:REDUCE NREL FOR FREE-FREE PI VEL GAUGE:',I4)
10090 FORMAT(/" DIPOLE LENGTH INTEGRALS (K=1, FOR /L-L'/=1)  AND",      &
     &    " QUADRUPOLE (K=2) INTEGRALS  <NL! R**K !N'L'>; ('N**' STANDS"&
     &    ," FOR: NL NOT COMPUTED)"/8X,                                 &
     &    "ABOVE THE DIAGONAL ARE VELOCITY",                            &
     &    " INTEGRALS <NL! 2*D/DR+(L'(L'+1)-L(L+1))/R !N'L'>      ")
10100 FORMAT(3X,"N  L",1X,15(I3,I3,2X))
10110 FORMAT((8X,15(I3,I3,2X)))
10120 FORMAT(I4,I3,1X,15F8.4)
10130 FORMAT((8X,15F8.4))
10140 FORMAT(/12X,'A',8X,'C',14X,                                       &
     &       ' PHOTO-IONIZATION (2K-POLE) INTEGRALS; GAUGE=',A3,' :')
10150 FORMAT(/' K=',I2/)
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!-----------------------------------------------------------------------
      FUNCTION DPOL1(X)
!
      REAL(WP) X,DPOL1
!
      DPOL1=(DONE-EXP(-(X/RCAV)**3))/X**3
!
      END FUNCTION DPOL1
!-----------------------------------------------------------------------
      FUNCTION DPOL2(X)
!
      REAL(WP) X,DPOL2
!
      DPOL2=DONE/((X*X+RCAV*RCAV)*SQRT(X*X+RCAV*RCAV))
!
      END FUNCTION DPOL2
!-----------------------------------------------------------------------
!
      END SUBROUTINE RKINT
!
!                             *******************
!
      SUBROUTINE RKX(DP1,DP2,DQ1,DQ2,JJ,DPA,DP,DX,DPOLA,REM,ovlp,SUM)
!
!-----------------------------------------------------------------------
!
!  SR.RKX CALCULATES THE EIE SLATER INTEGRAL USING INPUT YK (DP),
!    INCLUDING ANY LONG-RANGE CONTRIBUTION. AND ANY EXHANGE OVERLAP.
!
!  IT IS CALLED BY:
!    SR.SLATRX
!
!  IT CALLS:
!    SR.WEDDLE
!
!  IT CONTAINS:
!    FN.DPOL1
!    FN.DPOL2
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD,KORT
      USE COMMON_NRBPOT, ONLY: DPOT,TOL,MEND
      USE COMMON_NRBPOT, ONLY: ALFD,RCUT,ALAV,RCAV,IPOLFN
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION DP1(*),DP2(*),DQ1(*),DQ2(*),DPA(*),DP(*),DX(*)
!
      ALLOCATABLE :: GR(:)
!
!-----------------------------------------------------------------------
!      DPOL1(X)=SQRT(DONE-EXP(-(X/RCAV)**6))/X**2
!      DPOL2(X)=X/((X*X+RCAV*RCAV)*SQRT(X*X+RCAV*RCAV))
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!
! THE NAMES HERE ARE NOT NECESSARILY SIGNIFICANT THEY ARE COMMON LEGACY.
!
! LOCAL
      ALLOCATE(GR(MAXRS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RKX: ALLOCATION FAILS FOR GR'
        NF=0
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
      BREL2=ABS(IREL).EQ.2
      IPOLF2=IPOLFN/10
      MI=ABS(JJ)/2
!
      IF(BREL2)THEN
        IF(JJ.GT.0)THEN
          DO I=1,MAXRS
            GR(I)=DP1(I)*DP2(I)+DQ1(I)*DQ2(I)
            DPA(I)=GR(I)*(DP(I)+REM*DX(I)**MI)
          ENDDO
        ELSE
          DO I=1,MAXRS
            GR(I)=DP1(I)*DP2(I)+DQ1(I)*DQ2(I)
            DPA(I)=GR(I)*DP(I)
          ENDDO
        ENDIF
      ELSE
        IF(JJ.GT.0)THEN
          DO I=1,MAXRS
            GR(I)=DP1(I)*DP2(I)
            DPA(I)=GR(I)*(DP(I)+REM*DX(I)**MI)
          ENDDO
        ELSE
          DO I=1,MAXRS
            GR(I)=DP1(I)*DP2(I)
            DPA(I)=GR(I)*DP(I)
          ENDDO
        ENDIF
      ENDIF
!
      CALL WEDDLE(DZERO,DPA,SUM,MNH,DHNS,MJH,MAXRS)
!
      if(jj.eq.0)then
        if(ovlp.eq.dzero)then                                    !direct
!test          call weddle(dzero,gr,ovlp0,mnh,dhns,mjh,maxrs)  !e.g.rlx2
          sum=sum+rem       !*ovlp0     !subtract any divergent monopole
        elseif(kort.lt.0.or.kort.eq.0.and.mort.ne.-3)then      !exchange
          call weddle(dzero,gr,ovlp0,mnh,dhns,mjh,maxrs)
          do i=1,maxrs
            dpa(i)=gr(i)*dpot(i)
          enddo
          call weddle(dzero,dpa,rem0,mnh,dhns,mjh,maxrs)
          rem0=-rem0/(dpot(maxrs)*dx(maxrs))          !a.u. per electron
!      write(mw6,*)ovlp*rem0,ovlp0*rem
          xovlp=ovlp*rem0+ovlp0*rem
          xovlp=xovlp/dtwo                                      !average
          sum=sum+xovlp
          ovlp=ovlp*ovlp0
        else
          ovlp=dzero
        endif
      endif
!
      IF(IPOLF2.GT.0.AND.MI.EQ.1)THEN           !DIELECTRIC POLARIZATION
        IF(IPOLF2.EQ.1)THEN
          DO I=1,MAXRS
            DPA(I)=DPOL1(DX(I))*GR(I)
          ENDDO
        ELSEIF(IPOLF2.EQ.2)THEN
          DO I=1,MAXRS
            DPA(I)=DPOL2(DX(I))*GR(I)
          ENDDO
        ELSE
          STOP 'SR.RKX: HERE BE MONSTERS'
        ENDIF
        CALL WEDDLE(DZERO,DPA,DPOLB,MNH,DHNS,MJH,MAXRS)
!        write(mw0,*)(qrl(i,l),i=1,5),db,alav*dpola*dpolb
        SUM=SUM-ALAV*DPOLA*DPOLB
      ENDIF
!
!-----------------------------------------------------------------------
!
! LOCAL
      DEALLOCATE(GR,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'RKX: DE-ALLOCATION FAILS FOR GR'
        NF=0
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION DPOL1(X)
!
      REAL(WP) X,DPOL1
!
      DPOL1=SQRT(DONE-EXP(-(X/RCAV)**6))/X**2
!
      END FUNCTION DPOL1
!-----------------------------------------------------------------------
      FUNCTION DPOL2(X)
!
      REAL(WP) X,DPOL2
!
      DPOL2=X/((X*X+RCAV*RCAV)*SQRT(X*X+RCAV*RCAV))
!
      END FUNCTION DPOL2
!-----------------------------------------------------------------------
!
      END SUBROUTINE RKX
!
!                             *******************
!
      SUBROUTINE ROMB(ID,BCF,L,R1,I1,F1,R2,I2,F2,VM,V0,V1,M0,S1,S2,S3,  &
     &                S4,S5,XBINT,XOINT,EB,EO,TOLR,TM2)
!
!-----------------------------------------------------------------------
!
!  SR.ROMB IMPLEMENTS A SINGLE STEP OF ROMBERG'S RULE.
!
!  A. BURGESS, DAMTP, CAMBRIDGE - SEE ALSO J.PHYS.B30, 33 (1997).
!
!  IT IS CALLED BY:
!    SR.BORN
!
!  IT CALLS:
!    SR.FILON
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
      DIMENSION XBI(0:20),XOI(0:20),F1(0:*),F2(0:*)
      DIMENSION S1(0:*),S2(0:*),S3(0:*),S4(0:*),S5(0:*)
!
!-----------------------------------------------------------------------
!
      X0=V0/(V0+VM)
      X1=V1/(V1+VM)
      X=X0
      V=V0
      K=0
!
  100 CALL FILON(L,V,R1,I1,F1,FB1,FO1)
      IF(BCF)THEN
        CALL FILON(L,V,R2,I2,F2,FB2,FO2)
      ELSE
        FB2=FB1
        FO2=FO1
      ENDIF
      T=V+VM
      T=T*T/VM
      T2=FB1*FB2*V
      IF(L.EQ.0)THEN
        T1=T2
        T2=FO1*FO2*V
      ELSE
        IF(L.GT.1)THEN
          T1=FB1*FB2*V**(L+L-3)
        ELSEIF(V.GT.D1M7)THEN
          T1=(FB1*FB2-TM2*VM/(V+VM))/V
        ELSE
          T1=TM2/VM
!        stop 'romb'
        ENDIF
        DO J=1,L
          T2=T2*V*V
        ENDDO
      ENDIF
!
      S1(K)=V
      S2(K)=FB1
      S3(K)=FB2
      S4(K)=T1
      S5(K)=T2
      IF(K.EQ.0)THEN
        XB0=T*T1
        XO0=T*T2
        X=X1
        V=V1
        K=ID
        GO TO 100
      ENDIF
      XB0=(T*T1+XB0)*DHALF
      XO0=(T*T2+XO0)*DHALF
      H=X1-X0
      XBI(0)=XB0*H
      XOI(0)=XO0*H
      SB=DZERO
      SO=DZERO
      M=0
!
  200 M=M+1
      H=H*DHALF
      X=X0-H
      N=2**(M-1)
      DO 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)
        IF(BCF)THEN
          CALL FILON(L,V,R2,I2,F2,FB2,FO2)
        ELSE
          FB2=FB1
          FO2=FO1
        ENDIF
!
        tt=sqrt(abs(fb1))*sqrt(abs(fb2))
        if(tt.gt.sqrt(huge(tt))/dten**wp)then    !large lam so born=zero
          xbint=dzero
          xoint=dzero
          eb=d1p10
          eo=d1p10
          tolr=-done
          return
        endif
!
        T2=FB1*FB2*V
        IF(L.EQ.0)THEN
          T1=T2
          T2=FO1*FO2*V
        ELSE
          IF(L.GT.1)THEN
            T1=FB1*FB2*V**(L+L-3)
          ELSEIF(V.GT.D1M7)THEN
            T1=(FB1*FB2-TM2*VM/(V+VM))/V
          ELSE
            T1=TM2/VM
!         stop 'romb'
          ENDIF
          T2=FB1*FB2*V
          DO J=1,L
            T2=T2*V*V
          ENDDO
        ENDIF
        SB=T1*T+SB
        SO=T2*T+SO
        K=NINT(((X-X0)*ID)/(X1-X0),SP)
        S1(K)=V
        S2(K)=FB1
        S3(K)=FB2
        S4(K)=T1
        S5(K)=T2
      ENDDO
!
      T0=XBI(0)
      XBI(0)=(XB0+SB)*H
      U0=XOI(0)
      XOI(0)=(XO0+SO)*H
      DO I=1,M
        T3=DONE/(2**(I+I)-1)
        T1=XBI(I-1)
        U1=XOI(I-1)
        T2=(T1-T0)*T3+T1
        U2=(U1-U0)*T3+U1
        T3=T0
        T0=XBI(I)
        XBI(I)=T2
        U3=U0
        U0=XOI(I)
        XOI(I)=U2
      ENDDO
!
      EB=ABS((T2-T3)/T2)
      EO=ABS((U2-U3)/U2)
!
!        write(mw6,*)m,t3,t2,eb
!        call flush(mw6)
!
      IF(M.LT.M0.AND.EB.GT.TOLR)GO TO 200
!
!        write(mw6,*)m,v0,v1
!
!        if(eb.gt.tolr)then
!          write(mw0,*)' *** sr.romb: romberg has failed to converge'
!          write(mw0,*)' *** sr.romb: check accuracy, iterations & tol'
!     &                ,m0,eb
!!         write(mw6,*)' *** sr.romb: romberg has failed to converge'
!          write(mw6,*)' *** sr.romb: check accuracy, iterations & tol'
!     &                ,m0,eb
!        endif
!
      XBINT=T2
      XOINT=U2
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE ROMB
!
!                             *******************
!
      SUBROUTINE ROTSYM(N,NP,BEIVEC,C,S,IP,IQ,A,V,MXMAT)
!
!-----------------------------------------------------------------------
!
!  SR.ROTSYM EXECUTES A JACOBI ROTATION IN THE ROW IP AND THE COLUMN IQ
!  OF A AND V. C,S=COSINES,SINES OF THE ROTATION. THE RESULTS ARE AGAIN
!  IN A AND V. N,NP=ACTUAL DIMENSIONS OF A AND V,A(I,J),I=1,NP,J=1,N.
!  BEIVEC SEE SR.JACORD.
!
!  IT IS CALLED BY:
!    SR.JACORD
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION A(MXMAT,*),V(MXMAT,*)
!
!-----------------------------------------------------------------------
!
      H=A(IP,IQ)*S/C
      A(IP,IP)=A(IP,IP)-H
      A(IQ,IQ)=A(IQ,IQ)+H
!
      DO J=1,IP-1
        H=C*A(J,IP)-S*A(J,IQ)
        A(J,IQ)=S*A(J,IP)+C*A(J,IQ)
        A(J,IP)=H
      ENDDO
!
      DO J=IP+1,IQ-1
        H=C*A(IP,J)-S*A(J,IQ)
        A(J,IQ)=S*A(IP,J)+C*A(J,IQ)
        A(IP,J)=H
      ENDDO
!
      DO J=IQ+1,N
        H=C*A(IP,J)-S*A(IQ,J)
        A(IQ,J)=S*A(IP,J)+C*A(IQ,J)
        A(IP,J)=H
      ENDDO
!
      IF(.NOT.BEIVEC)GO TO 100
!
      DO J=1,NP
        H=C*V(J,IP)-S*V(J,IQ)
        V(J,IQ)=S*V(J,IP)+C*V(J,IQ)
        V(J,IP)=H
      ENDDO
!
!-----------------------------------------------------------------------
!
  100 RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE ROTSYM
!
!                             *******************
!
      FUNCTION SINTER(N,XN,YN,X)
!
!-----------------------------------------------------------------------
!
! APPLY LAGRANGE INTERPOLATION IN COMPLEX PLANE TO TRIGONOMETRIC
! EXPANSION IN XN,YN FOR X IN INTERVAL [0:1].
! COULD ABSORB PI INTO XN ETC FOR SPEED.
!
!  IT IS CALLED BY:
!    FN.XINT
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION XN(*),YN(*)
!
!-----------------------------------------------------------------------
!
      PI=ACOS(-DONE)
!
      P=0
      DO K=1,N
        A=0
        F=1
        DO M=1,N
          IF(M.NE.K)THEN
            A=A+XN(M)
            S=SIN(PI*(X-XN(M)))
            S=S/SIN(PI*(XN(K)-XN(M)))
            F=S*F
          ENDIF
        ENDDO
        IF(MOD(N,ITWO).EQ.0)F=F*SIN(PI*(X-A))/SIN(PI*(XN(K)-A))  !EVEN
        P=P+F*YN(K)
      ENDDO
!
      SINTER=P
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION SINTER
!
!                             *******************
!
      FUNCTION SJS(J1,J2,J3,L1,L2,L3)
!
!-----------------------------------------------------------------------
!
!  FN.SJS EVALUATES THE WIGNER 6J-SYMBOL:
!  THE SIX QUANTUM NUMBER ARGUMENTS HAVE TWICE THEIR PHYSICAL VALUE.
!
!  FACTORIALS DFS(I)=(I-1)!/LDFS**(I-1) FOR I=1,IXDFS ARE SUPPLIED
!  BY A PRIOR CALL TO SR.DFACT (CONTAINED IN MODULE CONSTAMTS_MATH).
!
!  CAN ALSO USE OLD STYLE DFS WHICH ALTERNATES FACTORIALS WITH PHASES,
!  ITS PHASE INFO IS NO LONGER USED. THE SWITCH IS TRANSPARENT.
!
!  IF THE ARGUMENTS ARE TOO LARGE FOR THE CURRENT PRECISION (FACTORIALS
!  AND/OR CANCELLATION) THEN SR.WIG6JR IS CALLED TO DETERMINE IT VIA
!  RECURSION. THIS IS LESS INEFFICIENT.
!
!  N.B. WHILE USE OF LOG(I!) SOLVES ANY OVERFLOW PROBLEM, IT DOES NOT
!  SOLVE THE CANCELLATION PROBLEM AS THE SJS IS A SUM OF TERMS OF
!  ALTERNATING SIGN (AND SO EACH TERM MUST BE EXPONENTIATED FIRST).
!  THE PRODUCTS BELOW ARE ORGANIZED SUCH THAT CANCELLATION BECOMES AN
!  ISSUE BEFORE OVERFLOW.
!
!  IT IS CALLED BY:
!    SR.CAFLGL
!    SR.CAFLGLX
!    SR.DIAGFS
!    SR.DWXBP_DAXPY
!    SR.DWXBP_DDOT
!    SR.FLGLX3
!    SR.MKALG1
!    SR.NCHAJK
!
!  IT CALLS:
!    SR.DIMUSE
!    SR.WIG6JR
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      REAL(XP) XOM
!
      PARAMETER (DEPS2=1.E-5_WP)
!
      DIMENSION IA(0:3),IB(0:3),JMN(3),JMX(3)
!
      ALLOCATABLE :: W6J(:)
!
      DATA BFIRST/.TRUE./
!
!-----------------------------------------------------------------------
!
      OMEGA=DZERO
!
!      sj=dzero
!      w6=dzero
!
      IF(J1+J2.LT.J3)GO TO 100
      IF(J1+L2.LT.L3)GO TO 100
      IF(J2+L3.LT.L1)GO TO 100
      IF(J3+L1.LT.L2)GO TO 100
!
      IF(ABS(J1-J2).GT.J3)GO TO 100
      IF(ABS(J1-L2).GT.L3)GO TO 100
      IF(ABS(J2-L3).GT.L1)GO TO 100
      IF(ABS(J3-L1).GT.L2)GO TO 100
!
      IJ0=J1+J2+J3+2
      IJ1=J1+L2+L3+2
      IJ2=L1+J2+L3+2
      IJ3=L1+L2+J3+2
!
      IF(MOD(IJ0,ITWO)+MOD(IJ1,ITWO)+MOD(IJ2,ITWO)+MOD(IJ3,ITWO).NE.0)  &
     &   GO TO 100
!
      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 100
!
      IF(DFS(3).LT.DZERO)THEN
        IH=1                         !IH=1 USES OLD DFS ALIGNMENT
      ELSE
        IH=2                         !IH=2 USES NEW DFS ALIGNMENT
      ENDIF
!
      I1=2/IH
!
      IWMIN=IWMIN/IH
      IWMAX=IWMAX/IH
!
!-----------------------------------------------------------------------
!
! WE CAN USE FACTORIALS, IF NOT TOO LARGE FOR CANCELLATION
!
!-----------------------------------------------------------------------
!
      IF(IWMAX.LE.IXDFS6)THEN
!
        CALL DIMUSE('MXDFS',IWMAX)
!
        ID1=ID1/IH
        ID2=ID2/IH
        ID3=ID3/IH
!
        IJ0=IJ0/IH
        IJ1=IJ1/IH
        IJ2=IJ2/IH
        IJ3=IJ3/IH
!
        XOM=0
!
!        IPHASE=MOD(IH*IWMAX-IONE,IFOUR)-2
!        DO IW=IWMAX,IWMIN,-I1     !REVERSE SUM TESTS CANCELLATION ERROR
!
        IPHASE=MOD(IH*IWMIN-IONE,IFOUR)-2
        DO IW=IWMIN,IWMAX,I1              !SUBJECT TO CANCELLATION ERROR
!
          XOM=IPHASE*DFS(IW)                                            &
     &        /(DFS(ID1-IW)*DFS(ID2-IW)*DFS(ID3-IW)*DFS(IW-IJ0)         &
     &        *DFS(IW-IJ1)*DFS(IW-IJ2)*DFS(IW-IJ3))+XOM
          IPHASE=-IPHASE
!
        ENDDO
!
        IJ0=IJ0+I1
        IJ1=IJ1+I1
        IJ2=IJ2+I1
        IJ3=IJ3+I1
!
        D1=SQRT(DFS(IJ0))
        D2=SQRT(DFS(IJ1))
        D3=SQRT(DFS(IJ2))
        D4=SQRT(DFS(IJ3))
!
        XOM=XOM/D1/D2/D3/D4
!
        OMEGA=XOM*SQRT(DFS(ID1-IJ0)*DFS(ID2-IJ0)*DFS(ID3-IJ0))          &
     &        *SQRT(DFS(ID1-IJ1)*DFS(ID2-IJ1)*DFS(ID3-IJ1))             &
     &        *SQRT(DFS(ID1-IJ2)*DFS(ID2-IJ2)*DFS(ID3-IJ2))             &
     &        *SQRT(DFS(ID1-IJ3)*DFS(ID2-IJ3)*DFS(ID3-IJ3))/LDFS
!
!        sj=omega
!!        write(mw6,*)'sjs=',omega
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! USE RECURSION IF CANCELLATION/TOO LARGE FOR FACTORIAL
!
!-----------------------------------------------------------------------
!
! USE RECURSION VIA SR.WIG6JR
!
      IF(IWMAX.GT.IXDFS6)THEN
!
        IF(BFIRST)THEN
          IF(XP.LT.16)THEN
!            WRITE(MW0,*)'*** FN.SJS: USING RECURSION, INCREASE XP?'
            WRITE(MW6,10010)IWMAX,IXDFS6,XP
          ENDIF
          BFIRST=.FALSE.
        ENDIF
!
! MAP SJS ORDER TO WIGNER 6J, TRIVIAL ONE-TO-ONE
!
! THEN RE-ORDER ARGUMENTS TO MINIMIZE LENGTH OF RECURSION
! (AS ONLY USED FOR LARGE ARGUMENT VALUES)
! N.B. WE ONLY CYCLE ARGUMENTS, AS PER 3J, NOT WORTH SHORT-CUTTING AS 6J
!
!        bcycle=.false.
        IA(1)=J1
        IA(2)=J2
        IA(3)=J3
        IB(1)=L1
        IB(2)=L2
        IB(3)=L3
!
        JRNG1=99999
        DO IC=1,3
          JMN(IC)=MAX(ABS(IA(2)-IA(3)),ABS(IB(2)-IB(3)))          !TWICE
          JMX(IC)=MIN(ABS(IA(2)+IA(3)),ABS(IB(2)+IB(3)))          !TWICE
          JRNG0=JMX(IC)-JMN(IC)
          IF(JRNG0.LT.JRNG1)THEN
            IC1=IC
            JRNG1=JRNG0
          ENDIF
          DO I=1,4              !OLD SCHOOL, COULD PROBABLY USE POINTERS
            I4=MOD(I,IFOUR)
            IA(I-1)=IA(I4)
            IB(I-1)=IB(I4)
          ENDDO
        ENDDO
!
!        NDIMW=JMX(IC1)/2
        IC1=IC1-1
        DO IC=1,IC1
!          bcycle=.true.
          DO I=1,4              !OLD SCHOOL, COULD PROBABLY USE POINTERS
            I4=MOD(I,IFOUR)
            IA(I-1)=IA(I4)
            IB(I-1)=IB(I4)
          ENDDO
        ENDDO
!
!        TA1=IA(1)
        TA2=IA(2)
        TA2=TA2/2
        TA3=IA(3)
        TA3=TA3/2
        TB1=IB(1)
        TB1=TB1/2
        TB2=IB(2)
        TB2=TB2/2
        TB3=IB(3)
        TB3=TB3/2
!
        T=MIN(TA2+TA3,TB2+TB3)
        NDIMW=NINT(T-DEPS2)              !NDIMW IS JUST JMAX
!
        ALLOCATE(W6J(-1:NDIMW+1))        !LBOUND ONLY NEEDS TO BE JMIN-1
!
        CALL WIG6JR(W6J,TA2,TA3,TB1,TB2,TB3,JMIN,JMAX,JH,NDIMW)
!
        IF(JMIN.LT.0)THEN
          IF(JMIN.EQ.-3)THEN                          !SHOULD NOT HAPPEN
            WRITE(MW0,*)                                                &
     &        '*** FN.SJS: WIG6JR DIMENSION FAILURE, INCREASE NDIMW TO '&
     &        ,JMAX
          ELSE
            WRITE(MW0,*)                                                &
     &   '*** FN.SJS: WIG6JR SELECTION RULE FAILURE, ALL 6J EQUAL ZERO!'
            IF(JMIN.EQ.-1)WRITE(MW0,*)                                  &
     &            '*** FN.SJS: WIG6JR FAILURE, NON-INTEGER TRIANGLE SUM'
            IF(JMIN.EQ.-2)WRITE(MW0,*)                                  &
     &               '*** FN.SJS: WIG6JR FAILURE, TRIANGLE RULE FAILURE'
          ENDIF
          DEALLOCATE(W6J)
          GO TO 100
        ENDIF
!
! THIS IS THE W6J LOCATION OF THE REQUIRED SJS
!
        JW=(IA(1)-JH)/2                 !NINT((TA1-JH)/DTWO)
!
        OMEGA=W6J(JW)
!
!        w6=omega
!!        write(mw6,*)j1,jw,omega
!
        DEALLOCATE(W6J)
!
      ENDIF
!
!
!-----------------------------------------------------------------------
!
! WE ARE DONE
!
  100 CONTINUE
!
!      if(abs(sj-w6).gt.1.d-12)then
!                             write(mw0,*)bcycle,'wig6jr=',w6,'sjs=',sj
!                             write(mw0,*)j1,j2,j3,l1,l2,l3
!      endif
!
      SJS=OMEGA
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(/' *** FN.SJS: FACTORIAL ARRAY TOO SHORT',I5,              &
     &       '.GT. IXDFS6=',I5,' WITH CURRENT WORD PRECISION XP=',I3,   &
     &       '; 6J-COEFFS ARE DETERMINED BY RECURSION'/)
!
!-----------------------------------------------------------------------
!
      END FUNCTION SJS
!
!                             *******************
!
      SUBROUTINE SLATR(BPRNT0)
!
!-----------------------------------------------------------------------
!
!  SR.SLATR EVALUATES SLATER INTEGRALS AND (IF BKUTOO)
!  2-BODY NON-FINE STRUCTURE INTEGRALS.
!
!  THE FOUR ELECTRON-ARGUMENTS (1,2,3.. FOR 1S,2S,2P..) HAVE BEEN
!  STORED IN QRL(I,L),I=1,4, AND 2*LAMBDA IN QRL(5,L).
!
!  IT IS CALLED BY:
!    SR.CARATE
!    SR.DIAGON
!
!  IT CALLS:
!    SR.ASSX
!    SR.ASS2X
!    SR.WEDDLE
!    SR.YLAMKR
!    SR.YLAMK
!    SR.ELAM
!    SR.XTWOO
!    SR.ZLAM
!
!  IT CONTAINS:
!    FN.ICOL
!    FN.DPOL1
!    FN.DPOL2
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DXRL,   ONLY: QRL,IRL,NAD
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_GENINF, ONLY: SCALER
      USE COMMON_INTS,   ONLY: DRL
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD,KORT
      USE COMMON_NRBAL1, ONLY: ISCALR
      USE COMMON_NRBAL2, ONLY: MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBDR,  ONLY: IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR
      USE COMMON_NRBINT, ONLY: DRLI,DYY,IYY,NRLI,MENG,NREL,NLAG,NLAGP   &
     &                        ,BLAG,BBC2
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBNF2, ONLY: DETA,DXSI,DZL,DXTWO
      USE COMMON_NRBNFI, ONLY: DZLI,DXTWOI,DETAI,FRI,GRI
      USE COMMON_NRBOLP, ONLY: OVLPGR,OVLPCF,IPAIR
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
      USE COMMON_NRBPOT, ONLY: DL2=>DPOT,TOL,MEND
      USE COMMON_NRBPOT, ONLY: POTHAM,MPSEUD
      USE COMMON_NRBPOT, ONLY: ALFD,RCUT,ALAV,RCAV,IPOLFN
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBSHF, ONLY: DSHIFT,MSHIFT,KSHIFT,MKMAX,MXEP
      USE COMMON_NRBVAL, ONLY: FACT,IVAL,NNEW,NNOLD,BJUMP,BJUMP2,BRAD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (PIH=1.5707963_WP)              !HISTORIC, TO BE REMOVED
!
      ALLOCATABLE :: DPA(:),DP(:),DUM4(:)
!
!-----------------------------------------------------------------------
!      DPOL1(X)=SQRT(DONE-EXP(-(X/RCAV)**6))/X**2
!      DPOL2(X)=X/((X*X+RCAV*RCAV)*SQRT(X*X+RCAV*RCAV))
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!
! THE NAMES HERE ARE NOT NECESSARILY SIGNIFICANT THEY ARE COMMON LEGACY.
!
! LOCAL
      ALLOCATE(DPA(MAXRS),DP(MAXRS),DUM4(MAXRS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SLATRI: ALLOCATION FAILS FOR DPA,DP,DUM4'
        NF=0
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
      PI=ACOS(-DONE)
!      PIH=PI/DTWO                                 !AS USED ELSEWHERE...
!
! INITIALIZE LOGICALS
!
      BREL2=ABS(IREL).EQ.2
      BDR=IDR.NE.0
      BKUTOO=KUTOO.NE.0
      BCONT=MODE.EQ.2.OR.MODE.EQ.3
!
      DZA=MION-NZION-1
      MXRM=MAXRS-1
!
      IF(BPRNT0)THEN
        IF(ABS(SCALER-DONE).GT.D1M8)WRITE(MW6,10040)SCALER
        IF(KUTOO.EQ.0)WRITE(MW6,10020)
        IF(KUTOO.NE.0)WRITE(MW6,10030)
      ELSEIF(ISCALR.NE.0)THEN
        WRITE(MW6,10040)SCALER
      ENDIF
!
      IF(BJUMP)THEN                 !JUST RE-COMPUTE OR RE-SCALE RYDBERG
!
        DO J=1,IRL
          M=0
          TM=DONE
          DO I=1,4
            N=QRL(I,J)
            IF(N.GT.0)THEN
              M=M+IVAL(N)
              TM=TM*FACT(N)
            ENDIF
          ENDDO
          IF(BCONT)THEN
            KK=NRLI(J)
          ELSE
            KK=0
          ENDIF
          IF(M.GT.0)THEN
            IF(BJUMP2)THEN
              DRL(J)=DRL(J)*TM      !RE-SCALE
              IF(BKUTOO)THEN
                DZL(J)=DZL(J)*TM
                DXTWO(J)=DXTWO(J)*TM
                DETA(J)=DETA(J)*TM
              ENDIF
              IF(KK.GT.0)THEN
                DO I=1,MENG
                  DRLI(I,KK)=DRLI(I,KK)*TM
                ENDDO
                IF(BKUTOO)THEN
                  DO I=1,MENG
                    DZLI(I,KK)=DZLI(I,KK)*TM
                    DXTWOI(I,KK)=DXTWOI(I,KK)*TM
                    DETAI(I,KK)=DETAI(I,KK)*TM
                  ENDDO
                ENDIF
              ENDIF
            ELSE
              DRL(J)=DZERO          !ZERO-OUT FOR RE-COMPUTE (+2NFS)
            ENDIF
          ENDIF
!
          IF(BJUMP2.AND.BPRNT0)THEN
            IF(KK.EQ.0)WRITE(MW6,10050)J,(QRL(I,J),I=1,5),DRL(J)
            IF(KK.GT.0)WRITE(MW6,10050)J,(QRL(I,J),I=1,5),              &
     &                                 (DRLI(IC,KK),IC=1,MENG)
            IF(BKUTOO)THEN
              IF(KK.EQ.0)WRITE(MW6,10060)DXTWO(J),DZL(J),DETA(J)
              IF(KK.GT.0)THEN
                WRITE(MW6,10060)(DXTWOI(IC,KK),IC=1,MENG)
                WRITE(MW6,10060)(DZLI(IC,KK),IC=1,MENG)
                WRITE(MW6,10060)(DETAI(IC,KK),IC=1,MENG)
              ENDIF
            ENDIF
          ENDIF
        ENDDO
!
        IF(BJUMP2)GO TO 200                                      !RETURN
!
      ELSE                                 !INITIALIZE AND COMPUTE *ALL*
!                                          !2-NFS DO NOT NEED SEPARATE
        DO L=1,IRL
          DRL(L)=DZERO
        ENDDO
!
        IF(MODE.EQ.4)THEN
          KK=0
          DO J=1,IRL
            IF(QRL(5,J).GT.2*MAXLAM)GO TO 20
            N1=QRL(1,J)
            N3=QRL(3,J)
            IF(IYY(N1)*IYY(N3).GT.0)GO TO 20
            N2=QRL(2,J)
            IF(QRL(5,J).GT.0.AND.IYY(N2).GT.0)GO TO 20
            KK=KK+1
            IF(KK.LE.IXFSL)NRLI(J)=KK
   20     ENDDO
!
          IF(KK.GT.IXFSL)THEN
            WRITE(MW6,10010)KK
            NF=-1
            GO TO 200
          ENDIF
        ENDIF
      ENDIF
!
! OUTER LOOP TO DETERMINE SLATER INETGRALS
!
      IPOLF2=IPOLFN/10
!
      DO J=1,IRL
!
        IF(DRL(J).NE.DZERO)GO TO 150
        IF(QRL(5,J).GT.2*MAXLAM)GO TO 150
        N1=QRL(1,J)
        N2=QRL(3,J)
        IF(N2.LE.ABS(MPSEUD))GO TO 150
!
        JJ=QRL(5,J)
        IF(JJ.LT.0)THEN                               !TRANSFER ONE-BODY
          IN=ICOL(N2,N1,IZERO)
          DRL(J)=DUY(IN)
          IF(BKUTOO)THEN
            DZL(J)=DZERO
            DXTWO(J)=DZERO
            DETA(J)=DZERO
          ENDIF
          IF(BCONT)THEN
            KK=NRLI(J)
          ELSE
            KK=0
          ENDIF
          IF(KK.GT.0)THEN
            IF(IRLX.EQ.2)THEN
              KF=IGRCF(N1)
              KG=IGRCF(N2)
              IF(KF*KG.GT.0)THEN
                K1=MIN(KF,KG)
                K2=MAX(KF,KG)
                KKK=((K2-1)*(K2-2))/2+K1
                OVL=OVLPCF(KKK)
                DO I=1,MENG
                  DRLI(I,KK)=DRLI(I,KK)*OVL
                ENDDO
              ENDIF
            ENDIF
            DRLI(NREL,KK)=DRL(J)
            IF(BKUTOO)THEN
              DO I=1,MENG
                DZLI(I,KK)=DZERO
                DXTWOI(I,KK)=DZERO
                DETAI(I,KK)=DZERO
              ENDDO
            ENDIF
          ENDIF
          GO TO 150
        ENDIF
!
!  MODE=2 SETS ALL SLATER INTEGRALS WITH MORE THAN ONE CONTINUUM
!  ORBITAL TO ZERO, EXCEPT FOR BOUND ORBITALS APPROXIMATED  BY A K=0
!  CONTINUUM ORBITAL. LONG-RANGE INTEGRALS DEALT WITH USING AMPLITUDE
!  -PHASE METHOD OF BURGESS & SHEOREY (1974 J.PHYS.B)  AND BADNELL
!  (1983 J.PHYS.B AND UNPUBLISHED).
!
        IF(IYY(N2).GT.0.AND.MODE.LE.2)GO TO 150
        BXTRP=QN(N1).LT.0.AND.QN(N2).LT.0                    !LONG-RANGE
!
        M2=(QL(N1)+QL(N2))/2+2
        MI=JJ/2
!
        IF(BREL2)THEN
          DO I=1,MAXRS
            DPA(I)=DPNL(I,N1)*DPNL(I,N2)+DQNL(I,N1)*DQNL(I,N2)
          ENDDO
        ELSE
          DO I=1,MAXRS
            DPA(I)=DPNL(I,N1)*DPNL(I,N2)
          ENDDO
        ENDIF
!
! LOOK FOR POSSIBLE RYD-CONT EXCHANGE OVERLAP.
! FOR EFFICIENCY, USER SHOULD NOT SWITCH ON IF NO RYD PRESENT.
!
        REM=DZERO
!
        IF(KORT.LT.0.AND.JJ.EQ.0.AND.IYY(N1).GT.0)THEN
          do i=1,maxrs
            dp(i)=dpa(i)*dl2(i)
          enddo
          call weddle(dzero,dp,rem0,MNH,dhns,mjh,maxrs)
          rem0=-rem0/(dl2(maxrs)*dx(maxrs))           !a.u. per electron
          if(ival(n2).gt.0)rem=rem0                              !direct
        ELSE
          rem0=dzero
        ENDIF
!
        IF(BREL)THEN
          IN1=ICOL(N1,N1,IZERO)
          IN2=ICOL(N2,N2,IZERO)
          DEL=DEY(N1)-DUY(IN1)-(DEY(N2)-DUY(IN2))             ! A.U.
          CALL YLAMKR(MI,M2,DEL,DPA,DP,DD1,DD2,MNH,DHNS,MJH,IZERO)
        ELSE
          CALL YLAMK(MI,M2,DPA,DP,DD1,DD2,MNH,DHNS,MJH,IZERO)
        ENDIF
!
        IF(IPOLF2.GT.0.AND.MI.EQ.1)THEN         !DIELECTRIC POLARIZATION
          IF(IPOLF2.EQ.1)THEN
            DO I=1,MAXRS
              DPA(I)=DPOL1(DX(I))*DPA(I)          !DPNL(I,N1)*DPNL(I,N2)
            ENDDO
          ELSEIF(IPOLF2.EQ.2)THEN
            DO I=1,MAXRS
              DPA(I)=DPOL2(DX(I))*DPA(I)          !DPNL(I,N1)*DPNL(I,N2)
            ENDDO
          ELSE
            STOP 'SR.SLATR: HERE BE MONSTERS - 1'
          ENDIF
          CALL WEDDLE(DZERO,DPA,DPOLA,MNH,DHNS,MJH,MAXRS)
        ENDIF
!
        if(rem0.ne.dzero)then
          if(rem.eq.dzero)then                    !exchange
            ovlp=dd1
            rem=rem0
          else                                    !direct
            ovlp=dzero
          endif
          ovlp00=ovlp
        endif
!
        if(rem.ne.rem0)stop 'slatr: rem.ne.rem0...'
        rem00=rem
!
        IF(.NOT.BXTRP.OR.MI.EQ.0)GO TO 50
!
!  EVALUATE LONG-RANGE INTEGRAL
!
        DTH=DX(MAXRS)-DX(MXRM)
        DD1=DPNL(MXRM,N1)
        DD2=DPNL(MAXRS,N1)
        DD3=DPNL(MXRM,N2)
        DD4=DPNL(MAXRS,N2)
        DX1=DX(MAXRS)
        TM=SCREEN(N1)
        TN=SCREEN(N2)
        DE=DTWO*DYY(NREL)
        IF(.NOT.BDR)DE=DE+DSHIFT(N1)*DTWO
        DS=DONE
        IF(IYY(N1).LT.0)THEN
          DE=DZERO
          DS=-QN(N1)
          DS=DS-TM
          DS=DZA*DZA/(PIH*DS**3)
        ENDIF
        DC=-QN(N2)
        DC=DC-TN
        DC=DZA*DZA/(PIH*DC**3)
        DNORM=DS*DC
        DNORM=SQRT(DNORM)
!        dnorm=1             !<<<<<<<<<<<<<<<<<<<<<<<<<<<<TEST CONT-CONT
        ML1=QL(N1)/2
        DS=ML1*(ML1+1)
        ML2=QL(N2)/2
        DC=ML2*(ML2+1)
        MN=-MI-1
!
        CALL ASS2X(DX1,DTH,DX2,DD1,DD2,DD3,DD4,DE,DZERO,DS,DC,DZERO,    &
     &             DZERO,DZERO,DZERO,DZA,MN,REM2)
!
        CALL ASSX(DX2,MN,TM,TN,DE,DZERO,DZA,ML1,ML2,DS,DC,DZERO,DZERO,  &
     &            DZERO,DZERO,REM)
!
        REM=REM*DNORM
!
!        SUM=REM2+REM
!        WRITE(MW6,1111)DX1,REM2,DX2,REM,SUM
!1111    FORMAT(5F12.6)
!
        REM=REM2+REM
!
! INNER LOOP OVER ALL INTGERALS UTILIZING THIS YLAMK
!
   50   DO L=J,IRL
!
          IF(QRL(1,L).NE.N1)GO TO 100
          IF(QRL(3,L).NE.N2)GO TO 100
          IF(QRL(5,L).NE.JJ)GO TO 100
          M1=QRL(2,L)
          M2=QRL(4,L)
          IF(M2.LE.ABS(MPSEUD))GO TO 100
          IF(IYY(M1).GT.0.AND.MODE.LE.2)GO TO 150             !CONT-CONT
!
          IF(BREL2)THEN
            IF(MI.EQ.0)THEN
              DO I=1,MAXRS
                DUM4(I)=DPNL(I,M1)*DPNL(I,M2)+DQNL(I,M1)*DQNL(I,M2)
                DPA(I)=DUM4(I)*DP(I)
              ENDDO
            ELSE
              DO I=1,MAXRS
                DUM4(I)=DPNL(I,M1)*DPNL(I,M2)+DQNL(I,M1)*DQNL(I,M2)
                DPA(I)=DUM4(I)*(DP(I)+REM*DX(I)**MI)
              ENDDO
            ENDIF
          ELSE
            IF(MI.EQ.0)THEN
              DO I=1,MAXRS
                DUM4(I)=DPNL(I,M1)*DPNL(I,M2)
                DPA(I)=DUM4(I)*DP(I)
              ENDDO
            ELSE
              DO I=1,MAXRS
                DUM4(I)=DPNL(I,M1)*DPNL(I,M2)
                DPA(I)=DUM4(I)*(DP(I)+REM*DX(I)**MI)
              ENDDO
            ENDIF
          ENDIF
!
          CALL WEDDLE(DZERO,DPA,SUM,MNH,DHNS,MJH,MAXRS)
!
          if(rem00.ne.dzero)then
            rem=rem00
            if(ival(n2).gt.0)then                                !direct
! only uncomment to test ovlp0, and *uncomment* duy skip in sr.radcon
!test          call weddle(dzero,dum4,ovlp0,mnh,dhns,mjh,maxrs)!e.g.rlx2
!t              sum=sum+rem   !*ovlp0   !subtract any divergent monopole
            elseif(ival(m1).gt.0)then                          !exchange
!              write(6,*)'SLATR: ',mi,n1,m1,n2,m2
              ovlp=ovlp00
              call weddle(dzero,dum4,ovlp0,mnh,dhns,mjh,maxrs)
              do i=1,maxrs
                dpa(i)=dum4(i)*dl2(i)
              enddo
              call weddle(dzero,dpa,rem0,mnh,dhns,mjh,maxrs)
              rem0=-rem0/(dl2(maxrs)*dx(maxrs))       !a.u. per electron
!              write(mw6,*)ovlp,rem0,ovlp0,rem
              xovlp=ovlp*rem0+ovlp0*rem
              xovlp=xovlp/dtwo                                  !average
              sum=sum+xovlp
              ovlp=ovlp*ovlp0
              im1=icol(m1,m1,izero)
              im2=icol(m2,m2,izero)
              dex=dey(n1)-duy(in1)-(dey(n2)-duy(in2))           ! a.u.
              dex=dey(m1)-duy(im1)-(dey(m2)-duy(im2))+dex       ! a.u.
              dex=-dex/dtwo                                     !average
!              write(mw6,*)sum,ovlp,dex,sum+ovlp*dex
              sum=sum+ovlp*dex
            endif
          endif
!
          SUM=SUM*SCALER                      !COWAN SLATER SCALE FACTOR
!
          IF(IPOLF2.GT.0.AND.MI.EQ.1)THEN       !DIELECTRIC POLARIZATION
            IF(IPOLF2.EQ.1)THEN
              DO I=1,MAXRS
                DPA(I)=DPOL1(DX(I))*DUM4(I)       !DPNL(I,M1)*DPNL(I,M2)
              ENDDO
            ELSEIF(IPOLF2.EQ.2)THEN
              DO I=1,MAXRS
                DPA(I)=DPOL2(DX(I))*DUM4(I)       !DPNL(I,M1)*DPNL(I,M2)
              ENDDO
            ELSE
              STOP 'SR.SLATR: HERE BE MONSTERS - 2'
            ENDIF
            CALL WEDDLE(DZERO,DPA,DPOLB,MNH,DHNS,MJH,MAXRS)
!            write(mw0,*)(qrl(i,l),i=1,5),sum,alav*dpola*dpolb
            SUM=SUM-ALAV*DPOLA*DPOLB
          ENDIF
!
          OVL=DONE
          IF(IRLX.EQ.2)THEN     !OVERLAPS
            KF=IGRCF(N1)
            KG=IGRCF(N2)
            IF(KG.EQ.0)KG=IGRCF(M1)
            IF(KF.NE.KG.AND.KG.GT.0)THEN
              K1=MIN(KF,KG)
              K2=MAX(KF,KG)
              KK=((K2-1)*(K2-2))/2+K1
              OVL=OVLPCF(KK)
              IF(IPAIR(KK).EQ.1)THEN   !SURELY THIS CAN BE SIMPLIFIED...
                IF(IEQ(N1).EQ.IEQ(N2))THEN
                  K=((N1-1)*(N1-2))/2+N2
                ELSEIF(IEQ(M1).EQ.IEQ(M2))THEN
                  IF(IGRCF(M1).EQ.0)GO TO 60
                  K=((M1-1)*(M1-2))/2+M2
                ELSEIF(KF.NE.IGRCF(M1))THEN
                  IF(IEQ(N1).EQ.IEQ(M1))THEN
                    K=((N1-1)*(N1-2))/2+M1
                  ELSEIF(IEQ(M2).EQ.IEQ(N2))THEN
                    IF(IGRCF(M2).EQ.0)GO TO 60
                    K1=MIN(M2,N2)
                    K2=MAX(M2,N2)
                    K=((K2-1)*(K2-2))/2+K1
                  else
                    write(mw6,*)'slater: why are we here?',kf,kg,n1,m1, &
     &                          n2,m2
                    write(mw0,*)'slater: why are we here?'
                    nf=-1
                    go to 200                                    !return
                  ENDIF
                ELSE
                  IF(IEQ(N1).EQ.IEQ(M2))THEN
                    K=((N1-1)*(N1-2))/2+M2
                  ELSEIF(IEQ(M1).EQ.IEQ(N2))THEN
                    K1=MIN(M1,N2)
                    K2=MAX(M1,N2)
                    K=((K2-1)*(K2-2))/2+K1
                  else
                    write(mw6,*)'slater: why are we here?',kf,kg,n1,m1, &
     &                          n2,m2
                    write(mw0,*)'slater: why are we here?'
                    nf=-1
                    go to 200                                    !return
                  ENDIF
                ENDIF
                OVL=OVL/OVLPGR(K)
              ENDIF
            ENDIF
          ENDIF
!
   60     DRL(L)=SUM*OVL
!
          IF(BCONT)THEN                               !BOUND-CONT INTERP
            KK=NRLI(L)
            IF(KK.GT.0)THEN
              IF(IRLX.EQ.2)THEN
                DO I=1,MENG
                  DRLI(I,KK)=DRLI(I,KK)*OVL
                ENDDO
              ENDIF
              DRLI(NREL,KK)=DRL(L)
            ENDIF
          ELSE
            KK=0
          ENDIF
!
!  EVALUATE TWO-BODY NON-FINE-STRUCTURE INTEGRALS, CONVERT ZL,X2 TO A.U.
!
          IF(BKUTOO)THEN
            DZL(L)=DZERO
            DXTWO(L)=DZERO
            DETA(L)=DZERO
            IF(KUTOO.NE.88)THEN
              CALL XTWOO(MI,N1,M1,N2,M2,TXTWOO)
              DXTWO(L)=TXTWOO*OVL
            ENDIF
            IF(KUTOO.NE.99)THEN
              CALL ZLAM(MI,N1,M1,N2,M2,TZLAM)
              DZL(L)=TZLAM*OVL
              IF(KUTOO.LT.98.OR.L.LE.NAD(0))THEN
                CALL ELAM(MI,N1,M1,N2,M2,TELAM)
                DETA(L)=TELAM*OVL
              ENDIF
            ENDIF
            DZL(L)=DZL(L)/DTWO
            DXTWO(L)=DXTWO(L)/DTWO
! JONES                       DONE
            IF(KK.GT.0)THEN
              IF(IRLX.EQ.2)THEN
                DO I=1,MENG
                  DZLI(I,KK)=DZLI(I,KK)*OVL
                  DXTWOI(I,KK)=DXTWOI(I,KK)*OVL
                  DETAI(I,KK)=DETAI(I,KK)*OVL
                ENDDO
              ENDIF
              DZLI(NREL,KK)=DZL(L)
              DXTWOI(NREL,KK)=DXTWO(L)
              DETAI(NREL,KK)=DETA(L)
            ENDIF
          ENDIF
!
  100   ENDDO                    ! *** END INNER SLATER LOOP
!
  150   IF(BPRNT0)THEN
          IF(BCONT)THEN
            KK=NRLI(J)
            IF(KK.EQ.0)WRITE(MW6,10050)J,(QRL(I,J),I=1,5),DRL(J)
            IF(KK.GT.0)WRITE(MW6,10050)J,(QRL(I,J),I=1,5),              &
     &                                 (DRLI(IC,KK),IC=1,MENG)
          ELSE
            KK=0
            WRITE(MW6,10050)J,(QRL(I,J),I=1,5),DRL(J)
          ENDIF
          IF(BKUTOO)THEN
            IF(KK.EQ.0)WRITE(MW6,10060)DXTWO(J),DZL(J),DETA(J)
            IF(KK.GT.0)THEN
              WRITE(MW6,10060)(DXTWOI(IC,KK),IC=1,MENG)
              WRITE(MW6,10060)(DZLI(IC,KK),IC=1,MENG)
              WRITE(MW6,10060)(DETAI(IC,KK),IC=1,MENG)
            ENDIF
          ENDIF
        ENDIF
!
      ENDDO                      ! *** END OUTER SLATER LOOP
!
!-----------------------------------------------------------------------
!
  200 CONTINUE
!
! LOCAL
      DEALLOCATE(DPA,DP,DUM4,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SLATR: DE-ALLOCATION FAILS FOR DPA,DP,DUM4'
        IF(NF.GT.0)NF=0
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(' *****STORAGE EXCEEDED IN SR.SLATER, INCREASE MXFSL TO ', &
     &       I5)
10020 FORMAT(/'   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>)')
10030 FORMAT(//'   I(R)   R(  A,  B,   C,  D, 2LBD ) = SLATER-INTEGRALS'&
     &       ,': BELOW IS 0.5*TWO-BODY NON-FINE-STRUCTURE INTEGRALS',   &
     &       ' (2LBD+1)*X2, ZLBD, ETALBD.')
10040 FORMAT(//' *** COWAN SLATER INTEGRAL SCALE FACTOR: ',F7.4)
10050 FORMAT(I7,3X,2(I5,I4),I6,7F14.7,1X/(34X,7F14.7))
10060 FORMAT(34X,7F14.7,1X/(34X,7F14.7))
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!-----------------------------------------------------------------------
      FUNCTION DPOL1(X)
!
      REAL(WP) X,DPOL1
!
      DPOL1=SQRT(DONE-EXP(-(X/RCAV)**6))/X**2
!
      END FUNCTION DPOL1
!-----------------------------------------------------------------------
      FUNCTION DPOL2(X)
!
      REAL(WP) X,DPOL2
!
      DPOL2=X/((X*X+RCAV*RCAV)*SQRT(X*X+RCAV*RCAV))
!
      END FUNCTION DPOL2
!-----------------------------------------------------------------------
!
      END SUBROUTINE SLATR
!
!                             *******************
!
      SUBROUTINE SLATRI(ICOUNT,N,KK,FR,GR,TM)
!
!-----------------------------------------------------------------------
!
!  SR.SLATRI CALCULATES SLATER INTEGRALS INVOLVING CONTINUUM FUNCTIONS
!  (ORBITAL N) AT THE ICOUNT'TH INTERPOLATION ENERGY, INDEXED BY KK,
!  AND (IF BKUTOO) 2-BODY NON-FINE STRUCTURE INTEGRALS.
!
!  IT IS CALLED BY:
!    SR.RADCON
!
!  IT CALLS:
!    SR.ASSX
!    SR.ASS2X
!    SR.WEDDLE
!    SR.YLAMKR
!    SR.YLAMK
!    SR.ELAM
!    SR.XTWOO
!    SR.ZLAM
!
!  IT CONTAINS:
!    FN.ICOL
!    FN.DPOL1
!    FN.DPOL2
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DXRL,   ONLY: QRL,IRL
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_GENINF, ONLY: SCALER
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD,KORT
      USE COMMON_NRBAL2, ONLY: MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,VSC,XC1,XC2,NPITER
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBINT, ONLY: DRLI,DYY,IYY,NRLI,MENG,NREL,NLAG,NLAGP   &
     &                        ,BLAG,BBC2
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBNFI, ONLY: DZLI,DXTWOI,DETAI,FRI,GRI
      USE COMMON_NRBPOT, ONLY: DL2=>DPOT,TOL,MEND
      USE COMMON_NRBPOT, ONLY: POTHAM,MPSEUD
      USE COMMON_NRBPOT, ONLY: ALFD,RCUT,ALAV,RCAV,IPOLFN
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBVAL, ONLY: FACT,IVAL,NNEW,NNOLD,BJUMP,BJUMP2,BRAD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION FR(*),GR(*)
!
      ALLOCATABLE :: DA(:),DP(:),DUM4(:)
!
      SAVE DEHLD
!
!-----------------------------------------------------------------------
!      DPOL1(X)=SQRT(DONE-EXP(-(X/RCAV)**6))/X**2
!      DPOL2(X)=X/((X*X+RCAV*RCAV)*SQRT(X*X+RCAV*RCAV))
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!
! THE NAMES HERE ARE NOT NECESSARILY SIGNIFICANT THEY ARE COMMON LEGACY.
!
! LOCAL
      ALLOCATE(DA(MAXRS),DP(MAXRS),DUM4(MAXRS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SLATRI: ALLOCATION FAILS FOR DA,DP,DUM4'
        NF=0
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
      PI=ACOS(-DONE)
      PIH=PI/DTWO
!
      BREL2=ABS(IREL).EQ.2
      BORT=MORT.LT.0
      BKUTOO=KUTOO.NE.0
      IPOLF2=IPOLFN/10
      MDEN10=MOD(MDEN,ITEN)
      MXRM=MAXRS-1
!
      DRY=DYY(ICOUNT)*DTWO
!
      DZ=NZION
      DZA=MION-NZION-1
!
      IF(BKUTOO)THEN                 !SWAP CONTINUUM FR->DPNL
        IF(ICOUNT.EQ.1.OR.NREL.EQ.1.AND.ICOUNT.EQ.2)THEN
                                                        !BACK-UP NREL'TH
          DEHLD=DEY(N)
          DEY(N)=DRY/DTWO
          DO I=1,MAXRS
            FRI(I)=DPNL(I,N)
            DPNL(I,N)=FR(I)
            GRI(I)=DQNL(I,N)
            DQNL(I,N)=GR(I)
          ENDDO
        ELSE                         !JUST LOAD NEW CONTINUUM
          DEY(N)=DRY/DTWO
          DO I=1,MAXRS
            DPNL(I,N)=FR(I)
            DQNL(I,N)=GR(I)
          ENDDO
        ENDIF
      ENDIF
!
      DO J=1,IRL
!
        KP=NRLI(J)
!  ****TEST                                       108
        IF(KP.GT.0)then                   !.AND. for stupid compilers
          if(DRLI(ICOUNT,KP).NE.DZERO)GO TO 300
        endif
        IF(QRL(5,J).GT.2*MAXLAM)GO TO 300
        N1=QRL(1,J)
!
! FALLING ORDER MEANS THAT IF 'A' IS NOT *THE* CONTINUUM ORBITAL N
! THEN NEITHER IS 'B,C OR D'.  SLATER INTEGRAL (A,B,C,D)
!
        IF(N1.NE.N)GO TO 300
        N2=QRL(3,J)
        IF(IYY(N2).GT.0.AND.MODE.LE.2)GO TO 300
!
        IF(QRL(5,J).GE.0)GO TO 200
!
! ONE-BODY INTEGRALS
!
        SUM=DZERO
        IF(.NOT.BLAG)GO TO 150
!
! must uncomment skip if calculating "duy" below - see also slatr/radcon
!t        if(kort.lt.0.and.ival(n2).gt.0)go to 150             !cont-ryd
!
        IF(.NOT.BORT)GO TO 50
        IF(BREL2)GO TO 50                                          !BREL
        IF(MORT.EQ.-3.AND.BREL)GO TO 50
!
        DO I=1,MAXRS
          DP(I)=DQNL(I,N2)*FR(I)
        ENDDO
        IF((MDEN.EQ.11.OR.MDEN.EQ.1.AND.NPITER.LT.0).AND.DENE.GT.DZERO) &
     &     THEN                                                !PERT DH1
          DO I=1,MAXRS
            T=EXP(-DX(I)/DEBYE)
            DP(I)=DP(I)+DTWO*DPNL(I,N2)*FR(I)*(DONE-T)*DZ/DX(I)
          ENDDO
        ELSE
          DO I=1,MAXRS
            DP(I)=DP(I)-DTWO*DPNL(I,N2)*FR(I)*VSC(I)
          ENDDO
        ENDIF
        IF(MPSEUD.NE.0)THEN
          DO I=1,MAXRS
            DP(I)=DP(I)+DTWO*DPNL(I,N2)*FR(I)*(DZ/DX(I)-POTHAM(I))
          ENDDO
        ENDIF
        GO TO 100
!
   50   IF(BREL2)THEN
          DO I=1,MAXRS
            DP(I)=(DPNL(I,N2)*FR(I)+DQNL(I,N2)*GR(I))*DL2(I)
          ENDDO
        ELSE
          DO I=1,MAXRS
            DP(I)=DPNL(I,N2)*FR(I)*DL2(I)
          ENDDO
        ENDIF
        IF((MDEN.EQ.11.OR.MDEN.EQ.1.AND.NPITER.LT.0).AND.DENE.GT.DZERO) &
     &     THEN                                                !PERT DH1
          DO I=1,MAXRS
            T=EXP(-DX(I)/DEBYE)
            DP(I)=DP(I)+DTWO*DP(I)*((DONE-T)*DZ/DX(I)+VSC(I))/DL2(I)
          ENDDO
!        ELSEIF(MDEN10.EQ.2)THEN                           !IS NO 2-BODY
        ENDIF
        IF(MPSEUD.NE.0)THEN
          DO I=1,MAXRS
            DP(I)=DP(I)+DTWO*DP(I)*(DZ/DX(I)-POTHAM(I))/DL2(I)
          ENDDO
        ENDIF
!
  100   CALL WEDDLE(DZERO,DP,SUM,MNH,DHNS,MJH,MAXRS)
!
  150   IF(KP.LE.0)THEN
          KK=KK+1
          IF(KK.GT.IXFSL)GO TO 300
          KP=KK
          NRLI(J)=KK
        ENDIF
!
        DRLI(ICOUNT,KP)=SUM/DTWO
!
        GO TO 300                                      ! ****  TEST  108
!
! TWO-BODY INTEGRALS
!
  200   BCALC=.FALSE.
        MJ=(QL(N1)+QL(N2))/2+2
        JJ=QRL(5,J)
        MI=JJ/2
!
        DO L=J,IRL                                     !START YLAMK LOOP
!
          IF(QRL(1,L).NE.N1)GO TO 250
          IF(QRL(3,L).NE.N2)GO TO 250
          IF(QRL(5,L).NE.JJ)GO TO 250
          M1=QRL(2,L)
          IF(IYY(M1).GT.0.AND.MODE.LE.2)GO TO 250             !CONT-CONT
!
          SUM=DZERO
          IF(.NOT.BLAG)GO TO 240
          M2=QRL(4,L)
!          write(6,*)'SLATRI ',icount,'  ',jj/2,n1,m1,n2,m2,rem00,ovlp00
!
          IF(BCALC)GO TO 220
          BCALC=.TRUE.
!
! CALCULATE YLAMDA
!
          IF(BREL2)THEN
            DO I=1,MAXRS
              DP(I)=FR(I)*DPNL(I,N2)+GR(I)*DQNL(I,N2)
            ENDDO
          ELSE
            DO I=1,MAXRS
              DP(I)=FR(I)*DPNL(I,N2)
            ENDDO
          ENDIF
!
! LOOK FOR POSSIBLE RYD-CONT EXCHANGE OVERLAP.
! FOR EFFICIENCY, USER SHOULD NOT SWITCH ON IF NO RYD PRESENT.
!
          REM=DZERO
!
          IF(KORT.LT.0.AND.JJ.EQ.0)THEN
            do i=1,maxrs
              da(i)=dp(i)*dl2(i)
            enddo
            call weddle(dzero,da,rem0,MNH,dhns,mjh,maxrs)
            rem0=-rem0/(dl2(maxrs)*dx(maxrs))         !a.u. per electron
            if(ival(n2).gt.0)rem=rem0                            !direct
          ELSE
            rem0=dzero
          ENDIF
!
          IF(BREL)THEN
            IN2=ICOL(N2,N2,IZERO)
            DEL=DEY(N2)-DUY(IN2)-DRY/DTWO  ! A.U. SIGN DOES NOT MATTER
            CALL YLAMKR(MI,MJ,DEL,DP,DA,DD1,DD2,MNH,DHNS,MJH,IZERO)
          ELSE
            CALL YLAMK(MI,MJ,DP,DA,DD1,DD2,MNH,DHNS,MJH,IZERO)
          ENDIF
!
          IF(IPOLF2.GT.0.AND.MI.EQ.1)THEN       !DIELECTRIC POLARIZATION
            IF(IPOLF2.EQ.1)THEN
              DO I=1,MAXRS
                DP(I)=DPOL1(DX(I))*DP(I)          !DPNL(I,N1)*DPNL(I,N2)
              ENDDO
            ELSEIF(IPOLF2.EQ.2)THEN
              DO I=1,MAXRS
                DP(I)=DPOL2(DX(I))*DP(I)          !DPNL(I,N1)*DPNL(I,N2)
              ENDDO
            ELSE
              STOP 'SR.SLATRI: HERE BE MONSTERS - 1'
            ENDIF
            CALL WEDDLE(DZERO,DP,DPOLA,MNH,DHNS,MJH,MAXRS)
          ENDIF
!
          if(rem0.ne.dzero)then
            if(rem.eq.dzero)then                    !exchange
              ovlp=dd1
              rem=rem0
            else                                    !direct
              ovlp=dzero
            endif
            ovlp00=ovlp
          endif
!
          if(rem.ne.rem0)stop 'slatri: rem.ne.rem0...'
          rem00=rem
!
          IF(MI.EQ.0.OR.QN(N2).GT.0)GO TO 220
!
! LONG-RANGE INTEGRAL LAMBDA .GT. 0
!
          DX1=DX(MAXRS)
          DT=DX(MAXRS)-DX(MXRM)
          DD=FR(MXRM)
          TN=FR(MAXRS)
          DD1=DPNL(MXRM,N2)
          DD2=DPNL(MAXRS,N2)
          DE=DRY
          ML1=QL(N1)/2
          DS=ML1*(ML1+1)
          ML2=QL(N2)/2
          DC=ML2*(ML2+1)
          MN=-MI-1
!
          CALL ASS2X(DX1,DT,DX2,DD,TN,DD1,DD2,DE,DZERO,DS,DC,DZERO,     &
     &               DZERO,DZERO,DZERO,DZA,MN,REM2)
!
          TN=SCREEN(N2)
!
          CALL ASSX(DX2,MN,TM,TN,DE,DZERO,DZA,ML1,ML2,DS,DC,DZERO,DZERO,&
     &              DZERO,DZERO,REM)
!
          DNORM=-QN(N2)
          DNORM=DNORM-TN
          DNORM=DZA*DZA/(PIH*DNORM**3)
          DNORM=SQRT(DNORM)
!          dnorm=1           !<<<<<<<<<<<<<<<<<<<<<<<<<<<<TEST CONT-CONT
          REM=REM*DNORM
!
!****TEST
!     IF(BREL2)THEN
!       DO I=1,MAXRS
!         DP(I)=(FR(I)*DPNL(I,N2)+GR(I)*DQNL(I,N2))*DX(I)**MN
!       ENDDO
!     ELSE
!       DO I=1,MAXRS
!         DP(I)=FR(I)*DPNL(I,N2)*DX(I)**MN
!       ENDDO
!     ENDIF
!     CALL WEDDLE(DZERO,DP,DD,MNH,DHNS,MJH,MAXRS)
!      SUM=DD+REM2+REM
!     WRITE(MW6,1111)DD,DX1,REM2,DX2,REM,SUM
!1111 FORMAT(6F12.6)
!
          REM=REM2+REM
!
! CALCULATE SLATER INTEGRAL
!
  220     IF(BREL2)THEN
            IF(MI.EQ.0)THEN
              DO I=1,MAXRS
                DUM4(I)=DPNL(I,M1)*DPNL(I,M2)+DQNL(I,M1)*DQNL(I,M2)
                DP(I)=DUM4(I)*DA(I)
              ENDDO
            ELSE
              DO I=1,MAXRS
                DUM4(I)=DPNL(I,M1)*DPNL(I,M2)+DQNL(I,M1)*DQNL(I,M2)
                DP(I)=DUM4(I)*(DA(I)+REM*DX(I)**MI)
              ENDDO
            ENDIF
          ELSE
            IF(MI.EQ.0)THEN
              DO I=1,MAXRS
                DUM4(I)=DPNL(I,M1)*DPNL(I,M2)
                DP(I)=DUM4(I)*DA(I)
              ENDDO
            ELSE
              DO I=1,MAXRS
                DUM4(I)=DPNL(I,M1)*DPNL(I,M2)
                DP(I)=DUM4(I)*(DA(I)+REM*DX(I)**MI)
              ENDDO
            ENDIF
          ENDIF
!
          CALL WEDDLE(DZERO,DP,SUM,MNH,DHNS,MJH,MAXRS)
!
          if(rem00.ne.dzero)then
            rem=rem00
            if(ival(n2).gt.0)then                                !direct
! only uncomment to test ovlp0, and *uncomment* duy skip above
!test          call weddle(dzero,dum4,ovlp0,mnh,dhns,mjh,maxrs)!e.g.rlx2
!t              sum=sum+rem   !*ovlp0   !subtract any divergent monopole
            elseif(ival(m1).gt.0)then                          !exchange
!              write(6,*)'slatri: ',icount,'    ',mi,n1,m1,n2,m2
              ovlp=ovlp00
              call weddle(dzero,dum4,ovlp0,mnh,dhns,mjh,maxrs)
              do i=1,maxrs
                dp(i)=dum4(i)*dl2(i)
              enddo
              call weddle(dzero,dp,rem0,mnh,dhns,mjh,maxrs)
              rem0=-rem0/(dl2(maxrs)*dx(maxrs))       !a.u. per electron
!              write(mw6,*)ovlp,rem0,ovlp0,rem
              xovlp=ovlp*rem0+ovlp0*rem
              xovlp=xovlp/dtwo                                  !average
              sum=sum+xovlp
              ovlp=ovlp*ovlp0
              im1=icol(m1,m1,izero)
              im2=icol(m2,m2,izero)
              dex=dyy(icount)-(dey(n2)-duy(in2))         ! a.u.
              dex=dey(m1)-duy(im1)-(dey(m2)-duy(im2))+dex     ! a.u.
              dex=-dex/dtwo                                    !average
!              write(mw6,*)sum,ovlp,dex,sum+ovlp*dex
              sum=sum+ovlp*dex
            endif
          endif
!
          SUM=SUM*SCALER                      !COWAN SLATER SCALE FACTOR
!
          IF(IPOLF2.GT.0.AND.MI.EQ.1)THEN       !DIELECTRIC POLARIZATION
            IF(IPOLF2.EQ.1)THEN
              DO I=1,MAXRS
                DP(I)=DPOL1(DX(I))*DUM4(I)       !DPNL(I,M1)*DPNL(I,M2)
              ENDDO
            ELSEIF(IPOLF2.EQ.2)THEN
              DO I=1,MAXRS
                DP(I)=DPOL2(DX(I))*DUM4(I)       !DPNL(I,M1)*DPNL(I,M2)
              ENDDO
            ELSE
              STOP 'SR.SLATRI: HERE BE MONSTERS - 2'
            ENDIF
            CALL WEDDLE(DZERO,DP,DPOLB,MNH,DHNS,MJH,MAXRS)
!            write(mw0,*)icount,(qrl(i,l),i=1,5),sum,alav*dpola*dpolb
            SUM=SUM-ALAV*DPOLA*DPOLB
          ENDIF
!
!
  240     KP=NRLI(L)
          IF(KP.LE.0)THEN
            KK=KK+1
            IF(KK.GT.IXFSL)GO TO 250
            KP=KK
            NRLI(L)=KK
          ENDIF
!
          DRLI(ICOUNT,KP)=SUM
!
!  EVALUATE TWO-BODY NON-FINE-STRUCTURE INTEGRALS, CONVERT ZL,X2 TO A.U.
!
          IF(BKUTOO)THEN
            DZLI(ICOUNT,KP)=DZERO
            DXTWOI(ICOUNT,KP)=DZERO
            DETAI(ICOUNT,KP)=DZERO
            IF(KUTOO.NE.88)THEN
              CALL XTWOO(MI,N1,M1,N2,M2,TXTWOO)
              DXTWOI(ICOUNT,KP)=TXTWOO
            ENDIF
            IF(KUTOO.NE.99)THEN
              CALL ZLAM(MI,N1,M1,N2,M2,TZLAM)
              DZLI(ICOUNT,KP)=TZLAM
              IF(KUTOO.LT.98)THEN
                CALL ELAM(MI,N1,M1,N2,M2,TELAM)
                DETAI(ICOUNT,KP)=TELAM
              ENDIF
            ENDIF
            DZLI(ICOUNT,KP)=DZLI(ICOUNT,KP)/DTWO
            DXTWOI(ICOUNT,KP)=DXTWOI(ICOUNT,KP)/DTWO  !  /DONE     JONES
          ENDIF
!
  250   ENDDO                                            !END YLAMK LOOP
!
!
! **TEST PRINT
! 108 KP=NRLI(J)
!     WRITE(MW6,701)J,(QRL(I,J),I=1,5),DRLI(ICOUNT,KP)
! 701 FORMAT(I5,3X,2(I4,I5),I6,F14.7)
!
!
  300 ENDDO                                    !END SLATER INTEGRAL LOOP
!
      IF(BKUTOO)THEN              !SWAP CONTINUUM BACK, IF LAST TIME
        IF(ICOUNT.EQ.MENG.OR.NREL.EQ.MENG.AND.ICOUNT.EQ.MENG-1)THEN
          DEY(N)=DEHLD
          DO I=1,MAXRS
            DPNL(I,N)=FRI(I)
            DQNL(I,N)=GRI(I)
          ENDDO
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
! LOCAL
      DEALLOCATE(DA,DP,DUM4,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SLATRI: DE-ALLOCATION FAILS FOR DA,DP,DUM4'
        NF=0
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!-----------------------------------------------------------------------
      FUNCTION DPOL1(X)
!
      REAL(WP) X,DPOL1
!
      DPOL1=SQRT(DONE-EXP(-(X/RCAV)**6))/X**2
!
      END FUNCTION DPOL1
!-----------------------------------------------------------------------
      FUNCTION DPOL2(X)
!
      REAL(WP) X,DPOL2
!
      DPOL2=X/((X*X+RCAV*RCAV)*SQRT(X*X+RCAV*RCAV))
!
      END FUNCTION DPOL2
!-----------------------------------------------------------------------
!
      END SUBROUTINE SLATRI
!
!                             *******************
!
      SUBROUTINE SLATRX(FRX,PSHFTX,MDIM1,MDIM2,MDIM3                    &
     &                 ,DRL,DZL,DXTWO,DETA                              &
     &                 ,M1,M2,LNEW,MPOSC)
!
!-----------------------------------------------------------------------
!
!  SR.SLATRX CALCULATES/UPDATES THE DEIE SLATER INTEGRALS (INCLUDING THE
!  EXCHANGE OVERLAP) AND (IF BKUTOO) 2-BODY NON-FINE STRUCTURE INTEGRALS
!
!  IT IS CALLED BY:
!    SR.CADWX
!    SR. DWXBP_DAXPY
!    SR. DWXBP_DDOT
!    SR. DWXLS_DAXPY
!    SR. DWXLS_DDOT
!
!  IT CALLS:
!    SR.ELAM
!    SR.LDFGX
!    SR.RKX
!    SR.XTWOO
!    SR.YLAMKX
!    SR.ZLAM
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_DXRL,   ONLY: QRL,IRLAST               !,IRL !IS GLOBAL
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD,KORT
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDWP, ONLY: SCALERX
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
      USE COMMON_NRBDW5, ONLY: DYY,MENG,NLAG
      USE COMMON_NRBDW6, ONLY: QPOS,QPOS0
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION FRX(MDIM1,MDIM2,MDIM3),PSHFTX(MDIM2,MDIM3)              &
     &         ,DRL(*),DZL(*),DXTWO(*),DETA(*)
!
      ALLOCATABLE :: DPA(:),DP(:)
!
!-----------------------------------------------------------------------
!
! THE NAMES HERE ARE NOT NECESSARILY SIGNIFICANT THEY ARE COMMON LEGACY.
!
! LOCAL
      ALLOCATE(DPA(MAXRS),DP(MAXRS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SLATRX: ALLOCATION FAILS FOR DPA,DP'
        NF=0
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
      BPRNT0=JPRINT.GE.4                      !FOR DETAILED PRINTOUT
!      BPRNT0=JPRINT.NE.-3
      BKUTOO=KUTOOX.NE.0
      BREL2=ABS(IREL).EQ.2
!
      MAXRS1=MAXRS
      IF(BREL2)MAXRS1=MAXRS1+1
!
      IF(BPRNT0)THEN
        WRITE(MW6,10010)M1,DYY(M1),M2,DYY(M2)
        IF(BKUTOO)WRITE(MW6,10020)
      ENDIF
!
! INITIALIZE
!
      IRL1=IRLAST(LNEW)                              !LOCAL IRL FOR LNEW
      if(irl1.eq.0)write(mw0,*)lnew,irl1
!
      IF(BKUTOO)THEN
        DO L=1,IRL1
          DRL(L)=DZERO
          DXTWO(L)=DZERO
          DZL(L)=DZERO
          DETA(L)=DZERO
        ENDDO
      ELSE
        DO L=1,IRL1
          DRL(L)=DZERO
        ENDDO
      ENDIF
!
      MLAMX2=MXLAMX*2
!
! OUTER LOOP TO DETERMINE SLATER INETGRALS
!
!!      write(63,*)'L=',lnew
!      icountt=0
!
      DO J=1,IRL1
!
        IF(DRL(J).NE.DZERO)GO TO 100
        JJ=QRL(5,J)
        IF(JJ.LT.0)GO TO 100      !NOT NEEDED FOR THIS LTOT (CASE INAST)
!
        N1=QRL(1,J)
        N2=QRL(3,J)
        IF(QL(N1).LT.0)GO TO 100  !NOT NEEDED FOR THIS LTOT (CASE INAST)
        IF(QL(N2).LT.0)GO TO 100  !NOT NEEDED FOR THIS LTOT (CASE INAST)
        n3=n2
!
        BDIR=QN(N2).LT.0                              !DIRECT
!        BEX=.NOT.BDIR                                 !EXCHANGE
!
!        if(abs(ql(n1)-ql(n2)).gt.qrl(5,j).or.ql(n1)+ql(n2).lt.qrl(5,j))
!     & write(63,*)j,ql(n1),ql(n2),qrl(5,j)
!
! DETERMINE YLAMK
!
        Q1=QPOS(N1-MPOSC)
        q1=abs(q1)
        IF(BDIR)THEN
!
          Q2=QPOS(N2-MPOSC)
          q2=abs(q2)
          T1=PSHFTX(M1,Q1)
          T2=PSHFTX(M2,Q2)
          DEL=DYY(M1)-DYY(M2)                         !BREL ONLY
!
          CALL YLAMKX(FRX(1,M1,Q1),FRX(1,M2,Q2),FRX(MAXRS1,M1,Q1),      &
     &                FRX(MAXRS1,M2,Q2),N1,N2,JJ,M1,M2,T1,T2,DEL,DPA,DP,&
     &                DX,DPOLA,REM,ovlp)
!
          IF(BKUTOO)THEN
            if(n1.eq.n2)then                  !same orb. (l) but diff. e
              n2=n1+1-2*((n1-mposc)/lcondwj)
              lhold=ql(n2)
              ql(n2)=ql(n1)
            else
              lhold=ql(n2)
            endif
            CALL LDFGX(M1,N1,FRX(1,M1,Q1),FRX(MAXRS1,M1,Q1),MAXRS,BREL, &
     &                 BREL2)
            CALL LDFGX(M2,N2,FRX(1,M2,Q2),FRX(MAXRS1,M2,Q2),MAXRS,BREL, &
     &                 BREL2)
          ENDIF
!
        ELSE
!
          IF(LNEW.GT.MAXLX.OR.JJ.GT.MLAMX2)GO TO 100
          IN2=ICOL(N2,N2,IZERO)
          DEL=DYY(M1)-(DEY(N2)-DUY(IN2))*DTWO       !RYD
!
          CALL YLAMKX(FRX(1,M1,Q1),DPNL(1,N2),FRX(MAXRS1,M1,Q1),        &
     &                DQNL(1,N2),N1,N2,-JJ,M1,M2,T1,T2,DEL,DPA,DP,DX,   &
     &                DPOLA,REM,ovlp)
!
          IF(BKUTOO)THEN
            CALL LDFGX(M1,N1,FRX(1,M1,Q1),FRX(MAXRS1,M1,Q1),MAXRS,BREL, &
     &                 BREL2)
          ENDIF
!
        ENDIF
!
! INNER LOOP OVER ALL INTGERALS UTILIZING THIS YLAMK
!
!        icount=0
        DO L=J,IRL1
!
          IF(QRL(1,L).NE.N1)GO TO 50
          IF(QRL(3,L).NE.n3)GO TO 50
          IF(QRL(5,L).NE.JJ)GO TO 50
          K1=QRL(2,L)
          K2=QRL(4,L)
          IF(QL(K1).LT.0)GO TO 50 !NOT NEEDED FOR THIS LTOT (CASE INAST)
          IF(QL(K2).LT.0)GO TO 50 !NOT NEEDED FOR THIS LTOT (CASE INAST)
!
! DETERMINE SLATER RK (A.U.)
!
!        if(abs(ql(k1)-ql(k2)).gt.qrl(5,j).or.ql(k1)+ql(k2).lt.qrl(5,j))
!     & write(63,*)j,ql(k1),ql(k2),qrl(5,j)
!
          IF(BDIR)THEN
            rem0=rem
            if(jj.eq.0.and.k1.ne.k2)rem0=dzero          !could test rlx2
            CALL RKX(DPNL(1,K1),DPNL(1,K2),DQNL(1,K1),DQNL(1,K2),JJ,DPA,&
     &               DP,DX,DPOLA,REM0,ovlp,SUM)
!            sum=0.                                             !test ex
          ELSE
            Q2=QPOS(K1-MPOSC)
            q2=abs(q2)
            ovlp0=ovlp
            CALL RKX(FRX(1,M2,Q2),DPNL(1,K2),FRX(MAXRS1,M2,Q2),         &
     &               DQNL(1,K2),-JJ,DPA,DP,DX,DPOLA,REM,ovlp0,SUM)
!                                                   add-in energy factor
!            if(jj.eq.0
!     &                .and.dadjus(k2).gt.dzero            !test
!     &                .and.dadjus(n2).gt.dzero            !exc. pseudos
!     &                                        )then
            IF(KORT.LE.0.AND.JJ.EQ.0)THEN     !finalize exchange overlap
              ik2=icol(k2,k2,izero)
              dex=-dyy(m1)/dtwo+dey(k2)-duy(ik2)-dyy(m2)/dtwo+dey(n2)   &
     &            -duy(in2)                                      !a.u.
              dex=dex/dtwo                                      !average
              sum=sum+ovlp0*dex
!              write(mw6,*)m1,m2,n1,k1,n2,k2,sum-ovlp0*dex,ovlp0,sum
            ENDIF
!            sum=0.                                             !test nx
          ENDIF
!
          IF(NF.LE.0)GO TO 200
!
          DRL(L)=SUM*SCALERX
!
!  EVALUATE TWO-BODY NON-FINE-STRUCTURE INTEGRALS, CONVERT ZL,X2 TO A.U.
!
          IF(BKUTOO)THEN
            IF(.NOT.BDIR)THEN
              if(n1.eq.k1)then                !same orb. (l) but diff. e
                k1=n1+1-2*((n1-mposc)/lcondwj)
                lhold=ql(k1)
                ql(k1)=ql(n1)
              else
                lhold=ql(k1)
              endif
              CALL LDFGX(M2,K1,FRX(1,M2,Q2),FRX(MAXRS1,M2,Q2),MAXRS,    &
     &                   BREL,BREL2)
            ENDIF
            MI=JJ/2
            CALL XTWOO(MI,N1,K1,N2,K2,TXTWOO)
            DXTWO(L)=TXTWOO/DTWO
            CALL ZLAM(MI,N1,K1,N2,K2,TZLAM)
            DZL(L)=TZLAM/DTWO
            CALL ELAM(MI,N1,K1,N2,K2,TELAM)
            DETA(L)=TELAM
            if(.not.bdir)ql(k1)=INT(lhold,QP)
          ENDIF
!
!          icount=icount+1
!
   50   ENDDO                    ! *** END INNER SLATER LOOP
!
        if(bkutoo.and.bdir)ql(n2)=INT(lhold,QP)
!
!        write(63,*)j,icount,bdir
!        call flush(63)
!        icountt=icountt+icount
!
  100   IF(BPRNT0)THEN
          TEST=DRL(J)
          IF(BKUTOO)TEST=TEST+DXTWO(J)+DZL(J)+DETA(J)
          IF(TEST.NE.DZERO)WRITE(MW6,10030)J,(QRL(I,J),I=1,5),DRL(J)
          IF(BKUTOO)WRITE(MW6,10040)DXTWO(J),DZL(J),DETA(J)
        ENDIF
!
      ENDDO                      ! *** END OUTER SLATER LOOP
!
!      write(63,*)'icountt=',icountt
!
!-----------------------------------------------------------------------
!
  200 CONTINUE
!
! LOCAL
      DEALLOCATE(DPA,DP,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SLATRX: DE-ALLOCATION FAILS FOR DPA,DP'
        IF(NF.GT.0)NF=0
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(/'   I(R)   R(  A,  B,   C,  D, 2LBD ) = SLATER-INTEGRALS',&
     &       3X,'FOR    E(',I2,')=',F10.3,5X,'E(',I2,')=',F10.3,'  RYD')
10020 FORMAT(                                                           &
     &': BELOW IS 0.5*TWO-BODY NON-FINE-STRUCTURE INTEGRALS (2LBD+1)*X2'&
     &,', ZLBD, ETALBD.')
10030 FORMAT(I7,3X,2(I5,I4),I6,7F14.7,1X/(34X,7F14.7))
10040 FORMAT(34X,7F14.7,1X/(34X,7F14.7))
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE SLATRX
!
!                             *******************
!
      SUBROUTINE SO2NL(K,N,L)
!
!-----------------------------------------------------------------------
!
! RETURN N AND L VALUES FOR A STANDARD ORDER ORBITAL INDEX K
!
!  IT IS CALLED BY:
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
      TN=1+8*K
      TN=SQRT(TN)
      N=INT((TN-DONE)/DTWO+DONE-D1M4)
      L=K-(N*(N-1))/2-1
!
      RETURN
!
      END SUBROUTINE SO2NL
!
!                             *******************
!
      SUBROUTINE SOCC
!
!-----------------------------------------------------------------------
!
!  SR.SOCC CALCULATES THE BLUME AND WATSON CONTRIBUTIONS TO THE
!  SPIN-ORBIT PARAMETERS.
!
!  IT IS CALLED BY:
!    SR.CALCFX
!    SR.MINIM
!
!  IT CALLS:
!    SR.NLAM
!!    SR.RAD
!    SR.RADBP1
!    SR.VCC
!    SR.VLAM0
!    SR.ZETA
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_COEFF,  ONLY: QRLP,IRLP
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_MINIM,  ONLY: MPNCH,KUTCAS,BPRINT
      USE COMMON_REL,    ONLY: DMASS,DCD,D2LL
      USE COMMON_RELINT, ONLY: DRLP1,DNL
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBAL2, ONLY: MAXLAM,NMULTE,KUTLS
      USE COMMON_NRBINT, ONLY: DRLI,DYY,IYY,NRLI,MENG,NREL,NLAG,NLAGP   &
     &                        ,BLAG,BBC2
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
      USE COMMON_NRBNF2, ONLY: DETA,DXSI,DZL,DXTWO
      USE COMMON_NRBOLP, ONLY: OVLPGR,OVLPCF,IPAIR
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX                     &
     &                        ,MXBORB,MXVORB,MXFORB,NGRP
      USE COMMON_NRBPOT, ONLY: ZESP,IZESP,NWRM
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBVAL, ONLY: FACT,IVAL,NNEW,NNOLD,BJUMP,BJUMP2,BRAD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION TNINT(3,2)
!
!-----------------------------------------------------------------------
!
      IF(IRLP.LE.0)GO TO 700
!
      BMVDR=ALLOCATED(DCD)
!
      BPRNT0=BPRINT
      IF(BPRINT)BPRNT0=JPRINT.NE.-3
      IF(BPRNT0)THEN
        IF(IZESP.NE.0)WRITE(MW6,10070)IZESP,(I,ZESP(I),I=1,ABS(IZESP))
        IF(KUTOO.NE.98)WRITE(MW6,10010)
        IF(KUTOO.EQ.98)WRITE(MW6,10050)
      ENDIF
!
      MXLAM=ABS(MAXLAM)
      NMULT=NMULTE-1                              !LIMIT NO OF MULIPOLES
!pc
!p      if(irlx.lt.0)then
!p        ngrp=-irlx/100000             !until /nrborb/ in a module
!p        mxborb=-irlx-100000*ngrp
!p      endif
!
! RUN THROUGH ALL PAIRS OF VALENCE ELECTRON QUANTUM NUMBERS
!
      IF(KUTOO.EQ.98)THEN
! DXSI ONLY USED FOR TEST PURPOSES
        DO K=1,MXORB
          IF(DEY(K).EQ.DZERO)GO TO 50
          DO J=1,K
            IF(DEY(J).EQ.DZERO)GO TO 20
            M=IVAL(K)+IVAL(J)
            IF(BJUMP.AND.M.EQ.0)GO TO 20
            IN=ICOL(J,K,IZERO)
            DXSI(IN)=DZERO
   20     ENDDO
   50   ENDDO
      ENDIF
!
      K0=0
!
! START LOOP OVER ALL COEFFICIENTS
!
      DO LP=1,IRLP
!
        K1=QRLP(1,LP)
        K3=QRLP(2,LP)
!
        K=QRLP(4,LP)
!        K=(K3-1)/IAXGR
!
        DC1=DZERO
        IF(K.NE.0)GO TO 450                         !RADIATIVE INTEGRALS
!
        if(k3.gt.k1)stop 'sr.socc: k3.gt.k1'  !should not be for B&W etc
!
        IN=ICOL(K3,K1,IZERO)
!
        M=IVAL(K1)+IVAL(K3)
        IF(BJUMP.AND.M.EQ.0)THEN
          DC1=DRLP1(LP)
          GO TO 400
        ENDIF
!
        DI=DZERO                                    !DIRECT
        W1=DZERO                                    !EXCHANGE
!
        IMT=0
!        IF(QN(K1).LT.0)IMT=IMT+1
!        IF(QN(K3).LT.0)IMT=IMT+1
        IF(IYY(K1).GT.0)IMT=IMT+1
        IF(IYY(K3).GT.0)IMT=IMT+1
        IF(MODE.LE.2.AND.IMT.GE.1)GO TO 400
!        IF(BREL.AND.K1.NE.K3)GO TO 16
!
        N1=ABS(QN(K1))
        N3=ABS(QN(K3))
!
        MQLA=QL(K1)
        QLA=INT(MQLA/2,QP)
        MQLB=0
!
        V1=DZERO
        V2=DZERO
        V3=DZERO
!
        OVL=DONE
        IF(IRLX.EQ.2)THEN            !DETERMINE OVERLAP
          KF=IGRCF(K1)
          KG=IGRCF(K3)
          IF(KF.NE.KG.AND.KF*KG.GT.0)THEN
            KK1=MIN(KF,KG)
            KK2=MAX(KF,KG)
            KK=((KK2-1)*(KK2-2))/2+KK1
            IF(IPAIR(KK).EQ.1)OVL=OVLPCF(KK)
          ENDIF
        ENDIF
!
        J2=-1
        K2=0
        GO TO 350
!
! J2 NUMBERS THE ELECTRONS IN THE CORE C0,  J2=1,2,.....NW AND
! SO CANNOT BE A CONTINUUM ELECTRON OR A DR VALENCE ELECTRON.
!
  100   K2=NNL(J2,1)
        if(irlx.lt.0)then
          ngrp1=igrcf(k1)
          k2=k2+(ngrp1-1)*mxborb
        endif
!
  150   K4=NNL(J2,1)                               !K2
        if(irlx.lt.0)then
          ngrp3=igrcf(k3)
          k4=k4+(ngrp3-1)*mxborb
        endif
!
        MQLB=INT(QL(K2),SP)
        QLB=INT(MQLB/2,QP)
!
        IF(BMVDR.AND.BREL)THEN
          IN=ICOL(K2,K2,IZERO)
          DCD(IN)=DZERO
        ENDIF
!
! CALCULATE THE DIRECT INTEGRAL, N(ABAB,LBD=0).
!
        M0=3
!
        CALL NLAM(M0,K1,K2,K3,K4,IZERO,DM)
!                                      CALL RAD(K1,K2,K3,K4,IZERO,DM,M0)
!
        DM=DM*OVL
!
        DI=DI-((MQLB+1)*4)*DM       !DIRECT B&W
!
!PRNT WRITE(MW6,182)  J2,      K1,K2,K3,K4,  DM
!
        TNINT(2,1)=DZERO
        TNINT(3,1)=DZERO
        TNINT(2,2)=DZERO
        TNINT(3,2)=DZERO
        QX=QLA+QLB
        L=ABS(MQLB-MQLA)/2
        K=L-3
        IF(L.EQ.0)THEN
          DC1=DONE
          L=1
          K=-1
        ENDIF
!
  200   K=K+1
        TNINT(1,1)=TNINT(2,1)
        TNINT(2,1)=TNINT(3,1)
        TNINT(1,2)=TNINT(2,2)
        TNINT(2,2)=TNINT(3,2)
!
! COMPUTE N-INTEGRALS (IF M0=+3)  AND V-INTEGRALS (M0=-3)
!
        DM=DZERO
        DK=DZERO
        IF(K.GT.MXLAM.OR.K.GT.2*NMULT)GO TO 250
!
!        CALL RAD(K1,K2,K4,K3,K,DK,M0)
!
        IF(M0.GT.0)THEN
          CALL NLAM(M0,K1,K2,K4,K3,K,DK)
        ELSEif(m0.lt.0)then
          CALL VLAM0(M0,K1,K2,K4,K3,K,DK)
        else
          write(mw6,*)'socc: m0=0 ??'
          write(mw0,*)'socc: m0=0 ??'
          nf=-1
          go to 700
        ENDIF
!
        DK=DK*OVL
!
        DM=DK
        IF(M0*K1.EQ.3*K3)GO TO 250
!
! USE THE RELATION N(AB,BA,K)=N(BA,AB,K) IN CASE A=C.
!
!        CALL RAD(K2,K1,K3,K4,K,DM,M0)
!
        IF(M0.GT.0)THEN
          CALL NLAM(M0,K2,K1,K3,K4,K,DM)
        ELSEif(m0.lt.0)then
          CALL VLAM0(M0,K2,K1,K3,K4,K,DM)
        else
          write(mw6,*)'socc: m0=0 ??'
          write(mw0,*)'socc: m0=0 ??'
          nf=-1
          go to 700
        ENDIF
!
        DM=DM*OVL
!
  250   TNINT(3,2)=DM
        TNINT(3,1)=DK
!
! TNINT(J1,1) CONTAINS INTEGRALS OF THE TYPE N(AB,BC) AND TNINT(J1,2)
! CONTAINS INTEGRALS N(BA,CB). THE INDEX J1 GIVES THE ORDER OF THE
! INTEGRAL, THUS J1=I CORRESPONDS TO ORDER K+I-3.
!
!PRNT WRITE(MW6,183)     K,M0,               DK, DM
        M0=-M0
        IF(K.LT.L)GO TO 200
!
        MK=2*K
        DK=K
        DKU=K+1
        IF(M0.LE.0)THEN
!
!    IF QLA+QLB+K IS AN ODD INTEGER THEN THE CONTRIBUTIONS FROM V1
!    AND V3 ARE ZERO.
!
          DC1=VCC(MQLA,MK,MQLB,IZERO,IZERO,IZERO)
          DM=QLA*(QLA+1)+K*(K+1)-QLB*(QLB+1)
          W1=-DM/(MQLA*(QLA+1))
          V1=V1-6*DC1*DC1*W1*(TNINT(2,1)-TNINT(2,2))
!         =V1-6*DC1*DC1*W1*(V(K1,K2,K4,K3,K-1)-V(K2,K1,K3,K4,K-1))
          V3=V3-3*DC1*DC1*W1*((DM-MK*DKU)*(DK*TNINT(3,1)-DKU*TNINT(1,2))&
     &       +DM*(DK*TNINT(3,2)-DKU*TNINT(1,1)))/(DK*DKU)
        ELSE
!
          MS=QX+K
          IWT=(MS+1)*(MS-MQLB)*(MS-MQLA)*(MS-MK+1)
          W1=DSIX*IWT/(MQLA*(MQLA+2))
!         DC1=VCC(MQLA,MK-2,MQLB,IZERO,IZERO,IZERO)
          DM=DC1*DC1*(TNINT(2,1)+TNINT(2,2))/(DK*DKU)
          V2=V2+W1*DM
          IF(KUTOO.NE.98)GO TO 300
!
! TEST TWO-BODY NON-FINE-STRUCTURE VALENCE-CLOSED SHELL CONTRIB.
!
          IF(KUTOO*QLA*QLB.NE.0)THEN
!
! JONES (A.U.)  WO1=IWT/(2*(MQLB+1))
            WO1=IWT
!
            DXSI(IN)=DXSI(IN)+WO1*DM
!
!         T=(MK+1)*(MK-1)*DC1*DC1
!         WRITE(MW6,*)K,T,DC1
!
          ENDIF
!
        ENDIF
!
!P101 WRITE(MW6,184) DC1,W1, V1,V2,V3
!
  300   IF(K.LT.QX)GO TO 200
!
! BLUME AND WATSON CLOSED-SHELL:
! ONLY NEED TO CONSIDER EACH CLOSED SHELL ONCE,
! SO INCREASE J2 BY THE NUMBER OF ELECTRONS IN THE CLOSED SHELL
! (IREL .LT. 0 USES POTENTIAL DERIVATIVE - SO SKIP)
! (IZESP.GT. 0 USES PURE NUCLEAR SCREENING BY ZESP - SO SKIP)
!
  350   IF(IREL.GE.0.AND.IZESP.LE.0)THEN
          J2=J2+2*(MQLB+1)
          IF(J2.LT.NW)GO TO 100
!
! OPTIONALLY FORCE R-MATRIX BLUME & WATSON "CLOSED-SHELL" CONTRIBUTION
! (ADJUST TESTS ON N2,N1,N3 TO REPRODUCE DESIRED R-MATRIX RESULT.)
!
          IF(J2.LT.NWRM)THEN
            K2=K2+1
            N2=ABS(QN(K2))
            IF(N2.LT.N1.AND.N2.LT.N3)GO TO 150
          ENDIF
        ENDIF
!
! IF ALL THE CORE ELECTRONS HAVE BEEN CONSIDERED, THE NEXT SET OF
! EQUIVALENT ELECTRONS IN THE VALENCE SHELLS MAY BE CONSIDERED
!
! SUM OF B&W EXCHANGE CONTRIBUTIONS
!
        W1=V1+V2+V3
!
! *** NUCLEAR SPIN-ORBIT
!
        IF(BMVDR.AND.BREL)THEN
! UNCOMMENT IF REL ORB S-O INTEGRAL COMPUTED IN RADIAL/RADCON.
!          DK=DCD(IN)
!          write(mw0,*)k1,k3
!          write(mw0,*)dk
          DCD(IN)=DZERO
!          DCD(K3,K1)=DZERO
!      GO TO 26
        ENDIF
!
        CALL ZETA(K1,K3,DK)        !CALL RAD(K1,K2,K3,K4,IZERO,DK,IZERO)
!
!      write(mw0,*)k1,k3,dk
!
!   26   CONTINUE
!
! COMBINE NUCLEAR WITH ANY DIRECT AND EXCHANGE BLUME & WATSON
!
        DC1=2*NZION*DK+DI+W1
!
! MULTIPY BY ANY SCREENING FACTOR
! (IZESP.GT.0 HAS ALREADY SWITCHED-OFF ANY B&W, OR POTENTIAL DERVATIVE)
!
        IF(IZESP.NE.0)THEN
          IZ=ABS(IZESP)
          IZ=MIN(IZ,INT(QLA,SP))
          DC1=DC1*ZESP(IZ)
        ENDIF
!
  400   DM=DTWO*DKCM*DC1
        DKU=DM/NZION**4
        DRLP1(LP)=DC1
!
        IF(KUTOO.NE.98)THEN
          IF(.NOT.BJUMP.AND.BPRNT0)WRITE(MW6,10020)LP,K1,K3,DC1,DM,DKU, &
     &                                   DI,W1
          IF(BJUMP.AND.BPRNT0)WRITE(MW6,10020)LP,K1,K3,DC1,DM,DKU
        ELSE
          IF(.NOT.BJUMP.AND.BPRNT0)WRITE(MW6,10040)LP,K1,K3,DC1,DM,DKU, &
     &                                   DI,W1,DXSI(IN)
          IF(BJUMP.AND.BPRNT0)WRITE(MW6,10040)LP,K1,K3,DC1,DM,DKU,DZERO,&
     &                              DZERO,DXSI(IN)
        ENDIF
!
        GO TO 600                                !EXIT LOOP
!
!---------------------------------------------------------------------
!
!  THE FOLLOWING SECTION PROVIDES FOR RELATIVISTIC RADIATIVE INTEGRALS
!
!---------------------------------------------------------------------
!
  450   CONTINUE
!
        IF(K0.EQ.0)THEN
          K0=K
! TMP K=-K0
          IF(BPRNT0)WRITE(MW6,10030)
        ENDIF
!
        K2=K1                                      !-K*IAXGR
        K4=K3                                      !-K*IAXGR
!
        KX=MIN(K2,K4)                        !FOR TYPE K=2,3
!
        M=IVAL(K2)+IVAL(K4)
        IF(BJUMP)THEN
          IF(M.EQ.0)THEN
            DC1=DRLP1(LP)
            GO TO 500
          ELSEIF(QN(KX).LT.0)THEN                !CONT-CONT (RYD APPROX)
            tm=nnew
            tm=tm-screen(kx)           !can use, as we do have q.d. here
            tn=nnold
            tn=tn-screen(kx)           !can use, as we do have q.d. here
            factj=(tn/tm)**3
            factj=sqrt(factj)
            DC1=DRLP1(LP)*factj
            GO TO 500
          ENDIF
        ENDIF
!
        IMT=0
!        IF(QN(K2).LT.0)IMT=IMT+1
!        IF(QN(K4).LT.0)IMT=IMT+1
        IF(IYY(K2).GT.0)IMT=IMT+1
        IF(IYY(K4).GT.0)IMT=IMT+1
!
        IF(MODE.GT.2.OR.IMT.LE.1)THEN
!
          M0=0
          IF(K.GT.8)M0=1000*QRLP(3,LP)
!
          CALL RADBP1(K2,K4,K,DC1,M0)
!
          if(m0.lt.0)then                        !should not occur (now)
            nf=-1
            go to 700
          endif
!
          OVL=DONE
          IF(IRLX.EQ.2.AND.K.LT.9)THEN            !DETERMINE OVERLAP
            KF=IGRCF(K2)
            KG=IGRCF(K4)
            IF(KF.NE.KG.AND.KF*KG.GT.0)THEN
              KK1=MIN(KF,KG)
              KK2=MAX(KF,KG)
              KK=((KK2-1)*(KK2-2))/2+KK1
              IF(IPAIR(KK).EQ.1)OVL=OVLPCF(KK)
            ENDIF
          ENDIF
          DC1=DC1*OVL
        ENDIF
!
  500   IF(BPRNT0)WRITE(MW6,10060)LP,K1,K3,DC1,K
!
        DRLP1(LP)=DC1
!
!-----------------------------------------------------------------------
!
! END M1+BP RADIATIVE
!
  600 ENDDO
!
! END LOOP OVER ALL COEFFICIENTS
!
!-----------------------------------------------------------------------
!
  700 RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(//5X,'ZETA(   A    B ) = SPIN-ORBIT PARAMETERS',37X,       &
     &       'BLUME AND WATSON CLOSED SHELL CONTRIBUTION, IN 2RY'/33X,  &
     &       '2*RY',17X,'1/CM',13X,'Z**4/CM',14X,'DIRECT CONTRIBUTION', &
     &       4X,'EXCHANGE CONTRIB.')
10020 FORMAT(I5,4X,2I5,8X,E14.7,2(5X,1PE14.7),11X,2(7X,0PE14.6))
!P182 FORMAT(/21X,'.   DM',6X,,I4,8X,4I4,E18.5)
!P183 FORMAT(20X,'..N1- OR V1-2',4X ,2I4,16X,2E18.5)  184FOR./77X,3E18.5
!P184 FORMAT (19X,'...DC1,W1,V1-3',28X,2E18.5/77X,3E18.5)
10030 FORMAT(47X,'NOW FOLLOWING ARE RADIATIVE INTEGRALS')
10040 FORMAT(I5,2X,2I5,5X,1PE14.7,2(3X,E14.7),1X,2(7X,E14.6),5X,E14.7)
10050 FORMAT(//5X,'ZETA( A    B ) = SPIN-ORBIT PARAMETERS',19X,'BLUME', &
     &       ' AND WATSON CLOSED SHELL CONTRIBUTION, IN 2RY.',5X,       &
     &       '| ORBIT-ORBIT'/27X,'*2RY',14X,'1/CM',11X,'Z**4/CM',10X,   &
     &       'DIRECT CONTRIB.',4X,'EXCHANGE CONTRIB.',5X,               &
     &       '| XI PARAMETER')
10060 FORMAT(I5,4X,2I5,8X,E14.7,I7)
10070 FORMAT(//5X,'EFFECTIVE SPIN-ORBIT SCREENING PARAMETERS FOR IZESP='&
     &       ,I3//5X,'L=',10(I7,F10.4))
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE SOCC
!
!                             *******************
!
      SUBROUTINE SPLYN(N,SX,SY,I1,E1,I2,E2,SA,SB,SC,SD,SS)
!
!-----------------------------------------------------------------------
!
! ALAN BURGESS, D.A.M.T.P. CAMBRIDGE.
!
! CUBIC SPLINE FITTING TO THE DATA POINTS (SX(J),SY(J)),J=1,2...N
! WITH KNOTS AT SX(J),J=2,3...(N-1),
! IN THE FORM SY(X)=SA(J)+Z*(SB(J)+Z*(SC(J)+Z*SD(J))),
! FOR X IN THE RANGE (SX(J),SX(J+1)),
! WHERE Z=X-(SX(J)+SX(J+1))/2.
! ONE OF THE FOLLOWING END CONDITIONS MUST BE CHOSEN FOR EACH END:
! (1)SPECIFIED END FIRST DERIVATIVES; SET I1=1, E1=(DY/DX)(X=SX(1))
!                                         I2=1, E2=(DY/DX)(X=SX(N))
! (2)SPECIFIED END 2ND DERIVATIVES; SET I1=2, E1=((D/DX)**2)Y (X=SX(1))
!                                       I2=2, E2=((D/DX)**2)Y (X=SX(N))
! (3)END 2ND DERIVATIVE =NEXT-TO-END 2ND DERIVATIVE; SET I1=3, I2=3
!                                            (NO NEED TO SET E1,E2)
! (4)3RD DERIVATIVE CONTINUOUS AT FIRST AND LAST KNOTS; SET I1=4, I2=4
!                                              (NO NEED TO SET E1,E2).
! N.B. THE CHOSEN CONDITIONS NEED NOT BE THE SAME FOR THE TWO ENDS.
!  INPUT: N,SX(J),SY(J) (J=1,2...N),I1,E1,I2,E2.
!  OUTPUT: SA(J),SB(J),SC(J),SD(J) (J=1,2...(N-1))
!          SS(J) (J=1,2...N), THE SECOND DERIVATIVE OF Y.
!
!  IT IS CALLED BY:
!    FN.XINT
!
!  IT CALLS:
!    SR.TRIMAT
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION SA(N),SB(N),SC(N),SD(N),SX(N),SY(N),SS(N)
!
!-----------------------------------------------------------------------
!
      H1=SX(2)-SX(1)
      T1=(SY(2)-SY(1))/H1
!
      IF(I1.EQ.1)THEN
        SB(1)=H1+H1
        SC(1)=H1
        SD(1)=6*(T1-E1)
      ELSEIF(I1.EQ.2)THEN
        SB(1)=1
        SC(1)=0
        SD(1)=E1
      ELSEIF(I1.EQ.3)THEN
        SB(1)=1
        SC(1)=-1
        SD(1)=0
      ELSEIF(I1.EQ.4)THEN
        SB(1)=1
        SC(1)=0
        SD(1)=0
      ELSE
        WRITE(MW6,*)'SR.SPLYN: ILLEGAL VALUE FOR I1:',I1
        STOP 'SR.SPLYN: ILLEGAL VALUE FOR I1'
      ENDIF
!
      IF(I2.EQ.1)THEN
        H2=SX(N)-SX(N-1)
        SA(N)=H2
        SB(N)=H2+H2
        SD(N)=6*(E2-(SY(N)-SY(N-1))/H2)
      ELSEIF(I2.EQ.2)THEN
        SA(N)=0
        SB(N)=1
        SD(N)=E2
      ELSEIF(I2.EQ.3)THEN
        SA(N)=-1
        SB(N)=1
        SD(N)=0
      ELSEIF(I2.EQ.4)THEN
        SA(N)=0
        SB(N)=1
        SD(N)=0
      ELSE
        WRITE(MW6,*)'SR.SPLYN: ILLEGAL VALUE FOR I2:',I2
        STOP 'SR.SPLYN: ILLEGAL VALUE FOR I2'
      ENDIF
!
      N1=N-1
      DO J=2,N1
        H2=SX(J+1)-SX(J)
        T2=(SY(J+1)-SY(J))/H2
        SA(J)=H1
        SB(J)=2*(H1+H2)
        SC(J)=H2
        SD(J)=6*(T2-T1)
        H1=H2
        T1=T2
      ENDDO
!
      IF(I1.EQ.4)THEN
        SA(2)=0
        H1=SX(2)-SX(1)
        H2=SX(3)-SX(2)
        SB(2)=SB(2)+H1+H1*H1/H2
        SC(2)=SC(2)-H1*H1/H2
      ENDIF
      IF(I2.EQ.4)THEN
        SC(N-1)=0
        T1=SX(N-1)-SX(N-2)
        T2=SX(N)-SX(N-1)
        SA(N-1)=SA(N-1)-T2*T2/T1
        SB(N-1)=SB(N-1)+T2+T2*T2/T1
      ENDIF
!
      CALL TRIMAT(N,SA,SB,SC,SD,SS)
!
      IF(I1.EQ.4)SS(1)=((H1+H2)*SS(2)-H1*SS(3))/H2
      IF(I2.EQ.4)SS(N)=((T1+T2)*SS(N-1)-T2*SS(N-2))/T1
!
      DO J=1,N1
        H1=SX(J+1)-SX(J)
        T1=H1*H1/4
        SD(J)=(SS(J+1)-SS(J))/(6*H1)
        SC(J)=(SS(J+1)+SS(J))/4
        SB(J)=(SY(J+1)-SY(J))/H1-T1*SD(J)
        SA(J)=(SY(J+1)+SY(J))/2-T1*SC(J)
      ENDDO
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE SPLYN
!
!                             *******************
!
      FUNCTION SPVAL(N,SX,SA,SB,SC,SD,X1,J1)                        !,SY
!
!-----------------------------------------------------------------------
!
! ALAN BURGESS, D.A.M.T.P. CAMBRIDGE.
!
! EVALUATES  CUBIC SPLINE FIT TO SY(X) AT X=X1, WHERE X1 LIES IN THE
! INTERVAL (SX(J1),SX(J1+1)), GIVEN THE SPLINE COEFFICIENTS
! SA(J),SB(J),SC(J),SD(J) PRODUCED BY SUBROUTINE SPLYN.
! J1 NEED NOT BE SET AS INPUT, BUT EXECUTION MAY BE QUICKER IF IT IS.
!  INPUT: SX(J), SY(J), J=1,2...N  : NOTE, SY(J) NOT NEEDED. (NRB)
!         SA(J),SB(J),SC(J),SD(J), J=1,2...N-1
!         X1
!         J1 (OPTIONAL).
!  OUTPUT: SPVAL=SY(X1).
!
!  IT IS CALLED BY:
!    FN.XINT
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION SX(N),SA(N),SB(N),SC(N),SD(N)                    !,SY(N)
!
!-----------------------------------------------------------------------
!
      IF(SX(1).LT.SX(N))THEN
        I1=1
        I2=N
        I=1
      ELSE
        I1=N
        I2=1
        I=-1
      ENDIF
!
      IF((J1-I1)*(J1-I2+I).GT.0)J1=I1
!
  100 IF(X1.LT.SX(J1))THEN
        IF(J1.EQ.I1)GO TO 300
        J1=J1-I
        GO TO 100
      ENDIF
!
  200 IF(X1.GT.SX(J1+I))THEN
        IF(J1.EQ.(I2-I))GO TO 300
        J1=J1+I
        GO TO 200
      ENDIF
!
  300 J2=J1+I
      Z=X1-(SX(J2)+SX(J1))/2
      IF(J2.GT.J1)J2=J1
!
      SPVAL=SA(J2)+Z*(SB(J2)+Z*(SC(J2)+Z*SD(J2)))
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION SPVAL
!
!                             *******************
!
      SUBROUTINE SPOR0(KK,QLMC,QBML,QBMS,MAXEL)
!
!-----------------------------------------------------------------------
!
!  SR.SPOR0 CHECKS WHICH SLATER-STATES OF TWO CFS DIFFER BY ZERO OR ONE
!  PAIR AND SETS POINTERS TO THEM FOR LATER USE BY SPOR1 IF THEY SATISFY
!  THE SPIN-ORBIT SELECTION RULES. IT CLOSELY RESEMBLES SR.FLGLX0 - NRB.
!
!  IT IS CALLED BY:
!    SR.ALGEB3
!
!  IT CALLS:
!    SR.RE_ALLOC
!
!-----------------------------------------------------------------------
!
!!      COMMON /BASIC/NF,KF,KG,JA,JB,JAP,JBP,JGAP(5)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,JA=>IBSK4,JB=>IBSK5            &
     &              ,JAP=>IBSK6,JBP=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9    &
     &              ,IBSK10=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
!
      USE COMMON_NRBFL0, ONLY: KINTI,KINTF,KEN2,KPTCFM,KINT,MPOINT
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION QLMC(MAXEL,*),QBML(*),QBMS(*)
!
      ALLOCATABLE :: BTEMP(:,:),KTEMP(:),LTEMP(:),MTEMP(:)              &
     &              ,JTEMP(:),NTEMP(:)
!
!-----------------------------------------------------------------------
!
      NF1=NF+1
      NF2=NF*NF
!
      BEQCFS=KG.EQ.KF
!
! LOCAL (SMALL)
!
      ALLOCATE(BTEMP(NF,NF),KTEMP(NF2+1),LTEMP(NF2),MTEMP(NF))
      ALLOCATE(JTEMP(NF),NTEMP(NF))
!
      DO L=1,NF
        J=QCG(L,KG)
        JTEMP(L)=IEQ(J)
        K=QCG(L,KF)
        NTEMP(L)=IEQ(K)
      ENDDO
!
      K=0
      DO I=NF,1,-1
        DO L=NF,1,-1
          BTEMP(L,I)=JTEMP(L).EQ.NTEMP(I)
          IF(BTEMP(L,I))THEN
            K=K+1
            LTEMP(K)=L
            KTEMP(K)=I
          ENDIF
        ENDDO
      ENDDO
      KTEMP(K+1)=0
      KMX=K
!
      DEALLOCATE(JTEMP,NTEMP)
!
! INITIALIZE GROUP RANGES
!
      IXD02=QCL0/2
!
      MG2=IXD02
      MG1=-IXD02
!
      MG2P=IXD02
      MG1P=-IXD02
!
! LOOP OVER INITIAL ML GROUPS OF CONFIG KF
!
      DO MG=MG2,MG1,-1
!
        M1=MPOINT(MG+1,KF)+1                      !SLATER-STATE RANGE
        M2=MPOINT(MG,KF)
!
! LOOP OVER FINAL MLP GROUPS OF CONFIG KG
!
        IF(BEQCFS)MG1P=MG
!
        DO MGP=MG2P,MG1P,-1
!
          M1P=MPOINT(MGP+1,KG)+1                  !SLATER-STATE RANGE
          M2P=MPOINT(MGP,KG)
!
! LOOP OVER INITIAL SLATER STATES OF ML
!
          DO M=M1,M2
!
            J=M
            QMS=QBMS(J)
            QML=QBML(J)
            QMJ=QML+QMS
!
! LOOP OVER FINAL SLATER STATES OF MLP
!
            IF(BEQCFS.AND.MG.EQ.MGP)M2P=M
!
            DO MP=M1P,M2P
!
              JD=MP
!
              NEN2=0
              IF(JD.EQ.J)GO TO 20             !SO BEQCFS=.TRUE.
!
              QMSP=QBMS(JD)
              IF(ABS(QMS-QMSP).GT.2)GO TO 25         !NO S.O.
!
              QMLP=QBML(JD)
              QMJP=QMLP+QMSP
              IF(QMJ.NE.QMJP)GO TO 25
!
              NK=0
!
! DETERMINE THE PAIR OF INDIVIDUAL SETS IN WHICH SLATER
! STATE JD DIFFERS FROM J, AND THE PHASE FACTOR THAT RESULTS FROM
! THE REMAINING NF-1 SETS:
!
              N1=0
              MU=0
              DO I=1,NF
                MTEMP(I)=0
              ENDDO
!
! CASES WHERE ORBITAL NL'S MATCH
!
              I0=0
              DO K=1,KMX
                I=KTEMP(K)
                L=LTEMP(K)
                IF(I.NE.I0)THEN                   !NEED TO CHECK L STILL
                  IF(QLMC(L,JD).EQ.QLMC(I,J))THEN
                    MTEMP(I)=L
                    I0=I
                  ELSEIF(KTEMP(K+1).NE.I)THEN     !HAVE MOVED TO A NEW I
                    NK=NK+1
                    IF(NK.GT.1)GO TO 25
                    N1=I
                    MU=I+MU
                  ENDIF
                ENDIF
              ENDDO
!
! CASES WHERE ORBITALS DO NOT MATCH, SEE IF A DIFFERENCE
! HAS ALREADY BEEN FLAGGED, IF NOT, DO SO.
!
              DO I=NF,1,-1
                IF(MTEMP(I).EQ.0.AND.N1.NE.I)THEN
                  DO L=NF,1,-1
                    IF(.NOT.BTEMP(L,I))THEN
                      NK=NK+1
                      IF(NK.GT.1)GO TO 25
                      N1=I
                      MU=I+MU
                      GO TO 5
                    ENDIF
                  ENDDO
                ENDIF
    5         ENDDO
!
              ICG1=QCG(N1,KF)
              LP=QL(ICG1)
              IF(LP.EQ.0)GO TO 25  !S-STATES GIVE NO SPIN-ORBIT CONTRIBS
!
              K=0
              DO L=NF,1,-1
                DO I=NF,1,-1
                  IF(MTEMP(I).EQ.L)GO TO 10
                ENDDO
                K=K+1
                N2=L
                MU=L+MU
                IF(K.EQ.NK)GO TO 15
   10         ENDDO
!
   15         ICG2=QCG(N2,KG)
              IF(QL(ICG2).NE.LP)GO TO 25        !ZERO IF L-VALUES DIFFER
              IF(QN(ICG1).GE.90.AND.QN(ICG2).GE.90)GO TO 25
!
              IPHASE=(1-2*MOD(MU,ITWO))               !*IPHASE
!
!  NK.EQ.1 HERE
!
              IF(NK.NE.1)THEN
                WRITE(MW6,*)'SPOR0:ERROR, SHOULD NOT BE HERE',KF,KG,J,JD
                STOP 'SPOR0: ERROR, SHOULD NOT BE HERE'
              ENDIF
!
              NEN2=NF1*N1+N2
              NEN2=NEN2*IPHASE
!
! FLAG THIS PAIR AS INTERACTING (TBD DON'T BOTHER TO STORE J=JD CASE?)
!
   20         KINT=KINT+1
              IF(KINT.GT.IXSTX)THEN               !COULD PACK FURTHER...
!
                IXXX=7*(IXSTX/5)
!
                WRITE(MW6,*)'*** SPOR0: increasing MXSTX from ',IXSTX,  &
     &                      ' TO: ',IXXX
                WRITE(MW0,*)'*** SPOR0: increasing MXSTX from ',IXSTX,  &
     &                      ' TO: ',IXXX
!
                CALL RE_ALLOC(KINTI,IONE,IXSTX,IXXX,IERR)
                CALL RE_ALLOC(KINTF,IONE,IXSTX,IXXX,IERR)
                CALL RE_ALLOC(KEN2,IONE,IXSTX,IXXX,IERR)
!
                IF(IERR.NE.0)THEN
                  WRITE(MW0,*)'SPOR0: RE-ALLOCATION FAILS FOR KINTI etc'
                  NF=0
                  GO TO 100
                ENDIF
!
                IXSTX=IXXX
!
              ENDIF
!
              KINTI(KINT)=J
              KINTF(KINT)=JD
              KEN2(KINT)=NEN2
!              WRITE(MW6,*)KF,J,'  **  ',KG,JD
!
   25         CONTINUE
!
            ENDDO           !END FINAL ML SLATER STATE LOOP
!
          ENDDO           !END INITIAL ML SLATER STATE LOOP
!
          KPTCFM(MGP,MG,KK)=KINT
          IF(BEQCFS)KPTCFM(MG,MGP,KK)=KINT
!
        ENDDO           !END FINAL MLP GROUP LOOP FOR KG
!
      ENDDO           !END INITIAL ML GROUP LOOP FOR KF
!
!-----------------------------------------------------------------------
!
  100 DEALLOCATE(BTEMP,KTEMP,LTEMP,MTEMP)
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE SPOR0
!
!                             *******************
!
      SUBROUTINE SPOR1(QLMC,MAXEL,MAM,NAM)
!
!-----------------------------------------------------------------------
!
!  SR.SPOR1 EVALUATES SLATER-STATE INTERACTIONS FOR THE SPIN-ORBIT
!  MATRIX ELEMENTS - NRB.
!
!  IT IS CALLED BY:
!    SR.ALGEB3
!
!  IT CALLS:
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!
!-----------------------------------------------------------------------
!
!!      COMMON /BASIC/NF,KF,KG,JA,JB,JAP,JBP,JGAP(5)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,JA=>IBSK4,JB=>IBSK5            &
     &              ,JAP=>IBSK6,JBP=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9    &
     &              ,IBSK10=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_COEFFS, ONLY: DRKPS,QRLPS,NRKPS
      USE COMMON_COEFFS, ONLY: IRKPS,IRKPS0,IRLPS,IRLPS0
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_NSTS1,  ONLY: NADS1,NSTJ1,NSTJ1D,IORIG1,JORIG1
!
      USE COMMON_NRBAL3, ONLY: DVC12,ICLRS,ICLRR,BLX
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M6)
!
      DIMENSION QLMC(MAXEL,*),MAM(*),NAM(*)
!
!-----------------------------------------------------------------------
!
      IRLPS1=IRLPS0+1
      IF(ICLRS.LT.0)GO TO 200
!
!     IN LOOPS 64,65 SCAN THROUGH SLATER STATES IN INITIAL AND
!     FINAL STATES RESP., AND CALCULATE CONTRIBUTIONS DUE TO EACH PAIR.
!
      DO J1=JA,JB
!
        L1=MAM(J1)
!
        DO J2=JAP,JBP
!
          L2=NAM(J2)
!
!THIS NEXT STATEMENT RESOLVES INTERACTIONS BY SLATER STATE
!OLD      IRKPS00=IRKPS+1
!
          DO I=IRLPS1,IRLPS
            IORIG1(I)=0
          ENDDO
!
          NK=0
          N1=0
          IF(L2.EQ.L1)GO TO 40                     !DIAGONAL
!
!    NOW COMPARE INITIAL AND FINAL SLATERSTATES, L1 AND L2,
!    AND SELECT ONLY THE ONES WHICH DIFFER IN ONE SET OF QUANTUM NUMBERS
!
          DO ICG2=1,NF
            N1=ICG2+N1
            DO ICG1=1,NF
              IF(QLMC(ICG1,L1).NE.QLMC(ICG2,L2))GO TO 10
              IF(IEQ(QCG(ICG1,KF)).NE.IEQ(QCG(ICG2,KG)))GO TO 10
              N1=N1-ICG1
              GO TO 20
   10       ENDDO
            IF(NK.NE.0)GO TO 150        !SS DIFFER IN MORE THAN ONE PAIR
            NK=1
            N2=ICG2
   20     ENDDO
!
!     L1 AND L2 DIFFER IN ONE PAIR, IN POSITIONS NUMBERED N1 AND N2
!
          GO TO 60
!
   40     N1=N1+1
          IF(N1.GT.NF)GO TO 150
!         N2=N1
   60     ICG1=QCG(N1,KF)
          LP=QL(ICG1)
!
          IF(LP.EQ.0)GO TO 120     !S-STATES GIVE NO SPIN-ORBIT CONTRIBS
!
          ICG2=ICG1
          IF(NK.NE.0)ICG2=QCG(N2,KG)
          IF(QN(ICG1).GE.90.AND.QN(ICG2).GE.90)GO TO 150
!
!     FIND THE AZIMUTHAL COMPONENTS OF L AND S FOR THE INDIVIDUAL
!     ELECTRONS,WHOSE NUMBERS ARE N1,N2.
!
          MAUX=QLMC(N1,L1)
          QLML1=INT(((MAUX+100)/2)*2-100,QP)
          QLMS1=INT((MAUX-QLML1)*2-1,QP)
          DD=QLMS1*QLML1
!
          IF(NK.NE.0)THEN                   !OFF-DIAGONAL
!
            IF(QL(ICG2).NE.LP)GO TO 150     !ZERO IF THE L-VALUES DIFFER
!
!     NOW PROCEED FOR (L+).(S-) OR (L-).(S+) RATHER THAN (L0).(S0)
!
!           QLML2=((100+QLMC(N2,L2))/2)*2 -100
!           QLMS2=(QLMC(N2,L2)-QLML2)*2-1
!           QLMS2+QLML2=QLMS1+QLML1 FOR NK=0,1
!
            IF(QLMC(N2,L2).NE.MAUX)THEN
              MAUX=QLMS1+QLML1
              DD=SQRT(REAL((LP-MAUX+1)*(LP+MAUX+1),WP))
            ENDIF
            IF(((N1+N2)/2)*2.NE.N1+N2)DD=-DD
            IF(ICG2.GT.ICG1)THEN
              MAUX=ICG2
              ICG2=ICG1
              ICG1=MAUX
            ENDIF
          ENDIF
!
          DD=DVC12*DD/DFOUR
!
! STORE CONTRIBUTION TO (EXISTING) COEFFICIENT
!
          DO J=IRLPS1,IRLPS
            IF(QRLPS(2,J).NE.ICG2)GO TO 80
            IF(QRLPS(1,J).NE.ICG1)GO TO 80
            I=IORIG1(J)
            IF(I.GT.0)THEN
              DRKPS(I)=DRKPS(I)+DD
              GO TO 120
            ENDIF
            L=J
            GO TO 100
   80     ENDDO
!
! CANNOT FIND OLD SET OF ARGUMENTS, SO START CONSTRUCTING A NEW SET
!
          L=IRLPS+1
          IF(L.GT.IXS1I)THEN
!
            IXXX=7*(IXS1I/5+1)
!
            WRITE(MW6,*)'*** SPOR1: increasing MXS1I from ',IXS1I,      &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** SPOR1: increasing MXS1I from ',IXS1I,      &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC2(QRLPS,IONE,IFOUR,IONE,IXS1I,IFOUR,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'SPOR1: RE-ALLOCATION FAILS FOR QRLPS'
              NF=0
              GO TO 500
            ENDIF
!
            IXXX0=MAX(IXS1I,IXSOI)
            IXXX1=MAX(IXXX,IXSOI)
            IF(IXXX1.GT.IXXX0)CALL RE_ALLOC(IORIG1,IONE,IXXX0,IXXX1,    &
     &         IERR)
            CALL RE_ALLOC(JORIG1,IONE,IXS1I,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'SPOR1: RE-ALLOCATION FAILS FOR IORIG1,JORIG1'
              NF=0
              GO TO 500
            ENDIF
!
            IXS1I=IXXX
!
          ENDIF
!
          IRLPS=L
          QRLPS(1,L)=INT(ICG1,QP)
          QRLPS(2,L)=INT(ICG2,QP)
!
  100     IRKPS=IRKPS+1
          IF(IRKPS.GT.IXS1C)THEN
!
            IXXX=7*(IXS1C/5+1)
!
            WRITE(MW6,*)'*** SPOR1: increasing MXS1C from ',IXS1C,      &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** SPOR1: increasing MXS1C from ',IXS1C,      &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC(DRKPS,IONE,IXS1C,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'SPOR1: RE-ALLOCATION FAILS FOR DRKPS'
              NF=0
              GO TO 500
            ENDIF
!
            CALL RE_ALLOC(NRKPS,IONE,IXS1C,IXXX,IERR)
            CALL RE_ALLOC(NSTJ1,IONE,IXS1C,IXXX,IERR)
            CALL RE_ALLOC(NSTJ1D,IONE,IXS1C,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'SPOR1: RE-ALLOCATION FAILS FOR NRKPS,NSTJ1'
              NF=0
              GO TO 500
            ENDIF
!
            IXS1C=IXXX
!
          ENDIF
!
          IORIG1(L)=IRKPS
          NRKPS(IRKPS)=L
          DRKPS(IRKPS)=DD
          NSTJ1(IRKPS)=L1
          NSTJ1D(IRKPS)=L2
!
  120     IF(NK.EQ.0)GO TO 40
!
!     NK.EQ.1 FOR STATES WHICH DIFFER IN ONE SET OF ONE-ELECTRON
!     QUANTUM NOS, THE NECESSARY TERM HAS ALREADY BEEN EVALUATED,
!     THEREFORE PROCEED TO NEXT PAIR OF SLATER STATES.
!
  150   ENDDO                 !END SCAN OF INITIAL SLATER STATES
!
      ENDDO                 !END SCAN OF FINAL SLATER STATES
!
!
!     IF THE COEFFICIENTS OF THE SPIN-ORBIT PARAMETERS IN THE MATRIX
!     ELEMENT HAVE NOT BEEN COMPLETELY CALCULATED, RETURN - SPOR1 WILL
!     BE CALLED AGAIN, FOR DIFFERENT (MS,ML) GIVING THE SAME MS+ML=QMJ.
!
      IF(BLX)RETURN
!
!     ELIMINATE COEFFICIENTS /DRKPS/.LT.TYNY AND ARGUMENTS QRLPS THAT
!     HAVE BEEN LISTED BEFORE IN THE REFERENCE LIST
!     IF(KF.GT.0)RETURN
!
  200 ICLRS=0
      IF(IRKPS.LT.IRKPS0)RETURN
!
      K=IRKPS0-1
      KP=0
      DO I=IRLPS1,IRLPS
        IORIG1(I)=0
      ENDDO
!
      DO I=IRKPS0,IRKPS
!
        JD0=NRKPS(I)
        JD=ABS(JD0)
        IF(ABS(DRKPS(I)).LT.TYNY)THEN
          IF(IORIG1(JD).GT.0)GO TO 400
          JD0=0               !RE-INDEX QRLPS AS MAY OCCUR LATER
          GO TO 250
        ENDIF
!
        K=K+1
        DRKPS(K)=DRKPS(I)
        NSTJ1(K)=NSTJ1(I)
        NSTJ1D(K)=NSTJ1D(I)
!
  250   IF(JD.LE.IRLPS0)THEN
          WRITE(MW6,*)'SPOR1: INFORM NRB OF STOP HERE'
          WRITE(MW0,*)'SPOR1: INFORM NRB OF STOP HERE'
          NF=-1
          GO TO 500
!        LP=JD
!        GO TO 92
        ENDIF
!
        IF(IORIG1(JD).EQ.0)THEN
          LP=JD-KP
          DO L=1,IRLPS0
            DO J=1,2
              IF(QRLPS(J,JD).NE.QRLPS(J,L))GO TO 260
            ENDDO
            KP=KP+1
            IORIG1(JD)=L
            LP=L
            GO TO 300
  260     ENDDO
        ELSE
          LP=IORIG1(JD)
          GO TO 300
        ENDIF
!
        IORIG1(JD)=LP
        DO J=1,2
          QRLPS(J,LP)=QRLPS(J,JD)
        ENDDO
!
  300   IF(JD0.NE.0)THEN
          NRKPS(K)=LP
!          IF(JD0.LT.0)NRKPS(K)=-NRKPS(K)
        ENDIF
!
  400 ENDDO
!
      IRLPS=IRLPS-KP
      IRKPS=K
!
!-----------------------------------------------------------------------
!
  500 RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE SPOR1
!
!                             *******************
!
      SUBROUTINE SPOR1F(QLMC,MAXEL,NAM)
!
!-----------------------------------------------------------------------
!
!  SR.SPOR1F EVALUATES SLATER-STATE INTERACTIONS FOR THE SPIN-ORBIT
!  MATRIX ELEMENTS. IT DIFFERS FROM SPOR1 IN THAT THE INTERACTING
!  PAIRS HAVE ALREADY BEEN SET-UP BY SR.SPOR0 - NRB.
!
!  IT IS CALLED BY:
!    SR.ALGEB3
!
!  IT CALLS:
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!
!-----------------------------------------------------------------------
!
!!      COMMON /BASIC/NF,KF,KG,JA,JB,JAP,JBP,JGAP(5)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,JA=>IBSK4,JB=>IBSK5            &
     &              ,JAP=>IBSK6,JBP=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9    &
     &              ,IBSK10=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_COEFFS, ONLY: DRKPS,QRLPS,NRKPS
      USE COMMON_COEFFS, ONLY: IRKPS,IRKPS0,IRLPS,IRLPS0
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_NSTS1,  ONLY: NADS1,NSTJ1,NSTJ1D,IORIG1,JORIG1
!
      USE COMMON_NRBAL3, ONLY: DVC12,ICLRS,ICLRR,BLX
      USE COMMON_NRBFL0, ONLY: KINTI,KINTF,KEN2
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M6)
!
      DIMENSION QLMC(MAXEL,*),NAM(*)                                    &
     &         ,NEJ(2),NEN(2)
!
      POINTER :: N1,N2
      TARGET :: NEN
!
      N1=>NEN(1)
      N2=>NEN(2)
!
!      EQUIVALENCE (NEN(1),N1),(NEN(2),N2)
!
!-----------------------------------------------------------------------
!
      IRLPS1=IRLPS0+1
      IF(ICLRS.LT.0)GO TO 400
!
      brev=kf.lt.kg
      NF1=NF+1
!
! BEGIN MAIN SLATER-STATE INTERACTION LOOP (64)
!
      DO J1=JA,JB
!
        kk=nam(j1)
        if(brev.or.kk.lt.0)then
          kk=abs(kk)
          i1=2
          i2=1
        else
          i1=1
          i2=2
        endif
        nej(i1)=kinti(kk)
        nej(i2)=kintf(kk)
        l1=nej(1)
        l2=nej(2)
!
!      write(mw6,*)kf,j,'      ',kg,jd
!
        DO I=IRLPS1,IRLPS
          IORIG1(I)=0
        ENDDO
!
        DDH=DONE
        NK=0
        N1=0
        IF(L2.EQ.L1)GO TO 50                !DIAGONAL
!
! NK=1,  L1 AND L2 DIFFER IN ONE PAIR, IN POSITIONS NUMBERED N1 AND N2
!
        nk=1
        nen2=ken2(kk)
!                              if(nen2.eq.0)stop 'nen2 error'
        if(nen2.lt.0)then
          ddh=-ddh
          nen2=-nen2
        endif
        nen(i1)=nen2/nf1
!                     if(nen(i1).eq.0)stop 'nen(1) error'
        nen(i2)=nen2-nen(i1)*nf1
!                     if(nen(i2).eq.0)stop 'nen(2) error'
!
        GO TO 100
!
! NK=0
!
   50   N1=N1+1
        IF(N1.GT.NF)GO TO 300
!       N2=N1
  100   ICG1=QCG(N1,KF)
        LP=QL(ICG1)
!                                  !RETAIN TESTS FOR NK=0 LOOP OVER ORBS
        IF(LP.EQ.0)GO TO 250       !S-STATES GIVE NO SPIN-ORBIT CONTRIBS
!
        ICG2=ICG1
        IF(NK.NE.0)ICG2=QCG(N2,KG)
        IF(QN(ICG1).GE.90.AND.QN(ICG2).GE.90)GO TO 300
!
!   FIND THE AZIMUTHAL COMPONENTS OF L AND S FOR THE INDIVIDUAL
!   ELECTRONS,WHOSE NUMBERS ARE N1,N2.
!
        MAUX=QLMC(N1,L1)
        QLML1=INT(((MAUX+100)/2)*2-100,QP)
        QLMS1=INT((MAUX-QLML1)*2-1,QP)
        DD=QLMS1*QLML1
!
        IF(NK.NE.0)THEN                     !OFF-DIAGONAL
!                                           !SO NO TEST NEEDED
!          IF(QL(ICG2).NE.LP)GO TO 64       !ZERO IF THE L-VALUES DIFFER
!
!   NOW PROCEED FOR (L+).(S-) OR (L-).(S+) RATHER THAN (L0).(S0)
!
!         QLML2=((100+QLMC(N2,L2))/2)*2 -100
!         QLMS2=(QLMC(N2,L2)-QLML2)*2-1
!         QLMS2+QLML2=QLMS1+QLML1 FOR NK=0,1
!
          IF(QLMC(N2,L2).NE.MAUX)THEN
            MAUX=QLMS1+QLML1
            DD=SQRT(REAL((LP-MAUX+1)*(LP+MAUX+1),WP))
          ENDIF
!          IF(((N1+N2)/2)*2.NE.N1+N2)DDH=-DDH     !TAKE FROM SPOR0
          IF(ICG2.GT.ICG1)THEN
            MAUX=ICG2
            ICG2=ICG1
            ICG1=MAUX
          ENDIF
        ENDIF
!
        DD=DDH*DVC12*DD/DFOUR
!
! STORE CONTRIBUTION TO (EXISTING) COEFFICIENT
!
        DO J=IRLPS1,IRLPS
          IF(QRLPS(2,J).NE.ICG2)GO TO 150
          IF(QRLPS(1,J).NE.ICG1)GO TO 150
          I=IORIG1(J)
          IF(I.GT.0)THEN
            DRKPS(I)=DRKPS(I)+DD
            GO TO 250
          ENDIF
          L=J
          GO TO 200
  150   ENDDO
!
! CANNOT FIND OLD SET OF ARGUMENTS, SO START CONSTRUCTING A NEW SET
!
        L=IRLPS+1
        IF(L.GT.IXS1I)THEN
!
          IXXX=7*(IXS1I/5+1)
!
          WRITE(MW6,*)'*** SPOR1F: increasing MXS1I from ',IXS1I,       &
     &                ' to: ',IXXX
          WRITE(MW0,*)'*** SPOR1F: increasing MXS1I from ',IXS1I,       &
     &                ' to: ',IXXX
!
          CALL RE_ALLOC2(QRLPS,IONE,IFOUR,IONE,IXS1I,IFOUR,IXXX,IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'SPOR1F: RE-ALLOCATION FAILS FOR QRLPS'
            NF=0
            GO TO 700
          ENDIF
!
          IXXX0=MAX(IXS1I,IXSOI)
          IXXX1=MAX(IXXX,IXSOI)
          IF(IXXX1.GT.IXXX0)CALL RE_ALLOC(IORIG1,IONE,IXXX0,IXXX1,IERR)
          CALL RE_ALLOC(JORIG1,IONE,IXS1I,IXXX,IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'SPOR1F: RE-ALLOCATION FAILS FOR IORIG1,JORIG1'
            NF=0
            GO TO 700
          ENDIF
!
          IXS1I=IXXX
!
        ENDIF
!
        IRLPS=L
        QRLPS(1,L)=INT(ICG1,QP)
        QRLPS(2,L)=INT(ICG2,QP)
!
  200   IRKPS=IRKPS+1
        IF(IRKPS.GT.IXS1C)THEN
!
          IXXX=7*(IXS1C/5+1)
!
          WRITE(MW6,*)'*** SPOR1F: increasing MXS1C from ',IXS1C,       &
     &                ' to: ',IXXX
          WRITE(MW0,*)'*** SPOR1F: increasing MXS1C from ',IXS1C,       &
     &                ' to: ',IXXX
!
          CALL RE_ALLOC(DRKPS,IONE,IXS1C,IXXX,IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'SPOR1F: RE-ALLOCATION FAILS FOR DRKPS'
            NF=0
            GO TO 700
          ENDIF
!
          CALL RE_ALLOC(NRKPS,IONE,IXS1C,IXXX,IERR)
          CALL RE_ALLOC(NSTJ1,IONE,IXS1C,IXXX,IERR)
          CALL RE_ALLOC(NSTJ1D,IONE,IXS1C,IXXX,IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'SPOR1F: RE-ALLOCATION FAILS FOR NRKPS,NSTJ1'
            NF=0
            GO TO 700
          ENDIF
!
          IXS1C=IXXX
!
        ENDIF
!
        IORIG1(L)=IRKPS
        NRKPS(IRKPS)=L
        DRKPS(IRKPS)=DD
        NSTJ1(IRKPS)=L1
        NSTJ1D(IRKPS)=L2
!
  250   IF(NK.EQ.0)GO TO 50
!
!     NK.EQ.1 FOR STATES WHICH DIFFER IN ONE SET OF ONE-ELECTRON
!     QUANTUM NOS, THE NECESSARY TERM HAS ALREADY BEEN EVALUATED,
!     THEREFORE PROCEED TO NEXT INTERACTION.
!
  300 ENDDO               !END SLATER-STATE INTERACTION LOOP
!
!
!     IF THE COEFFICIENTS OF THE SPIN-ORBIT PARAMETERS IN THE MATRIX
!     ELEMENT HAVE NOT BEEN COMPLETELY CALCULATED, RETURN - SPOR1 WILL
!     BE CALLED AGAIN, FOR DIFFERENT (MS,ML) GIVING THE SAME MS+ML=QMJ.
!
      IF(BLX)RETURN
!
!     ELIMINATE COEFFICIENTS /DRKPS/.LT.TYNY AND ARGUMENTS QRLPS THAT
!     HAVE BEEN LISTED BEFORE IN THE REFERENCE LIST
!     IF(KF.GT.0)RETURN
!
  400 ICLRS=0
      IF(IRKPS.LT.IRKPS0)RETURN
!
      K=IRKPS0-1
      KP=0
      DO I=IRLPS1,IRLPS
        IORIG1(I)=0
      ENDDO
!
      DO I=IRKPS0,IRKPS
!
        JD0=NRKPS(I)
        JD=ABS(JD0)
        IF(ABS(DRKPS(I)).LT.TYNY)THEN
          IF(IORIG1(JD).GT.0)GO TO 600
          JD0=0               !RE-INDEX QRLPS AS MAY OCCUR LATER
          GO TO 450
        ENDIF
!
        K=K+1
        DRKPS(K)=DRKPS(I)
        NSTJ1(K)=NSTJ1(I)
        NSTJ1D(K)=NSTJ1D(I)
!
  450   IF(JD.LE.IRLPS0)THEN
          WRITE(MW6,*)'SPOR1: INFORM NRB OF STOP HERE'
          WRITE(MW0,*)'SPOR1: INFORM NRB OF STOP HERE'
          NF=-1
          GO TO 700
!        LP=JD
!        GO TO 92
        ENDIF
!
        IF(IORIG1(JD).EQ.0)THEN
          LP=JD-KP
          DO L=1,IRLPS0
            DO J=1,2
              IF(QRLPS(J,JD).NE.QRLPS(J,L))GO TO 460
            ENDDO
            KP=KP+1
            IORIG1(JD)=L
            LP=L
            GO TO 500
  460     ENDDO
        ELSE
          LP=IORIG1(JD)
          GO TO 500
        ENDIF
!
        IORIG1(JD)=LP
        DO J=1,2
          QRLPS(J,LP)=QRLPS(J,JD)
        ENDDO
!
  500   IF(JD0.NE.0)THEN
          NRKPS(K)=LP
!          IF(JD0.LT.0)NRKPS(K)=-NRKPS(K)
        ENDIF
!
  600 ENDDO
!
!
      IRLPS=IRLPS-KP
      IRKPS=K
!
!-----------------------------------------------------------------------
!
  700 RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE SPOR1F
!
!                             *******************
!
      SUBROUTINE SPOR2(mam,nam,KK)
!
!-----------------------------------------------------------------------
!
!  SR.SPOR2 EVALUATES ALGEBRAIC CONTRIBUTIONS TO THE SPIN-ORBIT MATRIX
!  ELEMENTS BY LOOPING OVER ALL SLATER-STATE INTERACTIONS - NRB.
!
!  IT IS CALLED BY:
!    SR.ALGEB3
!
!  IT CALLS:
!    SR.RE_ALLOC
!    SR.RE_ALLOC2
!
!-----------------------------------------------------------------------
!
!!      COMMON /BASIC/NF,KF,KG,JGAP(4),IGAP,NJ2,NJP2,MGAP(2)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KF=>IBSK2,KG=>IBSK3,IBSK4=>IBSK4,IBSK5=>IBSK5      &
     &              ,IBSK6=>IBSK6,IBSK7=>IBSK7,IBSK8=>IBSK8,NJ2=>IBSK9  &
     &              ,NJP2=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_DC,     ONLY: BFAST,DC
      USE COMMON_COEFF,  ONLY: DRKP,QRLP,IRLP,NRKP
      USE COMMON_COEFF,  ONLY: IRKP,IRKP0
      USE COMMON_COEFFS, ONLY: DRKPS,QRLPS,NRKPS
      USE COMMON_COEFFS, ONLY: IRKPS,IRKPS0,IRLPS,IRLPS0
      USE COMMON_NSTS1,  ONLY: NADS1,NSTJ1,NSTJ1D,IORIG1,JORIG1
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC,RE_ALLOC2
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M9)
      PARAMETER (TTYNY=10*TYNY)
!
      DIMENSION mam(*),nam(*)
!
!-----------------------------------------------------------------------
!
      IRLP0=IRLP
!      IRLP1=IRLP0+1
!
      DO J=1,IRLPS
        JORIG1(J)=0
      ENDDO
!
! BEGIN MAIN LOOP 65 OVER SLATER STATE INTERACTIONS
!
      K0=NADS1(KK-1)+1
!
      DO KS=K0,NADS1(KK)
!
        L1=NSTJ1(KS)
        L2=NSTJ1D(KS)
!
        IF(BFAST)THEN
          DDH=DC(L1+NJ2)*DC(L2+NJP2)*DRKPS(KS)
        ELSE
          m1=mam(l1)
          if(m1.eq.0)go to 100
          m2=nam(l2)
          if(m2.eq.0)go to 100
          DDH=DC(m1)*DC(m2)*DRKPS(KS)
        ENDIF
!
        IF(ABS(DDH).LT.TYNY)GO TO 100
!
        N=NRKPS(KS)
        L=JORIG1(N)
        IF(L.GT.0)THEN
          K=IORIG1(L)
          DRKP(K)=DRKP(K)+DDH
        ELSE
!
! CANNOT FIND AN OLD SET OF ARGUMENTS EQUAL TO THE NEW SET, SO
! MUST START CONSTRUCTING A NEW COEFFICIENT.
!
          L=IRLP+1
          IF(L.GT.IXSOI)THEN
!
            IXXX=7*(IXSOI/5+1)
!
            WRITE(MW6,*)'*** SPOR2: increasing MXSOI from ',IXSOI,      &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** SPOR2: increasing MXSOI from ',IXSOI,      &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC2(QRLP,IONE,IFOUR,IONE,IXSOI,IFOUR,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'SPOR2: RE-ALLOCATION FAILS FOR QRLP'
              NF=0
              GO TO 300
            ENDIF
!
            IXXX0=MAX(IXS1I,IXSOI)
            IXXX1=MAX(IXS1I,IXXX)
            IF(IXXX1.GT.IXXX0)CALL RE_ALLOC(IORIG1,IONE,IXXX0,IXXX1,    &
     &         IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'SPOR2: RE-ALLOCATION FAILS FOR IORIG1'
              NF=0
              GO TO 300
            ENDIF
!
            IXSOI=IXXX
!
          ENDIF
!
          IRKP=IRKP+1
          IF(IRKP.GT.IXSOC)THEN
!
            IXXX=7*(IXSOC/5+1)
!
            WRITE(MW6,*)'*** SPOR2: increasing MXSOC from ',IXSOC,      &
     &                  ' to: ',IXXX
            WRITE(MW0,*)'*** SPOR2: increasing MXSOC from ',IXSOC,      &
     &                  ' to: ',IXXX
!
            CALL RE_ALLOC(DRKP,IONE,IXSOC,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'SPOR2: RE-ALLOCATION FAILS FOR DRKP'
              NF=0
              GO TO 300
            ENDIF
!
            CALL RE_ALLOC(NRKP,IONE,IXSOC,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'SPOR2: RE-ALLOCATION FAILS FOR NRKP'
              NF=0
              GO TO 300
            ENDIF
!
            IXSOC=IXXX
!
          ENDIF
!
          IRLP=L
          QRLP(1,L)=QRLPS(1,N)
          QRLP(2,L)=QRLPS(2,N)
          QRLP(3,L)=0
          QRLP(4,L)=0
          JORIG1(N)=L
          IORIG1(L)=IRKP
          NRKP(IRKP)=L
          DRKP(IRKP)=DDH
!
        ENDIF
!
  100 ENDDO
!
! IF THE MATRIX ELEMENT HAS BEEN CALCULATED CLEAR THE ARRAY  DRKP
! OF ZEROS AND ADJUST NRKP.
!
      IF(IRKP.LT.IRKP0)RETURN
!
      K=IRKP0-1
      N1=0
!
      DO I=IRKP0,IRKP
        IF(ABS(DRKP(I)).LT.TTYNY)GO TO 250
        K=K+1
        DRKP(K)=DRKP(I)
        N2=INT(NRKP(I),SP)
        LP=N2-N1
        DO L=1,IRLP0
          DO J=1,2
            IF(QRLP(J,N2).NE.QRLP(J,L))GO TO 150
          ENDDO
          LP=L
          GO TO 200
  150   ENDDO
        N1=N1-1
        DO J=1,2
          QRLP(J,LP)=QRLP(J,N2)
        ENDDO
  200   NRKP(K)=LP
  250   N1=N1+1
      ENDDO
!
      IRLP=IRLP-N1
      IRKP=K
!
!-----------------------------------------------------------------------
!
  300 RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE SPOR2
!
!                             *******************
!
      SUBROUTINE STOPOT(Z,MIONX,MK,AJUST0,DX1,MPOT,MI,MTI,DXI,X,POT,TOL &
     &                 ,MEND,MPP)
!
!-----------------------------------------------------------------------
!
!                N.R. BADNELL    D.A.M.T.P.   CAMBRIDGE
!
!  SR.STOPOT CALCULATES A SLATER-TYPE-ORBITAL UNIVERSAL POTENTIAL, FOR
!  MIONX ELECTRONS - WHICH MAY BE N- (SR.RADIAL) OR N+1 (SR.RADCON).
!
!  BORT=.FALSE.
!  FOR MIONX ELECTRONS, FILL UP PRINCIPAL QUANTUM NUMBER SHELLS WITH
!  MIONX-1 ELECTRONS. ADJUSTABLE PARAMETER IS APPLIED TO ALL SHELLS.
!
!  BORT=.TRUE.
!  CALCULATE NEW STO POTENTIAL FOR EACH NL ORBITAL MK, BASED ON
!  CONFIGURATION NO MCFSTO(MK). IF NONE SPECIFIED THEN
!  AVERAGES NUMBER OF ELECTRONS FOR EACH ORBITAL OVER NUMBER OF
!  CONFIGURATIONS WHICH CONTAIN THEM. EXCLUDE CORRELATION CONFIGS
!  ALSO, EXCLUDE VALENCE DR, CONTINUUM AND SPECTATOR ELECTRONS.
!  ELECTRON WITH PRINCIPAL QUANTUM NUMBER NS IS A SPECTATOR ELECTRON
!  IF THERE ARE NO ELECTRONS WITH P.Q. NO NS-1 IN ANY OF THE CONFIGS
!  IF REQUIRE INPUT OF CONTINUUM ORBITALS FROM RADWIN RESET
!  DKEY TO 999, SEE BELOW.
!  SHELL NUMBER EQUALS PRINCIPAL QUANTUM NUMBER I.E. MC(N)=N.
!  ADJUSTABLE PARAMETER SCALES RADIAL COORDINATE AND IS APPLIED
!  TO ALL SHELLS, FOR NOW.
!
!  QUANTITIES REQUIRED: TOL AND ALL ARGUMENTS UP TO DX
!
!  Z=NUCLEAR CHARGE, MIONX=NUMBER OF ELECTRONS IN THE ION
!
!  ADJUST=SCALING PARAMETER (A VALUE GT 1.0 CONTRACTS THE EFFECTIVE
!  RADIAL SCALE, I.E. Z FALLS OFF MORE SLOWLY TOWARDS RESIDUAL ZN.
!
!  DXI(J),J=1,MI=STEP LENGTH IN THE J'TH INTERVAL -- STEP LENGTH IS
!  DOUBLED IN SUCCESSIVE INTERVALS, DX1=DXI(1) IS INPUT - SO ARE THE
!  NUMBERS MTI(J) OF STEPS IN THE MI INTERVALS J
!
!  DX(I),I=1,MPOT=RADIAL DISTANCE AT THE MPOT RADIAL POINTS I;
!  MPOT MUST BE EITHER EXACT OR LE 0 AND WILL BE EXACT ON RETURN.
!
!  MEND=INDEX OF THE LAST POINT FOR WHICH THE EFFECTIVE CHARGE HAS
!  NOT NECESSARILY THE RESIDUAL VALUE ZN; FOR X.GT.X(MEND) THE
!  POTENTIAL IS ZN/X=(Z-MIONX+1)/X. IF THE RANGE X(MPOT) IS TOO
!  SMALL FOR THE EFFECTIVE CHARGE TO DROP TO ZN CONTROL IS RETURNED
!  WITH DX1=2*DX1 -- WHILE DXI(1) CONTAINS THE ORIGINAL DX1.
!
!  POT(I),I=1,MPOT=VALUE OF THE POTENTIAL AT THE POINTS X(I).
!  POT(I) WAS STORED IN /COM1/- POT,TOL,MEND NOW OUTPUT THROUGH
!  ARGUMENT LIST & THEN STORED IN /COM1/IN RADIAL FOR USE IN RADWAV.
!
!  X(MEND) IS LAST POINT FOR WHICH POT*X/ZN .GT. TOL (TYPICALLY=0
!  THEN POTENTIAL IS COULOMB TO 1% AT DX(MEND))
!
!  IT IS CALLED BY:
!    SR.RADCON
!    SR.RADCX0
!    SR.RADIAL
!    SR.RADWIN
!
!  IT CALLS:
!    SR.POTIN
!    SR.VPNL
!    FN.ZEFX
!
!  IT CONTAINS:
!    FN.PSTO
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CADJ,   ONLY: DALAN,BALAN
      USE COMMON_CCLSH,  ONLY: NW,NNL
      USE COMMON_CMESH,  ONLY: MHF,MRAD,MSTEP,IXTRA,xmax
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_MINIM,  ONLY: MPNCH,KUTCAS,BPRINT
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBDW,  ONLY: IDW,btop
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBSTO, ONLY: ALF,TEL,MSHELL,MCFSTO,MC,MCFMX,MEXPOT    &
     &                        ,NOCC,IOCC,NLSTOE,BFIX,BSTO,MXSHLL,NGAPSTO&
     &                        ,MEXPOT0,ISTATIC,faca,facsp,fac_csi,faclam&
     &                        ,ifacy,potx
      USE COMMON_NRBVAL, ONLY: FACT,IVAL,NNEW,NNOLD,BJUMP,BJUMP2,BRAD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      CHARACTER(LEN=3) LABG
!
      PARAMETER (TOLH=D1M2)
      PARAMETER (TOLW=D1M3)    !TOLERANCE FOR MATCHING OCCUPATION NOS WK
!
      ALLOCATABLE :: MEL(:)
      ALLOCATABLE :: CAV(:),PAV(:)
!
      DIMENSION POT(*),X(*),DXI(*),MTI(*)
!
      DATA MP0/0/,MP00/0/
!
      save iswch,iswch0,iswch1                 !case iterating user nocc
!
!-----------------------------------------------------------------------
!
! CHECK HISTORIC USAGE
!
      IF(Z.EQ.DZERO)THEN
        WRITE(MW0,*)'*** ERROR: SR.STOPOT NO LONGER INITIALS DX1,',     &
     &              ' CALL SR.MESH INSTEAD'
        WRITE(MW6,*)'*** ERROR: SR.STOPOT NO LONGER INITIALS DX1,',     &
     &              ' CALL SR.MESH INSTEAD'
        GO TO 1300
      ENDIF
!
! GO READ EXTERNAL POTENTIAL (& RETURN)
!
      IF(MHF*MK.GT.0)THEN
!
        CALL POTIN(-Z,MIONX,MK,MPOT,X,POT,MEND)   !-Z FLAGS STOPOT CALL
!
        GO TO 1200                                !RETURN
!
      ENDIF
!
! SOME INITIALIZATIONS
!
      BPRNT0=BPRINT
      IF(BPRINT)BPRNT0=JPRINT.NE.-3
      BPRNTS=BPRNT0.AND.(JPRINT.GT.0.OR.MCFMX.LE.0)
!
      BREL2=ABS(IREL).EQ.2
      BORT=MORT.LT.0
!
      IF(MPP.LT.MP0)MP0=MPP
!
      NOCCM=MOD(NOCC,I1000)
!
      MCFMXX=MCFMX
      IF(MCFMXX.GT.I1000)MCFMXX=0         !AVERAGE OVER MOD(MCFMX,I1000)
!
!     DTOL=0.01
      DTOL=TOL
!
!     DKEY=999                            !FLAG EXCLUDE RADWIN FROM POT
      DKEY=5999                           !FLAG EXCLUDE RYDBERG AS WELL
!
! NEGATIVE SCALING PARAMETERS/LAMDAS FLAG SCREENED HYDROGENIC
!
      AJUST=AJUST0
      IF(ABS(AJUST).LT.D1M2.AND.MPP.LT.2)AJUST=DONE      !FOR DIRECT STO
!
      IF(AJUST.LT.DZERO)THEN
        TA=-AJUST*Z
        TB=(DONE+AJUST)*Z
        ZH=Z/DTWO
        MEND=1
        DO J=1,MPOT
          T=EXP(-ZH*X(J))            !HISTORIC CUSP CONDITION AT ORIGIN
          T=T*TB
          POT(J)=(TA+T)/X(J)
          IF(ABS(T/TA).GT.TOLH)MEND=J
        ENDDO
        IF(MEND.LT.MPOT)GO TO 1200                !RETURN
        DX1=DX1+DX1
        T=T/X(MEND)
        WRITE(MW6,10070)AJUST,X(MEND),POT(MEND),T
        GO TO 1200                                !RETURN
      ENDIF
!
! DETERMINE INITIAL ASYMPTOTIC CHARGE
!
      ZN=1-MIONX
      ZN=Z+ZN
!      ZN1=ZN
!      IF(NINT(ZN1,SP).EQ.IZERO)ZN1=DONE
!
! IF ONLY ONE ELECTRON IS PRESENT THE POTENTIAL IS PURELY COULOMBIC
!
      IF(MIONX.EQ.1)THEN
        MEND=1
        DO I=1,MPOT
          POT(I)=ZN/X(I)
        ENDDO
        GO TO 1200                                !RETURN
      ENDIF
!
      ISWCH0=0                  !FLAG IF WE HAVE N AND N+1 ELECTRON CFGS
      DO I=1,MXORB
        IF(QN(I).LT.0.OR.IVAL(I).NE.0.OR.SCREEN(I).GE.D7999)ISWCH0=1
      ENDDO
      IF(MK.GT.MXORB)ISWCH0=1                    !CONT, CASE IDW.NE.0
!
      BNLSUB=(MIONX-ISWCH0).GT.NLSTOE.OR.BALAN   !RESOLVE BY NL-SUBSHELL
!
      ISWCH=0                   !FLAG IF MK IS RYD/CONT
      IF(QN(MK).LT.0.OR.IVAL(MK).NE.0.OR.SCREEN(MK).GE.D7999)ISWCH=1
!
! ONLY CORRECT HARTREE-SLATER FOR NON-RYD/CONT, SO
      BHSCRT=ISWCH.EQ.0
! THIS ASSUMES ANY UNIQUE POTENTIAL IS GENERATED BY A CALL TO STOPOT
! WITH AN MK THAT GIVES ISWCH=0, E.G. BOUND, WHICH IS THE NORM.
!
      IF(MCFMXX.LT.0.AND.ISWCH.EQ.1)THEN       !CASE IF -MCFMX TOO LARGE
        KF=KMAX
        IF(KCUT.GT.0.AND.IEQ(0).GE.0)KF=MIN(KCUT,KMAX)
                                                      !NO NEED 4 IEQ=-1?
        DO K=1,KF
          I=QCG(NF,K)
          IF(QN(I).LT.0.OR.IVAL(I).NE.0.OR.SCREEN(I).GE.D7999)MCFMXX=K
        ENDDO
        MCFMXX=-MCFMXX
      ENDIF
!
! GO TO SELF-CONSISTENT
!
      IF(MPP.GT.1)GO TO 1100
!
      IF(BORT)GO TO 600
!
! V(LL) POTENTIAL (HISTORIC)
!
!      MXSHLL=10
      ALLOCATE(MEL(MXSHLL))
!
      IOK=2
      NN=MIONX-1
      MS=0
      IF(NN.GT.88)MS=-1                                   !JUICYS
!
      IF(MSHELL.GT.0)GO TO 500
      IF(MS.EQ.0)GO TO 100
!
      MSHELL=2
      MEL(1)=88
      MEL(2)=NN-88
      GO TO 500
!
  100 MC(1)=1
      MEL(1)=2
      MC(2)=2
      MEL(2)=8
!
      IF(NN.GT.56)GO TO 200
!
      MC(3)=3
      MEL(3)=8
      MC(4)=4
      MEL(4)=2
      MC(5)=3
      MEL(5)=10
      MC(6)=4
      MEL(6)=6
      MC(7)=5
      MEL(7)=2
      MC(8)=4
      MEL(8)=10
      MC(9)=5
      MEL(9)=6
      MC(10)=6
      MEL(10)=2
      GO TO 300
!
  200 MC(3)=3
      MEL(3)=18
      MC(4)=4
      MEL(4)=18
      MC(5)=5
      MEL(5)=8
      MC(6)=6
      MEL(6)=2
      MC(7)=4
      MEL(7)=14
      MC(8)=5
      MEL(8)=10
      MC(9)=6
      MEL(9)=6
      MC(10)=7
      MEL(10)=2
!
  300 DO I=1,MXSHLL
        NN=NN-MEL(I)
        IF(NN.LE.0)GO TO 400
      ENDDO
!
  400 NN=NN+MEL(I)
      MEL(I)=NN
      MSHELL=I
!
  500 IF(NOCCM.NE.0)THEN
        MSHELL=ABS(NOCCM)
        IF(MSHELL.GT.MXSHLL)THEN
          WRITE(MW6,*)'*** SR.STOPOT: ONLY MXSHLL=',MXSHLL,             &
     &                ' SHELLS DEFINED','BUT USER NOCC GIVES MSHELL=',  &
     &                MSHELL
          WRITE(MW0,*)'*** SR.STOPOT: ONLY MXSHLL=',MXSHLL,             &
     &                ' SHELLS DEFINED','BUT USER NOCC GIVES MSHELL=',  &
     &                MSHELL
          GO TO 1300
        ENDIF
        WKT=0
        DO I=1,MSHELL
          WKT=WKT+TEL(I)
        ENDDO
        IF(ABS(WKT-MIONX).GT.TOLW)THEN
          WRITE(MW6,10150)WKT,MIONX
          WRITE(MW0,10150)WKT,MIONX
          GO TO 1300
        ENDIF
      ELSE
        WKT=0
        DO I=1,MSHELL
          TEL(I)=MEL(I)
          WKT=WKT+TEL(I)
        ENDDO
      ENDIF
      GO TO 1000
!
! V(NL) POTENTIAL
!
!
  600 CONTINUE
      IF(IRLX.LT.0)THEN                !NO COMMON CORE, CASE IEQ(0).GT.0
        MA0=0
        MB0=0
      ELSE                                                  !COMMON CORE
        MA0=MA
        MB0=MB
      ENDIF
      BCORE=IEQ(MK).GE.MA0.AND.IEQ(MK).LE.MB0              !IEQ UNNECESS
!
!      MXSHLL=10
      IF(BNLSUB)MXSHLL=MXORB
!
      ALLOCATE(MEL(MXSHLL))
!
      DO J=1,MXSHLL
        MC(J)=J
        IF(BNLSUB)THEN
!          if(balan)then
!            MC(J)=QL(J)/2+1
!          else
          MC(J)=MOD(INT(QN(J),SP),I70)              !CASE RADWIN FLAGGED
!          endif
        ENDIF
      ENDDO
!
      IF(BNLSUB)THEN
        MS=MK
        IF(QN(MK).LT.0)MS=-MS
        LABG='GAM'
      ELSE
        MS=QN(MK)
        MS=MOD(MS,I70)
        LABG='  N'
      ENDIF
!
! USER INPUT OCCUPATION NUMBERS
!
      iswch1=0
      IF(NOCCM.NE.0)THEN
        MSHELL=ABS(NOCCM)
        ms0=ms
        if(nocc.gt.0)then                     !unique/FAC, so
!          ms=0                    !need ms for any generation in radcon
          iswch=0
          iswch0=0
        else
          ms=0
          iswch1=1
        endif
        IOK=0
        WKT=0
        DO I=1,MSHELL
          IF(I.EQ.MK)IOK=NINT(TEL(I))         !ASSUMES INTEGER...
          WKT=WKT+TEL(I)
        ENDDO
        ZN=Z-WKT+1-iswch1
!        write(*,*)mionx,nw+nf
        MION1=MIONX-iswch1
        WW1=WKT-MION1
        IF(ABS(WW1).GT.TOLW)THEN
          IF(WW1.GT.TOLW)WW1=WW1-1
          IF(ABS(WW1).GT.TOLW)THEN
            if(nocc.lt.0)then
              WRITE(MW6,10150)WKT,MION1
              WRITE(MW0,10150)WKT,MION1
              GO TO 1300
            else
              WRITE(MW6,10160)WKT,MION1
!              WRITE(MW0,10131)WKT,MION1
!            go to 1300       !o.k. to proceed for fac
            endif
          ELSEIF(WW1.GT.-TOLW)THEN
!            MION1=MION1+iswch1
            if(nocc.lt.0)then
              WRITE(MW6,10150)WKT,MION1
              WRITE(MW0,10150)WKT,MION1
              ms=ms0
              IF(MS.LT.0.OR.IVAL(MK).GT.0.OR.IOCC.GT.MSHELL)MS=0
!              ZN=ZN+ISWCH0-ISWCH
              IF(MS.GT.0)THEN
                ZN=ZN+1
                WRITE(MW6,10170)ZN
                WRITE(MW0,10170)ZN
              ELSE
                WRITE(MW6,10180)ZN
                WRITE(MW0,10180)ZN
              ENDIF
              GO TO 1300     !should probably save user from themselves
            else
              WRITE(MW6,10160)WKT,MION1
!              WRITE(MW0,10131)WKT,MION1
!              go to 1300     !o.k. to proceed for fac
            endif
          ELSE
            WRITE(MW6,*)                                                &
     &         ' *** STOPOT: SHOULD PROBABLY HAVE AN ERROR MESSAGE HERE'
            WRITE(MW0,*)                                                &
     &         ' *** STOPOT: SHOULD PROBABLY HAVE AN ERROR MESSAGE HERE'
            GO TO 1300
          ENDIF
        ENDIF
        GO TO 1000
      ENDIF
!
! DETERMINE OCCUPATION NUMBERS FROM FLAGGED CONFIG(S)
!
      DO J=1,MXSHLL
        TEL(J)=DZERO
        MEL(J)=0
      ENDDO
!
      MSHELL=0
      KAV=0
      NZ=0
!
      IF(MCFMXX.GT.0)THEN
!        IF(MK.GT.MCFMXX)THEN                       !HISTORIC...
!          KS=MCFSTO(MCFMXX)
!        ELSE
        KS=MCFSTO(MK)
!        ENDIF
        IF(IEQ(0).GE.0.AND.KS.NE.0.OR.IEQ(0).LT.0.AND.BCORE)THEN
!
! DETERMINE OCCUPATION NUMBERS FOR CONFIG. SPECIFIED FOR THIS ORBITAL
! (N.B. MCFSTO(MK) NOT USER SPECIFIED FOR VALENCE, CASE IEQ(0).LT.0)
!
          KF=KS
          IF(KS.LE.0)THEN
            IF(BCORE)THEN                          !AVERAGE OVER ALL CFS
              KS=1
              KF=KMAX
            ELSE
              WRITE(MW6,10020)KS,MK
              WRITE(MW0,*)'SR.STOPOT: INVALID CONFIGURATION FOR ORBITAL'
              GO TO 1300
            ENDIF
          ENDIF
          IF(KS.GT.KMAX)THEN
            WRITE(MW6,10020)KS,MK
            WRITE(MW0,*)'SR.STOPOT: INVALID CONFIGURATION FOR ORBITAL'
            GO TO 1300
          ENDIF
          GO TO 700
!        ELSE
! FULLY RELAXED SO USES SINGLE CF OCC NOS
        ENDIF
      ENDIF
!
! USE CONFIGURATION AVERAGE
!
      KS=1
      KF=KMAX
      IF(IEQ(0).eq.0)THEN
        IF(KCUT.GT.0)KF=MIN(KCUT,KMAX)
        IF(MCFMX.GT.I1000)KF=MIN(MOD(MCFMX,I1000),KMAX) !SO NOT KCUT
        IF(mcfmxx.lt.0)kf=min(-mcfmxx,kmax)
      ENDIF
!
  700 bdw=idw.ne.0.and.qn(mk).lt.0
!           allow target average but an override for cont e.g. Laguerres
      if(bdw.and.mcfsto(mk).ne.0)then
        ks=mcfsto(mk)
        kf=ks
      endif
!
!***********************************************************************
! cont partial waves and/or rydberg l-mixing weight average occupation
! according to their number. to count only once, comment-out bskip0=.f.
! however, this is global.
! tbd: need to check parent complex/config depending on bnlsub t/f
! to see if has changed and re-set (see bskip1 check inside do k=ks,kf.
! (this assumes that the partial wave/ryd expansion on a parent config
! is sequential - cont is so if auto generated.)
! even with this, we are trying to second guess the optimum average for
! the user application. ultimately, the user should set for each orbital
! (via mcfmx) which config to use for ths occupation nos for the sto pot
! this (mcfmx) works for basis='srlx' in the same way as for nlam lambda
! it is not applicable for basis='rlx', of course.
! if (fully) implemented or switched-on "as-is" here, then it needs to
! be ported in sr.vpnl as well 9which mirros stopot) for plasma pot and
! 'scca'.
!***********************************************************************
!
      mf=0
! mk non-ryd and non-cont
      bskip0=qn(mk).gt.0.and.ival(mk).eq.0.and.screen(mk).lt.dkey
      bskip0=.false.                         !.f. switches-off operation
      bskip1=.false.
      bskip2=.false.
!
      DO K=KS,KF
!
        IF(.NOT.BCORE.and.mcfmxx.ge.0)THEN
!
! AVERAGE OVER ONLY THOSE CONFIGS THAT CONTAIN MK.
! (FIND THE CONFIG CONTAINING MK FOR CASE OF IEQ(0).LT.0 - LAZY...)
!
          MF=QCG(NF,K)
!
          DO I=1,NF
            IF(QCG(I,K).EQ.MK)THEN
              IF(IEQ(0).LT.0.AND.MCFSTO(MK).EQ.0)MCFSTO(MK)=K
              GO TO 750
            ENDIF
          ENDDO
!
          IF(IEQ(0).GT.0.AND.IEQ(MK).LE.MB)THEN         !CASE KCOR1.LT.0
            IGROUP=IGRCF(MK)
            IF(IGROUP.EQ.ICFGP(K))GO TO 750             !ORB IN CFG
            GO TO 900
          ENDIF
!
          IF(MCFMXX.LE.0.OR.MCFSTO(MK).EQ.0.OR.IEQ(0).LT.0)then
            if(bdw)go to 750
            GO TO 900
          ENDIF
!
! IF USER READ OF MCFSTO FOR SUBSET OF ORBITALS ONLY, TRY AND ENSURE
! NO IMBALANCE IN TARGET CONTINUUM
!OLD      IF(IVAL(MK).GT.0.OR.SCREEN(MK).GT.DKEY)GO TO 21
          IF(SCREEN(MK).GT.DKEY.AND.                                    &
     &       (QN(MF).LT.0.OR.IVAL(MF).NE.0.OR.SCREEN(MF).GT.DKEY).OR.   &
     &       bdw)GO TO 750
!
!          IF(IEQ(0).LT.0)GO TO 900
!
          MS=0
          IF(MHF.GE.-100.OR.MK.NE.MCFMXX)THEN     !NEED FOR POTOUT='YES'
            WRITE(MW6,10030)MK,K
            WRITE(MW0,*)                                                &
     &                '*****ERROR IN SR.STOPOT: ORBITAL NOT FOUND IN CF'
            GO TO 1300
          ENDIF
!
        ENDIF
!OLD   21   CONTINUE
!
! USE MCFMX.LT.0 TO AVERAGE OVER -MCFMX
!
  750   CONTINUE
!
! cont partial waves and/or rydberg l-mixing weight occupation to number
! to count only once, comment-out bskip0=.f.
!
        if(bskip0.and.mf.ne.0)then
! if only want to count a ryd/cont once
!          bskip1=qn(mf).lt.0.or.ival(mf).ne.0.or.screen(mf).gt.5999
! if only want to count a cont once
          bskip1=qn(mf).lt.0.or.screen(mf).gt.7999
        endif
!
! tbd: need to re-set bskip2 false if parent complex/config has changed
!
        if(bskip2)go to 900
        bskip2=bskip1
!
! EQUAL WEIGHTING, COULD TRY ALTERNATIVE......
!
        KAV=KAV+1
!
        N0=100
        IOK=0
        if(bdw)nz=nz+1
!
!        write(mw6,*)mk,ieq(mk),k
!
        DO I=1,MXORB
!          I=QCG(L,K)
          I1=NEL(I,K)
          IF(I1.LE.0)GO TO 800                              !ALL CORE
          IF(I.EQ.MK)IOK=IOK+I1
          MJ=MOD(QN(I),Q70)
          IF(BNLSUB)THEN
            J=I
          ELSE
            J=MJ
          ENDIF
          NZ=NZ+I1
          IF(IVAL(I).GT.0.AND.(QN(I).GE.ABS(QN(MK)).OR.QN(MK).LT.0))    &
     &       GO TO 800
!          if(dadjus(i).lt.dzero.and.qn(mk).lt.0)go to 800     !for dw
          IF(SCREEN(I).GT.DKEY)GO TO 800
          IF(QN(I).LT.0)GO TO 800
          IF(J.GT.MXSHLL)GO TO 800
          IF((MJ-N0).GT.NGAPSTO.AND.ABS(MS).LT.J)GO TO 800
          NZ=NZ-I1
          N0=MJ
          IF(J.GT.MSHELL)MSHELL=J
          MEL(J)=MEL(J)+I1
  800   ENDDO
!
        IF(MS.GT.MXSHLL.OR.MS.LT.0.OR.IVAL(MK).GT.0)NZ=NZ-1
!
  900 ENDDO
!
      IF(KAV.EQ.0)THEN
        IF(MCFMXX.EQ.0.AND.KF.LT.KMAX)THEN       !CORRELATION ORBITAL
          KF=KMAX                                   !NOT IN KCUT, SO
          GO TO 700
        ELSE
          WRITE(MW6,10010)MK,KF
          WRITE(MW0,*)                                                  &
     &               '*****ERROR IN SR.STOPOT: ORBITAL NOT FOUND IN CFS'
          GO TO 1300
        ENDIF
      ENDIF
!
      IF(MB.GT.0)THEN
        DO I=MA,MB
          MJ=QN(I)
          J=MOD(MJ,I70)
          IF(BNLSUB)J=I
          IF(J.GT.MSHELL)MSHELL=J
          MEL(J)=MEL(J)+2*(QL(I)+1)*KAV
        ENDDO
      ENDIF
!
! ADJUST ASYMPTOTIC CHARGE, BASED-ON ACTUAL MEL
      T1=KAV
      TZ=NZ
      TZ=TZ/T1
      ZN=ZN+TZ
!
      IF(MPP.EQ.0)THEN
        NZ=NINT(TZ,SP)
        IF(ABS(TZ-NZ).GT.TOLW)THEN          !FOR MCFMX.GT.0 NZ IS 0 OR 1
          IF(BPRNT0)WRITE(MW6,10100)TZ
!          WRITE(MW0,1001)TZ
!          GO TO 999
        ENDIF
      ENDIF
!      write(mw6,*)mk,ajust,zn
!
!      write(mw6,*)mk,kav
      WKT=0
      IF(BPRNTS)THEN
        WRITE(MW6,10110)LABG
      ENDIF
      DO J=1,MSHELL
        T2=MEL(J)
        TEL(J)=T2/T1
        WKT=WKT+TEL(J)
        IF(BPRNTS.AND.TEL(J).GT.TOLW)THEN
          IF(J.GT.-MB)WRITE(MW6,"(I4,F10.4)")J,TEL(J)
        ENDIF
      ENDDO
      IF(BPRNTS)THEN
        WRITE(MW6,10090)WKT
!        WRITE(MW6,10070)
      ENDIF
!
      IF(MS.LT.0.OR.IVAL(MK).GT.0)MS=0
!
! POTENTIAL RE-ENTRY POINT
!
 1000 CONTINUE
!
!      write(66,*)-mk,ajust
      DO J=1,MSHELL
        ALF(J)=AJUST
        IF(BALAN)THEN
          ALF(J)=DALAN(J)
          if(dalan(j).lt.dzero)then
            write(mw6,10120)j,dalan(j)
            write(mw0,                                                  &
     &   "('***SR.STOPOT: SUBSHELL POTENTIAL LAMBDAS MUST BE POSITIVE')"&
     &   )
            go to 1300
          endif
!          write(mw6,997)j,alf(j)
! 997      format(i5,3f16.6)
!          if(tel(j).ne.dzero)write(mw6,*)j,tel(j)
        ENDIF
      ENDDO
!
      DZ=-Z
      MEND=1
      TS=DONE
      MN=QN(MK)
      MN=ABS(MN)
      IF(IOK.EQ.1)MN=-MN
      ML=QL(MK)/2
      MSS=MS
      if(abs(mexpot0).eq.4)mss=0
!
! n.b. all static here
      if(nocc.gt.0)then                   !fac unique averaged potential
        BWEIGHT=ABS(MEXPOT0).NE.4                !WEIGHTING NEEDED
      else
        BWEIGHT=.FALSE.                          !AS NOT FAC
      endif
!
      if(nocc.le.0)then
!
! this just checks actual asymptotic charge against expected,
! if the historic juggling to set expected differs then actual prevails.
! it does *not* prevent fractional charges!
! note, wkt0 is actual, and will include any self-screening, whereas
! wkt, even with iswch/0, cannot describe nocc.lt.0.
!
        te=-zefx(mss,mn,ml,dz,ts,mshell,mc,tel,wkt0,alf,x(1),mexpot0,   &
     &     faca)
        te=te*x(1)
!      write(*,*)wkt-(iswch0-iswch),te,wkt0
        if(abs(te-wkt0).gt.dtol)then
          write(mw6,*)'*** warning zefx asymp charge, found & expected',&
     &                z-te,z-wkt0
          write(mw0,*)'*** warning zefx asymp charge, found & expected',&
     &                z-te,z-wkt0
        endif
        zn0=z-wkt0          !actual asymptotic charge, as defined by tel
        if(abs(zn0-zn).gt.dtol)then
          if(noccm.lt.0)then          !can't always correct sto when fac
            write(mw6,*)'Confusion over asymp charge, expected & found',&
     &                  zn,zn0
            write(mw0,*)'Confusion over asymp charge, expected & found',&
     &                  zn,zn0
          endif
          zn=zn0                                           !so "correct"
        endif
!
      elseif(.NOT.BWEIGHT)then
        PDUM=-ZEFX(MSS,MN,ML,DZ,TS,MSHELL,MC,TEL,WKT1,ALF,X(1),MEXPOT0, &
     &       FACA)
        ZN=Z-WKT1
      endif
!
      if(.NOT.BWEIGHT)then
!
        ZN1=ZN
        IF(NINT(ZN1,SP).EQ.IZERO)ZN1=DONE
!
        DO I=1,MPOT
!
          POT(I)=-ZEFX(MSS,MN,ML,DZ,TS,MSHELL,MC,TEL,WKT1,ALF,X(I),     &
     &           MEXPOT0,FACA)
!
          T=POT(I)*X(I)/ZN1
          IF(ABS(T).GT.DTOL)MEND=I
!
!       if(qn(mk).lt.0)then
!        write(66,887) i,x(i),pot(i),t
! 887    format(i5,3f16.6)
!       endif
!
          POT(I)=POT(I)+ZN/X(I)         !so lose info on no e- at origin
!
!        if(bprnt0)write(76,*)i,x(i),x(i)*pot(i),-pot(i)
!
        ENDDO
!
!        write(mw0,*)mk,wkt1
!      if(i.gt.0.and.qn(mk).lt.0)stop 'stopot'
!
      else                                !fac unique averaged potential
!
        ALLOCATE(CAV(MPOT),PAV(MPOT))
!
        DO I=1,MPOT
          PAV(I)=DZERO
          CAV(I)=DZERO
        ENDDO
!
        ZPS=Z
        DO K=1,MSHELL
!
          if(abs(tel(k)).gt.tolw)then
            MN=QN(K)
            MN=ABS(MN)
            N=MN
            IF(IOK.EQ.1)MN=-MN            !local exchange mexpot0=1-3...
            ML=QL(K)/2                    !cowan mexpot0=3
            MSS=QN(K)                     !n.b. bnlsub=.false. here
            if(abs(mexpot0).eq.4)mss=0
!
            ZPS=ZPS-(TEL(K)-1)/DTWO
!
            DO I=1,MPOT
!
              POTI=ZEFX(MSS,MN,ML,DZ,TS,MSHELL,MC,TEL,WKT1,ALF,X(I),    &
     &             MEXPOT0,FACA)
!
              PS=PSTO(N,ZPS,X(I))
!          write(77,*)i,x(i),ps
              T=PS*PS*TEL(K)
              PAV(I)=PAV(I)-POTI*T
              CAV(I)=CAV(I)+T
!
            ENDDO
!
            ZPS=ZPS-(TEL(K)+1)/DTWO
          endif
!
        ENDDO
!
        ZN=Z-WKT1
        ZN1=ZN
        IF(NINT(ZN1,SP).EQ.IZERO)ZN1=DONE
!
        DO I=1,MPOT
!         if(bprnt0)write(77,*)mend,i,x(i),pav(i),cav(i)
          IF(ABS(CAV(I)).LT.D1M70)GO TO 1050         !CONVERGED
          POT(I)=PAV(I)/CAV(I)
          T=POT(I)*X(I)/ZN1
          IF(ABS(T).GT.DTOL)MEND=I
          POT(I)=POT(I)+ZN/X(I)
!        if(bprnt0)write(77,*)i,x(i),x(i)*pot(i),-pot(i)
        ENDDO
        I=MPOT+1
!
 1050   ITEST=I
!
        DO I=ITEST,MPOT
          POT(I)=ZN/X(I)
        ENDDO
!
        DEALLOCATE(CAV,PAV)
!
      endif
!
      IF(ABS(MEXPOT0).EQ.4.AND.BHSCRT)THEN       !CORRECT ASYMPTOTICALLY
!
! just apply a non-smooth correction
!
        zn=zn+done
        do i=1,mpot
          zpx=pot(i)*x(i)
          if(zpx.lt.zn)pot(i)=zn/x(i)
        enddo
!
      ENDIF
!
!
      IF(MEND.GE.MPOT)THEN    !POT OUT-OF-CONTROL - UNPHYSICAL STOs?
        DX1=DX1+DX1           !HISTORIC FLAG
        T=ZN-POT(MPOT)*X(MPOT)
        WRITE(MW6,10070)AJUST,X(MPOT),ZN,T
!
!        do j=1,mend
!          write(66,887)j,x(j),pot(j),x(j)*pot(j),pot(j)-zn/x(j)
! 887      format(i5,4f16.6)
!        enddo
!
      ENDIF
      GO TO 1200                                  !RETURN
!
! SELF-CONSISTENT RE-ENTRY POINT (AFTER 1ST ITERATION)
!
 1100 CONTINUE
!
      IF(MSHELL.EQ.0)MSHELL=ABS(NOCCM)
      BPRNTX=BPRNT0.AND.MP00.EQ.0
!
      BSTATIC=MEXPOT.GE.ISTATIC
!
      if(nocc.gt.0)then                   !fac unique averaged potential
!
        BFIRST=MPP.gt.MP0.or.iswch.gt.0 !iswch.gt.0 for ryd/cont genrted
        IF(.NOT.BFIRST)GO TO 1200                !NULL CALL - NO UPDATES
!
        BTEST=ABS(MEXPOT).EQ.4.AND.BSTATIC       !NO WEIGHTING NEEDED
        BWEIGHT=.NOT.BTEST                       !ELSE, NEEDED
      else
        BFIRST=.FALSE.
        BWEIGHT=.FALSE.                          !AS NOT FAC
      endif
!
      IF(.NOT.BWEIGHT)THEN
!
! NOCC.LT.0 USES A DIFFERENT POTENTIAL FOR EACH ORBITAL.
! IF MCFMX IS SET APPROPRIATELY, IT CAN BE THE SAME AVERAGE
! POTENTIAL FOR EACH ORBITAL SAVE FOR THE OMITTED SELF-INTERACTION
! TERM I.E. THE ORBITALS ARE (STILL) NOT ORTHOGONAL.
! (ALSO FAC STATIC HARTREE-SLATER.)
!
        IF(BPRNTX)THEN
          if(BFIRST)then
            WRITE(MW6,10050)mb,NOCCM-mb,MCFMXX
          elseif(MCFMXX.LT.0)then
            WRITE(MW6,10040)NOCCM,MCFMXX
          else
            BPRNTX=.FALSE.
          endif
        ENDIF
!
        MP0=MPP
        IF(BPRNT0)MP00=MP0
!
        if(ifacy.eq.2020)then            !apply cut-off to direct only
          allocate(potx(mpot))           !so hold exchange
        endif
!
        mkk=mk
        if(noccm.ne.0)mkk=-mk                !flag use occ. nos. as-is
!
        CALL VPNL(Z,MIONX,MKK,WK,AJUST,MPOT,MI,MTI,DXI,POT,DTOL,MEND)
!
!        write(mw0,*)mpp,mk,wk
!        i77=70+mpp
!        do j=1,mend
!          t=pot(j)
!          if(ifacy.eq.2020)t=t+potx(j)
!          write(i77,887)j,x(j),x(j)*t
! 887      format(i5,3f10.6)
!        enddo
!
        WKT=0
        IF(BPRNTX)THEN
          DO J=1,MSHELL
            IF(ABS(TEL(J)).GT.TOLW)THEN
              WKT=WKT+TEL(J)
              WRITE(MW6,10060)J,TEL(J)
            ENDIF
          ENDDO
          WRITE(MW6,10090)WKT
          WRITE(MW6,10080)
        ELSE
          DO J=1,MSHELL
            IF(ABS(TEL(J)).GT.TOLW)THEN
              WKT=WKT+TEL(J)
            ENDIF
          ENDDO
        ENDIF
!
        if(noccm.ne.0)then
          mion1=mionx-iswch1
          btest1=abs(wkt-mion1).gt.tolw
          btest2=abs(wkt-mion1+iswch).gt.tolw
          btest3=abs(wkt-mion1+iswch0).gt.tolw
          if(btest1.and.btest2.and.btest3)then
            IF(BPRNT0)WRITE(MW6,10140)WKT,MION1,MK
            if(iswch.eq.1)then
              write(mw0,10140)wkt,mionx-iswch,mk
              if(.not.bprnt0)write(mw6,10140)wkt,mionx-iswch,mk
!              if(nocc.lt.0)go to 1300
            endif
          endif
        endif
!
      ELSE
!
! NOCC.GT.0 USES A SINGLE UNIQUE POTENTIAL BY AVERAGING OVER THE
! POTENTIALS USED FOR EACH ORBITAL - THE AVERAGE OF THE MODEL
! CONFIGURATION.
!
! not currently needed.
        iswch=0
        iswch0=0
!
        ALLOCATE(CAV(MPOT),PAV(MPOT))
!
        DO I=1,MPOT
          PAV(I)=DZERO
          CAV(I)=DZERO
        ENDDO
!
        IF(BPRNTX)WRITE(MW6,10050)mb,NOCCM-mb,MCFMXX
!
        WKT=0
        DO K=1,MSHELL
          BTEST1=DEY(K).NE.DZERO.AND.IVAL(K).EQ.0.AND.SCREEN(K).LT.DKEY
          btest2=noccm.eq.0.or.noccm.ne.0.and.tel(k).gt.tolw
          IF(BTEST1.and.btest2)THEN
!
            CALL VPNL(Z,MIONX,K,WK,AJUST,MPOT,MI,MTI,DXI,POT,DTOL,MEND)
!
!          if(mp00.eq.0)write(mw0,*)k,wk
            IF(BPRNTX.AND.WK.GT.TOLW)THEN
              WRITE(MW6,10060)K,WK
            ENDIF
            WKT=WKT+WK
            IF(WK.GT.TOLW)THEN
              DO I=1,MPOT
                TT=DPNL(I,K)*DPNL(I,K)
                IF(BREL2)TT=TT+DQNL(I,K)*DQNL(I,K)
                T=WK*TT                         !WEIGHT BY PROB. DENS. T
                PAV(I)=PAV(I)+POT(I)            !*T !IF NOT DONE IN VPNL
                CAV(I)=CAV(I)+T
              ENDDO
            ENDIF
          ENDIF
        ENDDO
!
        IF(BPRNTX)THEN
          WRITE(MW6,10090)WKT
          WRITE(MW6,10080)
        ENDIF
!
!        if(mp0.eq.0)write(mw0,*)wkt
        IF(ABS(WKT-MIONX).gt.TOLW.and.abs(wkt-mionx+iswch0).gt.tolw)THEN
          IF(BPRNT0)WRITE(MW6,10130)WKT,MIONX-iswch0
!          WRITE(MW0,1002)WKT,MIONX-iswch0
!          GO TO 999
        ENDIF
!
        MP0=MPP
        IF(BPRNT0)MP00=MP0
!
! (RE-) INITIALIZE POT
!
!        ZN=ZN+iswch0-iswch                 !can't predict user nocc, so
        zn=z-wkt+1
!
! this just checks actual asymptotic charge against expected,
! it does *not* prevent fractional charges!
!
        te=pav(mpot)*x(mpot)/cav(mpot)
!        write(*,*)zn,te
        if(abs(te-zn).gt.dtol)then
          if(noccm.eq.0)then
            write(mw6,*)'Confusion over asymp charge, expected & found',&
     &                  zn,te
            write(mw0,*)'Confusion over asymp charge, expected & found',&
     &                  zn,te
          endif
          zn=te            !correct
          itest=mpot-mpot/20
        else
          itest=mpot
        endif
!
        ZN1=ZN
        IF(NINT(ZN1,SP).EQ.IZERO)ZN1=DONE
!
        DO I=1,MPOT
          POT(I)=PAV(I)/CAV(I)
          T=POT(I)-ZN/X(I)
          T=T*X(I)/ZN1
          IF(ABS(T).GT.DTOL)MEND=I
!          if(bprnt0)write(77,*)i,x(i),x(i)*pot(i),cav(i)
!     &                         ,cav(i)/(4*xpi)/x(i)**2
        ENDDO
!
        if(.not.bprnt0.and.bprnt0)then             !i.e. off
!
          tp1=0
          tr1=0
          sump=0
          sumr=0
!
!          p1=0
!          cafe=0
!
          x1=0
          do i=1,mpot
            x0=x1
            x1=x(i)
!
            tp0=tp1
            tr0=tr1
            tp1=cav(i)
            tr1=cav(i)/(4*xpi)/x(i)**2
            sump=sump+(x1-x0)*(tp1+tp0)
            sumr=sumr+(x1-x0)*(tr1+tr0)
!
!            p0=p1
!            p1=pav(i)-z*cav(i)/x(i)
!            cafe=cafe+(x1-x0)*(p1+p0)
          enddo
!
          sump=sump/2
          sumr=sumr/2
          write(mw0,*)sump,sumr
!
!          cafe=cafe/4                                     !a.u.
!          write(mw0,*)'fac config. e-e av. energy=',cafe
!          write(mw6,*)'fac config. e-e av. energy=',cafe
!
        endif
!
        DEALLOCATE(CAV,PAV)
!
        IF(MEND.GE.ITEST)THEN
          MEND=MPOT
          T=POT(ITEST)*X(ITEST)
          WRITE(MW6,10190)MK,X(ITEST),ZN,T
        ENDIF
!
      ENDIF
!
      IF(ABS(MEXPOT).EQ.4.AND.BHSCRT)THEN        !CORRECT ASYMPTOTICALLY
!
! determine a fit for z(x) = (z-n+1)+(n-1)exp(-lam*x) valid at all r.
! match to hartree-slater at user/default charge z(xi), which defines xi
! then lam=-log{[z(xi)-(z-n+1)]/(n-1)}/xi
! n.b. at the mid-point z(xi)=(z+z-n+1)/2,  lam=log(2)/xi
!
        ALLOCATE(CAV(MPOT),PAV(MPOT))
!
        ZN=POT(MPOT)*X(MPOT)                !hartree asymp charge
        zpa=zn+done                         !correct asymp charge
!
        TE=Z-ZN                             !no of electrons
        te1=te-done                         !no of screening electrons
!
        if(facsp.lt.0)then
          zpi=(z+zpa)/2                     !at mid-point
          facsp=-zpi
        else                                !user supplied
          fzhigh=pot(1)*x(1)-d1m8
          zpi=min(facsp,fzhigh)
          fzlow=zpa+d1m8
          zpi=max(zpi,fzlow)
        endif
!,
        ta2=min(fac_csi,z-zpa)
!
        zpi2=zpa+ta2
!
        ii=1
        i2=1
        do i=1,mpot
          zpx=pot(i)*x(i)
          cav(i)=zpx
          if(zpx.gt.zpi)ii=i                !matching point for fit 5
          if(zpx.gt.zpi2)i2=i               !fac hartree-slater adjust
        enddo
        i2=min(i2,mpot-1)                   !incase off, ii is bounded
!
        ii0=ii
        if(abs(cav(ii)-zpi).gt.abs(zpi-cav(ii+1)))ii=ii+1
!        if(ii.gt.ii0)write(*,*)cav(ii0),zpi,cav(ii)
!
        ii2=i2
        if(abs(cav(i2)-zpi2).gt.abs(zpi2-cav(i2+1)))i2=i2+1
!        if(i2.gt.ii2)write(*,*)cav(ii2),zpi2,cav(i2)
!
        xii=x(ii)
        xi2=x(i2)
!
! case 5:
! replaces hartree-Slater with the above fit over x(ii) to x(mpot)
!
        zpii=pot(ii)*xii                    !=zpi=matching charge
!        zpii=zpi
        tz0=(zpii-zpa)
!
!        nm=3
!        np=3
!        zpdii=(cav(ii-nm)-cav(ii+np))
!        zpdii=zpdii/(log(x(ii-nm))-log(x(ii+np)))
!        zpdii=zpdii/xii                     !charge deriv at matching
!
        tlam0=dzero
        if(tz0.ne.dzero)then
          tl=te1/tz0
          if(tl.gt.dzero)tlam0=log(tl)
        endif
!
        t5=0.0                              !non-zero test only
        t5r=done+t5*xii
        tlam5=tlam0-log(t5r)
        tlam5=tlam5/xii
!       tlam5=-zpdii/tz0-t5/t5r              !matches derivative
!
        faclam=tlam5
!
!        write(mw0,*)'xii,tlam=',xii,zpii,tlam5
!
        ii2=-mpot                           !.lt.0 uses HS at all x
!
!        m177=170+mpp
!
        DO I=ii,ii2
!
          tt5=zpa+te1*exp(-tlam5*x(i))/(done+t5*x(i))
!
          POT(I)=TT5/X(I)
!
!          write(m177,*)i,x(i),cav(i),tt5,cav(i)-tt5
        ENDDO
!        call flush(m177)
!
        if(ii2.gt.0)go to 1150              !uses fit to "correct"
!
! case 2:
! corrects hartree-slater charge Z_HS, which is Z-N asymptotically,
! for x.gt.x2 by adding 1+a*exp[(x2-x)*b],
! where x2 is defined by Z_HS(x2)=Z-N+1+a
! and -a*b is the derivative Z_HS(x2).
! the fac default is a=0.55
!
        if(ta2.lt.-done)go to 1150
!
        nm=0
        np=1
!
!        if(allocated(potx))then              !add-back exchange
!          cav(i2)=cav(i2)+potx(i2)*x(i2)
!          if(np.gt.0)cav(i2+np)=cav(i2+np)+potx(i2+np)*x(i2+np)
!          if(nm.gt.0)cav(i2-nm)=cav(i2-nm)+potx(i2-nm)*x(i2-nm)
!        endif
!
        ta2=cav(i2)-zpa
        if(allocated(potx))ta2=ta2+potx(i2)*x(i2)  !don't double count
!        write(*,*)'a=',ta2
        tb2=(cav(i2+np)-cav(i2-nm))/(log(x(i2-nm))-log(x(i2+np)))
        tb2=tb2/xi2
!        tb2=(cav(i2+np)-cav(i2-nm))/(x(i2-nm)-x(i2+np))
!
!        call diff(cav,pav,MTI,DXI,MI)       !overkill as only need i2
!        write(mw0,*)xi2,tb2,-pav(i2)        !and fac uses 2-point
!        tb2=-pav(i2)
!
        tb2=tb2/ta2
        tb2=abs(tb2)                         !case increasing zpa!
!
!        write(mw0,*)'xi2,a,b=',xi2,ta2,tb2
!
!        m180=180+mpp
!
        DO I=i2+1,MPOT
!
          tt2=zpa+ta2*exp(-(x(i)-xi2)*tb2)
!
          POT(I)=TT2/X(I)
!
!          tt5=zpa+te1*exp(-tlam5*x(i))/(done+t5*x(i))
!          write(m180,*)i,x(i),cav(i),tt2,tt5,tt2-tt5
        ENDDO
!        call flush(m180)
!
 1150   DEALLOCATE(CAV,PAV)
!
        if(allocated(potx))then              !add-back exchange
          do i=1,i2
            pot(i)=pot(i)+potx(i)
          enddo
          deallocate(potx)
        endif
!
      ENDIF
!
!-----------------------------------------------------------------------
!
 1200 CONTINUE
!
      IF(ALLOCATED(MEL))DEALLOCATE(MEL)
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
 1300 NF=-1
      GO TO 1200
!
!-----------------------------------------------------------------------
!
10010 FORMAT(' *** ERROR IN SR.STOPOT: ORBITAL',I4,' NOT FOUND IN',     &
     &       ' THE FIRST',I4,' CONFIGURATIONS')
10020 FORMAT(' *** ERROR IN SR.STOPOT: NON-VALID CONFIGURATION',I3,     &
     &       ' SPECIFIED FOR ORBITAL ',I3)
10030 FORMAT(' *** ERROR IN SR.STOPOT: ORBITAL ',I3,                    &
     &       ' NOT FOUND IN CONFIGURATION ',I3)
10040 FORMAT(//' CONFIGURATION AVERAGE OCCUPATION NUMBERS FOR NOCC=',I3,&
     &       5X,'MCFMX=',I5//' GAM',6X,'WOCC')
10050 FORMAT(//' FAC CONFIGURATION AVERAGE OCCUPATION NUMBERS FOR NOCC='&
     &       ,I1,'+',I2,5X,'MCFMX=',I5//' GAM',6X,'WOCC')
10060 FORMAT(I4,F10.4)
10070 FORMAT(' *** SR.STOPOT (ADJUST,X(MPOT),COUL-POT(MPOT),NON-COUL) ='&
     &       ,                                                          &
     &       4F10.5/'  RETURN AND EXTEND RADIAL MESH - UNPHYSICAL STOs?'&
     &       )
10080 FORMAT(//)
10090 FORMAT(/' SUM',F10.4/)
10100 FORMAT(' *** SR.STOPOT: WARNING, ASYMPTOTIC CHARGE= Z-N+',F6.2)
10110 FORMAT(//' STO POTENTIAL OCCUPATION NUMBERS:'//' ',A3,6X,'WOCC')
10120 FORMAT(/' ***SR.STOPOT: SUBSHELL POTENTIAL LAMBDAS MUST BE',      &
     &       ' POSITIVE: SUBSHELL, LAMBDA=',I5,F10.4)
10130 FORMAT(' *** SR.STOPOT: SR.VPNL GIVES FICTIONAL AVERAGE CF',      &
     &       ' WITH WK.NE.MION:',F6.2,I3)
10140 FORMAT(' *** SR.STOPOT: SR.VPNL GIVES FICTIONAL AVERAGE CF',      &
     &       ' WITH WK.NE.MION:',F6.2,I3,' FOR ORBITAL',I3)
10150 FORMAT(' *** SR.STOPOT: USER INPUT NOCC GIVES',' WK.NE.MION-1:',  &
     &       F6.2,I3)
10160 FORMAT(' *** SR.STOPOT: USER INPUT NOCC GIVES',' WK.NE.MION:',    &
     &       F6.2,I3)
10170 FORMAT(' *** SR.STOPOT: ATTEMPTING TO REMOVE SELF-SCREENING,',    &
     &       ' ASYMPTOTIC CHARGE SEEN BY AN ELECTRON IS:',F6.2)
10180 FORMAT(' *** SR.STOPOT: SELF-SCREENING IS *NOT* REMOVED,',        &
     &       ' ASYMPTOTIC CHARGE SEEN BY AN ELECTRON IS:',F6.2)
10190 FORMAT(' *** SR.STOPOT: NOT ENOUGH MESH POINTS FOR ORBITAL?',I5,  &
     &       ' CHECK IF ASYMPTOTIC POTENTIAL ACCURATE ENOUGH:',1P,      &
     &       3E11.3)
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION PSTO(N,Z,X)
!
! CALCULATES STO P_N(X) FOR CHARGE Z.
!
      INTEGER (SP) N
      REAL (WP) Z,X,PSTO,T
!
      T=Z*X/N
      PSTO=(2*T/LDFS)**N*EXP(-T)*SQRT(2*Z/(N*DFS(2*N+1)))
!
      END FUNCTION PSTO
!-----------------------------------------------------------------------
!
      END SUBROUTINE STOPOT
!
!                             *******************
!
      SUBROUTINE STORAD(ZA,MAXRS,MAXPS,MXORB)
!
!-----------------------------------------------------------------------
!
!  SR.STORAD INITIALIZES DPNL TO STO'S.
!
!  IT IS CALLED BY:
!    SR.VMPOT
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
      DO I=1,MXORB
        IF(DEY(I).EQ.DZERO)GO TO 100
        IF(QN(I).LT.0.OR.QN(I).GT.10)GO TO 100
        N=QN(I)
        XNT=1                                    !AVOID INTEGER OVERFLOW
        DO J=1,N
          XNT=XNT*2*J*(2*J-1)
        ENDDO
        AN=REAL(N*XNT/2,WP)
        AN=SQRT(ZA/AN)
        T=N
        T=ZA/T
        DO J=1,MAXRS
          DPNL(J,I)=DZERO
          TX=T*DX(J)
          IF(TX.LT.D1P2)DPNL(J,I)=AN*(TX+TX)**N*EXP(-TX)
          IF(ABS(DPNL(J,I)).GT.D1M6)MAXPS=MAX(MAXPS,J)
        ENDDO
  100 ENDDO
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE STORAD
!
!                             *******************
!
      SUBROUTINE SYMLS
!
!-----------------------------------------------------------------------
!
!  SR.SYMLS
!     DETERMINES THE LSP SYMMETRIES AND CHANNEL LIST BASED-UPON THE USER
!     SPECIFIED MINST, MAXST  & MINLT, MAXLT, OR DIRECT LSP INPUT,
!
!  IT IS CALLED BY:
!    SR.ALGX
!
!  IT CALLS:
!    SR.DIMUSE
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_MINIM,  ONLY: BECOR
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_QTG,    ONLY: MTGD,NXLL,NTT,NTG,JTGD,QTGS,QTGL,QTGD    &
     &                        ,NFI,NFK,NFQ
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      use common_misc,   only: ione1,ione0
!
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,INAST0=>NASTB                            &
     &                        ,INASTJ0=>NASTJB,LFACT,JFACT              &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
      USE COMMON_NRBDW4, ONLY: DSPECE,INDEX,JNDEX,NSPECE,NENERG
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBDWX, ONLY: LLCH,ITARG,NCHG,INASTX,NCHMX,MAXLX0
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBIAD, ONLY: IADD
      USE COMMON_NRBKUT, ONLY: KCUTX,LSKUT,NASTK
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBNF1, ONLY: DEK,BFALL,KUTOO
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
! if elastic is dropped here then it has an effect on inelastic
! transitions between terms of same symmetry because they are mixed
!
!old  ione0=0                                    !=0 retain elastic here
!
! if bcor then we have algebraic correlation, and we know how ordered
!
      bcor=kmax*kcut.ne.kcut*kcut
!
! if becor then we have correlation by energy, and we know not where, so
!
      beqgrpl0=.not.becor                       !false for full li=lf mx
!
! if only algebraic then can reduce memory requirement  NAD(NCOR)
!
      bcorr=bcor.and..not.becor.and.kcutx.ge.0
!
!-----------------------------------------------------------------------
!
! INITIALIZATIONS
!
      BKUTOO=KUTOOX.NE.0
!
      BPRNT0=JPRINT.NE.-3
!
      BTHRSH=LVMAX.GE.0
!
! SCATTERING SYMMETRY RESTRICTIONS
!
      IF(MXLAMX.EQ.1000)THEN                     !MAX EXCHANGE MULTIPOLE
        IF(MAXLX.GE.100)THEN
          MXLAMX=NXLL+3                      !TWICE MAX ORB L+3 (was +1)
        ELSE
!          MXLAMX=(MAXLX+1)/2
          MXLAMX=MAXLX-NXLL/2
        ENDIF
      ENDIF
!
!      IF(MAXLX.GE.100)MAXLX=2*MXLAMX                !MAX L FOR EXCHANGE
      IF(MAXLX.GE.100)MAXLX=MXLAMX+NXLL/2            !MAX L FOR EXCHANGE
      IF(INAST0.LE.0.AND.MAXLX.LT.MAXLT+2)THEN
        MAXLX=MAX(MAXLX,INT(QCL0/2-1,SP))  !ALL CHANNELS TO SCALE DIRECT
      ENDIF
!T      MAXLX0=MAXLX           !PASS THRU TO FLGLX1,RESX1 FOR CHECK ONLY
!
      IF(MAXLOO.GE.100)MAXLOO=MAXLX
!
      WRITE(MW6,10070)
      WRITE(MW6,10120)MAXLX
      IF(MXLAMX.NE.1000)WRITE(MW6,10010)MXLAMX
      IF(NMULTX.LT.100)WRITE(MW6,10020)NMULTX
      IF(BKUTOO)WRITE(MW6,10030)MAXLOO
!
      IF(INAST0.GT.0)THEN
!
        WRITE(MW6,10130)
        MAXLT=0
        DO I=1,INAST0
          IS=LSPI(I)/10000
          IP=LSPI(I)-IS*10000
          IL=IP/10
          IP=IP-IL*10
          WRITE(MW6,10140)I,IS,IL,IP
          MAXLT=MAX(MAXLT,IL)
        ENDDO
        MAXLT=-MAXLT                                    !FLAG FOR ALGXLS
!
      ELSE
!
        IF(ABS(MODD).GT.1)THEN
!
          IF(BTHRSH)THEN
!
            MAXL=LVMAX+QCL0/2
            IF(MAXLT.EQ.1000)MAXLT=MAXL
            IF(MAXLT.GT.MAXL)THEN
              WRITE(MW6,10070)
              WRITE(MW6,10080)MAXL,LVMAX
              WRITE(MW6,10070)
              MAXLT=MAXL
            ELSEIF(MAXLT.LT.MAXL)THEN
              WRITE(MW6,10070)
              WRITE(MW6,10090)MAXLT,LVMAX,MAXL
              WRITE(MW6,10070)
!              MAXLT=MAXL                     !ALLOW USER TO RESTRICT...
            ENDIF
!
            MINL=LVMIN-QCL0/2
            MINL=MAX(IZERO,MINL)
            IF(MINLT.GT.MINL)THEN
              WRITE(MW6,10070)
              WRITE(MW6,10100)MINLT,LVMIN,MINL
              WRITE(MW6,10070)
!              MINLT=MINL                     !ALLOW USER TO RESTRICT...
            ELSEIF(MINLT.LT.MINL)THEN
              WRITE(MW6,10070)
              WRITE(MW6,10110)MINL,LVMIN
              WRITE(MW6,10070)
              MINLT=MINL
            ENDIF
!
          ELSE
!
            IF(MAXLT.EQ.1000)MAXLT=30
            IF(MAXLT.GT.100)THEN
              MAXLT=100
              WRITE(MW0,*)'*** SR.SYMLS: REDUCING MAXLT TO',MAXLT
              MINLT=MIN(MINLT,MAXLT)
            ENDIF
!
            IF(MINLT.LT.0)MINLT=0
!
          ENDIF
!
        ENDIF
!
        IF(MINSP.LT.1)MINSP=1                 !2S+1 TOT
        I1=MOD(INT(QCS0,SP),ITWO)
        I0=MOD(MINSP-1,ITWO)
        IF(I0.EQ.I1)MINSP=MINSP+1
        MAXSP=MIN(MAXSP,INT(QCS0+2,SP))
!
        WRITE(MW6,10150)MINSP,MAXSP,MINLT,MAXLT
!
        IF(IPAR.NE.2)WRITE(MW6,10160)IPAR
        IPAR=ABS(IPAR)
        IPAR=MOD(IPAR,ITHREE)                     !0-EVEN, 1-ODD, 2-BOTH
        IPART=MAX(IONE,IPAR)
!
      ENDIF
!
      WRITE(MW6,10070)
!
! SET-UP SCATTERING SYMMETRY LIST
!
      IF(INAST0.GT.0)THEN
!
        INAST=INAST0
        INASTX=999
        IFORE=0
        LFACT=100                                  !OVERRIDE USER/ALGEB0
!
      ELSE
!
        INAST=0
        INASTX=0                   !999 for no use of symmetry,0 for use
!par        inastx=999                                              !par
        IFORE=(MAXSP-MINSP)/2
        IF(MINSP.GT.1)IFORE=IFORE+1
        IFORE=IFORE*IPART
!
        IP0=MOD(IPAR,ITWO)
        IP1=MIN(IPAR,IONE)
        FACTL=REAL(LFACT,WP)/D100
        IL=MINLT
        IAXSL=0
!
   50   DO IS=MINSP,MAXSP,2
          DO IP=IP0,IP1
            INAST=INAST+1
            BLX=INAST.LE.IAXSL
            IF(BLX)LSPI(INAST)=10000*IS+10*IL+IP
          ENDDO
        ENDDO
!
        if(lfact.gt.100)il0=il
        IF(IL.GT.MAX(MAXLX,15_SP))IL=NINT(IL*FACTL,SP)
        IL=IL+1
        IF(IL.LE.MAXLT)GO TO 50
!
        IF(IAXSL.EQ.0)THEN
          ALLOCATE(LSPI(INAST))
          IAXSL=INAST
          INAST=0
          IL=MINLT
          GO TO 50
        ENDIF
!
        if(lfact.gt.100)then
          if(lrglam.gt.il0)lrglam=il0               !case factl "misses"
          maxlt=il0
        endif
!
        CALL DIMUSE('MAXSL',INAST)
!
        IF(INAST.GT.MAXSL)THEN
          IF(MAXSL.GT.0)WRITE(MW6,10050)INAST,MAXSL
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      IXCHG=0
      IX=0
      DO I=1,INAST
        IX=IX+1
        IS=LSPI(IX)/10000
        IP=LSPI(IX)-IS*10000
        IL=IP/10
        IP=IP-IL*10
        MTS=IS-1
        MTL=IL+IL
        MTP=IP+IP
!
        NN=0
        DO N=1,NSL0
          IF(QSI(N)+1.ne.MTS.and.QSI(N)-1.ne.MTS)GO TO 100
          if(il.gt.maxlx.and.qsi(n).gt.mts)go to 100                 !nx
          LCON=MIN(INT(QLI(N),SP),LCONDW-1)
          LMIN=ABS(MTL-LCON)
          LMAX=MTL+LCON
          I1=MOD(LMAX,IFOUR)
          IF(MTP.NE.ABS(I1-QPI(N)))THEN                    !ALIGN PARITY
            LMAX=LMAX-2
            LMIN=LMIN+2
          ENDIF
          IF(LMAX.GE.LMIN)NN=NN+1
  100   ENDDO
        IXCHG=MAX(IXCHG,NN)
      ENDDO
!
! EX-COMMON/NRBDWX/
      ALLOCATE(LLCH(2,IXCHG,INAST),ITARG(IXCHG,INAST),NCHG(INAST),      &
     &         STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SYMLS: ALLOCATION FAILS FOR LLCH,ITARG,NCHG'
        GO TO 200
      ENDIF
!
! EX-COMMON/NRBGRP/
      ALLOCATE(NADG(INAST),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SYMLS: ALLOCATION FAILS FOR NADG'
        GO TO 200
      ENDIF
!
!-----------------------------------------------------------------------
!
! SET-UP CHANNEL LIST BY GROUP
!
      MXX=0                          !SEE ACTUAL USAGE (.LE.NSL0)
      NNN=0
      NCHTOT=0
      NCHMX=0
      INAST0=INAST                     !SINCE WILL REDUCE IF NO CHANNELS
      IX=0
      IPAR4=0
      ncorr=0
!
      DO I0=1,INAST0
!
        IX=IX+1
        IS=LSPI(IX)/10000
        IP=LSPI(IX)-IS*10000
        IL=IP/10
        IP=IP-IL*10
!                                                                 !ALIGN
        MTS=IS-1
        MTL=IL+IL
        MTP=IP+IP
!
        LUP=0
        LLOW=999
        NN=0
        DO N=1,NSL0
          IF(QSI(N)+1.ne.MTS.and.QSI(N)-1.ne.MTS)GO TO 150
          if(il.gt.maxlx.and.qsi(n).gt.mts)go to 150                 !nx
          LMIN=INT(QLI(N),SP)
          LCON=MIN(LMIN,LCONDW-1)
          LMIN=ABS(MTL-LMIN)
          lmin=max(lmin,abs(mtl-lcon))      !case mtl.lt.lcondw-1.lt.qli
          I1=MOD(LMIN,IFOUR)
          IF(MTP.NE.ABS(I1-QPI(N)))LMIN=LMIN+2             !ALIGN PARITY
          LMAX=MTL+LCON
          I1=MOD(LMAX,IFOUR)
          IF(MTP.NE.ABS(I1-QPI(N)))LMAX=LMAX-2             !ALIGN PARITY
          IF(LMAX.GE.LMIN)THEN
            NN=NN+1
            BLY=NN.LE.IXCHG
            IF(BLY)THEN
              ITARG(NN,IX)=N
              LLCH(1,NN,IX)=LMIN
              LLCH(2,NN,IX)=LMAX
            ENDIF
            QSNX=QSI(N)
            LUP=MAX(LUP,LMAX)
            LLOW=MIN(LLOW,LMIN)
          ENDIF
  150   ENDDO
!
! SINCE WE ARE KEYED ON SMALL L. (THIS IS "APPROXIMATE" FOR 2FS!)
!
!        IF(BTHRSH.AND.(LVMAX.LT.LLOW/2.OR.LVMIN.GT.LUP/2))NN=0  !DROP
!
! Can't use if scaling non-exchange since indexing currently assumes
! same S present for each Lp, i.e. we can use MAXST or IPAR (or MAXLT)
! since the same selection is applied to ALL symmetries but cannot vary
! selection between symmetries. Not a big saving since it likely only
! affects a couple of symmetries on the final L. So, re-working the
! NX indexing is not a high priority esp. since BTHRSH is ADAS-specific.
!
        IF(NN.GT.0)THEN
          MXX=MAX(MXX,NN)
          NWT=IS
          if(il.gt.maxlx)nwt=-2*(qsnx+1)                          !nx
!
          IF(BPRNT0)WRITE(MW6,10170)IX,NWT,IL,IP
!
          NCHG(IX)=NN
          NADG(IX)=NNN-ncorr
!
!          nchs=0
          NCHL=0
          IF(BLY)THEN
            DO N=1,NN
              NC=ITARG(N,IX)
              MC=NSL(NC)
              MCI=NGRPI(NC)
              L1=LLCH(1,N,IX)
              L2=LLCH(2,N,IX)
              LD=((L2-L1)/4+1)
              NCH=MC*LD
              DO L=L1,L2,4
                DO M=1,MC
                  J1=M+MCI
                  NCHL=NCHL+1
!                  if(jndex(j1).gt.0)nchs=nchs+1
                  IF(BPRNT0)WRITE(MW6,10180)NCHL,J1,L/2
!                write(mw6,1118)nch,j1,qsi(j1)+1,qli(j1)/2,qpi(j1)/2,l/2
                ENDDO
              ENDDO
              DO NP=1,N
                ND=ITARG(NP,IX)
                beqgrp=nc.eq.nd
                beqgrpl=beqgrpl0.and.beqgrp
                IF(NMETAG(NC)+NMETAG(ND).LT.2)THEN
                  IF(beqgrp)THEN
                    LDP=(LD*(LD+1))/2
                    LD=1
                    NCH=MC
                  ELSE
                    L1P=LLCH(1,NP,IX)
                    L2P=LLCH(2,NP,IX)
                    LDP=((L2P-L1P)/4+1)
                  ENDIF
                  MCP=NSL(ND)
                  NCHP=MCP*LDP
                  NNN=NNN+NCH*NCHP
                  if(bcorr)then
                    nco=0
                    nce=0
!            do li=l1,l2,4
!              lf2=l2p
!              if(nc.eq.nd)then
!                lf2=li
!                l1p=llch(1,np,ix)
!              endif
!              do lf=l1p,lf2,4
                    mcip=ngrpi(nd)
                    do m=1,mc
                      j1=m+mci
                      j=jndex(j1)
                      do mp=1,mcp
                        j1p=mp+mcip
!                        if(j1p.gt.j1-ione0.and.li.eq.lf)go to 61
                        jp=jndex(j1p)
                        if(j.lt.0.and.jp.lt.0)then
                          nco=nco+1                         !corr.-corr.
                          if(j1.eq.j1p)nce=nce+1
                        endif
                      enddo
!   61                 continue
                    enddo
!               enddo
!             enddo
                    ncorr=ncorr+nco*ld*ldp
                  endif
                ENDIF
              ENDDO
              IF(beqgrpl.and.NMETAG(NC).LT.1)THEN
                LD=(L2-L1)/4+1
                MM=MC+ione0
                NNN=NNN-LD*(MM*(MM-1))/2                   !FOR LI.EQ.LF
                if(bcorr)ncorr=ncorr-ld*(nco-nce)/2        !for li.eq.lf
              ENDIF
            ENDDO
            NCHMX=MAX(NCHMX,NCHL)
            NCHTOT=NCHTOT+NCHL
          ENDIF                                  ! nchs,
          IF(.NOT.BPRNT0)WRITE(MW6,10190)IX,NWT,IL,IP,NCHL
        ELSE                                            !QUIETLY DISCARD
          INAST=INAST-1
          IF(IL.GT.MAXLX.AND.IS.GT.1)IPAR4=1
          LHOLD=LSPI(IX)
          DO I=IX+1,INAST0
            NCHG(I-1)=NCHG(I)
            NADG(I-1)=NADG(I)
            LSPI(I-1)=LSPI(I)
          ENDDO
          NCHG(INAST0)=0                                !NO LS CHANNELS
          NADG(INAST0)=-1                               !FLAG
          LSPI(INAST0)=LHOLD                            !NEED FOR 2FS?
          IX=IX-1
        ENDIF
!
        IF(IL.LE.MAXLX)INASTX=MAX(INASTX,IX)
!
      ENDDO
!
      CALL DIMUSE('MXCHG',MXX)
      if(mxx.ne.ixchg)write(mw0,*)'ixchg=',ixchg,mxx
!
      IF(IXCHG.GT.MXCHG)THEN
        IF(MXCHG.GT.0)WRITE(MW6,10060)IXCHG
      ENDIF
!
      IADD=NNN-ncorr                           !for corr.-corr. omission
!
!      if(ncorr.gt.0)then
!        write(mw0,*)iadd,ncorr,iadd-ncorr
!        stop   'ncorr test'
!      endif
!
      IF(MAXLT.LT.0)THEN         !NO SCALING, EXCHANGE CAN BE OFF THOUGH
        INASTX=INAST
      ELSE
        INASTX=INASTX+2*(IFORE-IPAR4)                !FURTHER THAN XCHNG
        INASTX=MIN(INASTX,INAST)
      ENDIF
!OLD INASTX WAS PASSED THRU TO SR.ALGXLS VIA COMMON/BASIC/....
!      NAST=INAST
!
!-----------------------------------------------------------------------
!
      RETURN
!
  200 WRITE(MW6,10040)
      NF=-1                                                       !ABORT
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(/44X,' MAX EXCHANGE LAMDA (MXLAMX)=',I3)
10020 FORMAT(/44X,' No. OF MULTIPOLES (NMULTX) =',I3)
10030 FORMAT(/44X,' MAX  2-BODY NFS  L (MAXLOO)=',I3)
10040 FORMAT(' SR.SYMLS: FAILURE - CASE SKIPPED')
10050 FORMAT('***SR.SYMLS: ALLOCATION INCREASES NUMBER OF SYMMETRIES ', &
     &       ' IAXSL =',I3,' .GT. MAXSL=',I3)
10060 FORMAT('***SR.SYMLS: ALLOCATION INCREASES NUMBER OF CHANNEL ',    &
     &       'GROUPS  IXCHG =',I3,' .GT. MXCHG=',I3)
10070 FORMAT(//1X,136('-')//)
10080 FORMAT(/' NOTE: REDUCING MAXLT TO',I3,', THAT NEEDED BY LVMAX=',  &
     &       I3)
10090 FORMAT(/' ***WARNING: YOU HAVE SET MAXLT=',I3,', LESS THAN THAT', &
     &       ' FORMALLY NEEDED BY LVMAX=',I3/22X,'SET MAXLT=',I3,       &
     &       ', TO SATISFY TRIANGLE RELATION')
10100 FORMAT(/' ***WARNING: YOU HAVE SET MINLT=',I3,', GREATER THAT',   &
     &       ' FORMALLY NEEDED BY LVMIN=',I3/22X,'SET MINLT=',I3,       &
     &       ', TO SATISFY TRIANGLE RELATION')
10110 FORMAT(/' NOTE: INCREASING MINLT TO',I3,', THAT NEEDED BY LVMIN=',&
     &       I3)
10120 FORMAT(' *** PARTIAL WAVE SYMMETRY RESTRICTIONS:',5X,'MAXIMUM',   &
     &       ' EXCHANGE L (MAXLX) =',I3)
10130 FORMAT(//'   SY 2S+1  L  (P-0/1 FOR EVEN/ODD)',5X,                &
     &       '*** NO TOP-UP ***')
10140 FORMAT(1X,4I4)
10150 FORMAT(//' MINST=',I2,3X,'MAXST=',I2,5X,'MINLT=',I2,3X,'MAXLT=',  &
     &       I3)
! 1118 format(7x,i8,i9,3i4,i10)
10160 FORMAT(/' PARITY IPAR=',i2)
10170 FORMAT(/' SY=',I3,5X,'(2S+1) L P =',I3,I4,I3/13X,'CH',8X,'T',3X,  &
     &       'SMALL L')
10180 FORMAT(7X,I8,I9,I10)
10190 FORMAT(' SY=',I3,5X,'(2S+1) L P =',I3,I4,I3,5X,'NCHT=',I6)
!     &      ,2X,'(',I6,')')
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE SYMLS
!
!                             *******************
!
      SUBROUTINE SYMLSJ
!
!-----------------------------------------------------------------------
!
!  SR.SYMLSJ
!     DETERMINES THE LSJ SYMMETRIES AND CHANNEL LIST BASED-UPON THE USER
!     SPECIFIED MINJT, MAXJT. OR DIRECT JP INPUT, AND CHECKS CONSISTENCY
!     WITH ANY SUPPLIED LSP, MAXJFS.
!
!  IT IS CALLED BY:
!    SR.ALGX
!
!  IT CALLS:
!    SR.DIMUSE
!    SR.NUMSYM
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_MINIM,  ONLY: BECOR
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      use common_misc,   only: ione1,ione0
!
      USE COMMON_NRBDW,  ONLY: IDW                                      &
     &                        ,INAST0=>NASTB                            &
     &                        ,INASTJ0=>NASTJB,LFACT,JFACT              &
     &                        ,KUTLSX,MAXLX,KUTSSX,MAXJFS,KUTOOX,MAXLOO &
     &                        ,NMULTX,MXLAMX,LRGLAM,btop
      USE COMMON_NRBDW2, ONLY: LCONDW,LCONDWJ,MTJ,LVMIN,LVMAX
      USE COMMON_NRBDW4, ONLY: DSPECE,INDEX,JNDEX,NSPECE,NENERG
      USE COMMON_NRBDWJ, ONLY: JSYMM,NCHGJ,NADGJ,NCHMXJ
      USE COMMON_NRBDWM, ONLY: NMETA,NMETAJ,NMETAG,NMETGJ
      USE COMMON_NRBDWX, ONLY: LLCH,ITARG,NCHG
      USE COMMON_NRBGRP, ONLY: NGRPI,NADG
      USE COMMON_NRBIAD, ONLY: IADJ                     !,IADJT
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,INASTJ=>NASTJ                   &
     &                        ,MINJT,MAXJT,NEIGENJ
      USE COMMON_NRBKUT, ONLY: KCUTX,LSKUT,NASTK
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,INAST=>NAST                   &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
! if elastic is dropped here then it has an effect on inelastic
! transitions between terms of same symmetry because they are mixed
!
!old  ione0=0                                    !=0 retain elastic here
!
! if bcor then we have algebraic correlation, and we know how ordered
!
      bcor=kmax*kcut.ne.kcut*kcut
!
! if becor then we have correlation by energy, and we know not where, so
!
      beqgrpl0=.not.becor                       !false for full li=lf mx
!
! if only algebraic then can reduce memory requirement  NAD/J(NCOR/J)
!
      bcorr=bcor.and..not.becor.and.kcutx.ge.0
!
!-----------------------------------------------------------------------
!
! INITIALIZATIONS
!
      BPRNT0=JPRINT.NE.-3
      BTEST=BPRNT0         !.TRUE.                    !DETAILED PRINTOUT
!
      BTHRSH=LVMAX.GE.0
!
! SCATTERING SYMMETRY RESTRICTIONS
!
      MTEST=MOD(INT(QCS0,SP),ITWO)
      WRITE(MW6,10060)
      WRITE(MW6,10070)MXLAMX
!
      IF(INASTJ0.GT.0)THEN
!
        WRITE(MW6,10080)
        INASTJ=INASTJ0
        IX=0
        DO I0=1,INASTJ0
          IX=IX+1
          IJ=JPI(IX)/10
          IF(IJ.LE.MAXJT)THEN            !LEGACY OF MAXJFS, NOT ON MAXLT
            IP=JPI(IX)-IJ*10
            WRITE(MW6,10090)IX,IJ,IP
            IF(MOD(IJ,ITWO).EQ.MTEST)THEN
              WRITE(MW6,10140)
              WRITE(MW0,*)                                              &
     &                  '***SR.SYMLSJ ERROR: ILLEGAL TOTAL 2J REQUESTED'
              GO TO 300
            ENDIF
          ELSE                                          !QUIETLY DISCARD
            INASTJ=INASTJ-1
            jhold=jpi(ix)
            DO J=IX+1,INASTJ0
              JPI(J-1)=JPI(J)
            ENDDO
            jpi(inastj0)=jhold
            IX=IX-1
          ENDIF
        ENDDO
        MAXJT=-1                                        !FLAG FOR FUTURE
!
      ELSE
!
        IF(MAXJT.GT.200)MAXJT=60
        IF(MINJT.LT.0)MINJT=0
        IF(MOD(MINJT,ITWO).EQ.MTEST)MINJT=MINJT+1
        IF(MOD(MAXJT,ITWO).EQ.MTEST)MAXJT=MAXJT-1
        IF(MOD(MAXJFS,ITWO).EQ.MTEST)MAXJFS=MAXJFS-1
        IF(MAXJFS.GT.MAXJT)THEN
          WRITE(MW6,10060)
          WRITE(MW6,10050)
          MAXJFS=MAXJT
        ENDIF
!
        WRITE(MW6,10100)MINJT,MAXJT
!
        IF(IPAR.NE.2)WRITE(MW6,10130)IPAR
        IPAR=ABS(IPAR)
        IPAR=MOD(IPAR,ITHREE)                     !0-EVEN, 1-ODD, 2-BOTH
!
      ENDIF
!
      WRITE(MW6,10060)
!
! SET-UP LSJ SCATTERING SYMMETRY LIST
!
      IF(INASTJ0.GT.0)THEN
!        INASTJ=INASTJ0                           !MAYBE REDEFINED ABOVE
        JFACT=200                                  !OVERRIDE USER/ALGEB0
      ELSE
!
        INASTJ=0
        IF(MINJT.GT.MAXJT)GO TO 100
!
        IP0=MOD(IPAR,ITWO)
        IP1=MIN(IPAR,IONE)
        FACTJ=REAL(JFACT,WP)/D200
        IJ=MINJT
        IAXJG=0
!
   50   DO IP=IP0,IP1
          INASTJ=INASTJ+1
          BLX=INASTJ.LE.IAXJG
          IF(BLX)JPI(INASTJ)=10*IJ+IP
        ENDDO
!
        if(jfact.gt.200)ij0=ij
        IF(IJ.GT.MAX(MAXJFS,30_SP))THEN
          IJ=NINT(IJ*FACTJ,SP)
          IF(MOD(IJ,ITWO).NE.MOD(MAXJT,ITWO))IJ=IJ-1
        ENDIF
        IJ=IJ+2
        IF(IJ.LE.MAXJT)GO TO 50
!
        IF(IAXJG.EQ.0)THEN
          ALLOCATE(JPI(INASTJ))
          IAXJG=INASTJ
          INASTJ=0
          IJ=MINJT
          GO TO 50
        ENDIF
!
        if(jfact.gt.200)then
          if(lrglam.gt.ij0)lrglam=ij0               !case factj "misses"
          maxjt=ij0
        endif
!
        CALL DIMUSE('MAXJG',INASTJ)
!
        IF(INASTJ.GT.MAXJG)THEN
          IF(MAXJG.GT.0)WRITE(MW6,10020)INASTJ,MAXJG
        ENDIF
!
      ENDIF
!
  100 IF(INASTJ.EQ.0)THEN                            !NO J-SYMMS
        WRITE(MW0,*)'ATTENTION: NO J-SYMMETRIES FOR BP...'
        WRITE(MW6,10040)
        RETURN                                        !<----------RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
      IXSYJ=0
      KX=0
      DO J=1,INASTJ
        KX=KX+1
        IJ=JPI(KX)/10
        IPJ=JPI(KX)-IJ*10
        JCOUNT=0
        CALL NUMSYM(IJ,IPJ,JCOUNT)            !NO. OF LSP SYMMS EXPECTED
        IXSYJ=MAX(IXSYJ,JCOUNT)
      ENDDO
!
! EX-COMMON/NRBDWJ/
      ALLOCATE(JSYMM(IXSYJ,INASTJ),NCHGJ(INASTJ),NADGJ(INASTJ),         &
     &         STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SYMJ: ALLOCATION FAILS FOR JSYMM,NCHGJ,NADGJ'
        GO TO 300
      ENDIF
!
!-----------------------------------------------------------------------
!
! IDENTIFY LSP SYMMETRIES WHICH GIVE RISE TO THE REQUESTED JPI ONES.
!     INASTJ IS THE ACTUAL NUMBER OF JP SYMMS TO BE USED.
!
      MXX=0
      NNN=0
      NNN2=0
      NCHTOT=0
      NCHMXJ=0
      INASTJ00=INASTJ                  !SINCE WILL REDUCE IF NO LS SYMMS
      KX=0
      ncorr=0
      ncorr2=0
      JFAIL=0
!
      DO J0=1,INASTJ00
!
        KX=KX+1
        IJ=JPI(KX)/10
        IPJ=JPI(KX)-IJ*10
!
        NN=0
        JCOUNT=0
        CALL NUMSYM(IJ,IPJ,JCOUNT)            !NO. OF LSP SYMMS EXPECTED
        IF(JCOUNT.EQ.0)GO TO 200              !NONE POSSIBLE
!
        DO IX=1,INAST0        !inast0,1,-1    !MIRRORS ALGEB3 TERM ORDER
          if(nchg(ix).eq.0)go to 150
          IS=LSPI(IX)/10000
          IP=LSPI(IX)-IS*10000
          IL=IP/10
          IP=IP-IL*10
!
          IF(IP.NE.IPJ)GO TO 150
!                                                                 !ALIGN
          MTS=IS-1
          MTL=IL+IL
!          MTP=IP+IP
          IF(ABS(MTL-MTS).GT.IJ.OR.(MTL+MTS).LT.IJ)GO TO 150
          NN=NN+1
          BLY=NN.LE.IXSYJ
          IF(BLY)THEN
            JSYMM(NN,KX)=IX
          ENDIF
  150   ENDDO
!
        IF(NN.LT.JCOUNT.AND..NOT.BTHRSH)THEN        !ALLOW IF BTHRSH
          CALL NUMSYM(IJ,IPJ,JCOUNT)                !PRINT MISSING SYMMS
          JFAIL=JFAIL+JCOUNT-NN
        ELSEIF(NN.GT.JCOUNT)THEN
          WRITE(MW6,*)'SR.SYMLSJ: DROPPING',NN-JCOUNT,'SPECIFIED SLP ', &
     &                'FOR JP SYJ=',KX,':',IJ,IPJ
!          write(mw0,*)'sr.symlsj: something amiss with slp vs jp...'
          IF(BLY.and.BTEST)THEN
            WRITE(MW6,*)'SYJ=',KX,':',IJ,IPJ
            DO N=1,NN
              IX=JSYMM(N,KX)
              IS=LSPI(IX)/10000
              IP=LSPI(IX)-IS*10000
              IL=IP/10
              IP=IP-IL*10
              nwt=is
              if(il.gt.maxlx)nwt=-2*is+2
              WRITE(MW6,*)'SYM=',IX,':',nwt,IL,IP
            ENDDO
          ENDIF
!          GO TO 999
        ENDIF
!
  200   IF(NN.GT.0)THEN
          MXX=MAX(MXX,NN)
!
          IF(BPRNT0)WRITE(MW6,*)' '
          IF(BTEST)WRITE(MW6,10110)KX,IJ,IPJ,NN
!
          NCHGJ(KX)=NN
          NADGJ(KX)=NNN2-ncorr2
!          write(mw0,*)'kx=',kx,' nadgj(kx)=',nadgj(kx)
!
          IF(BLY)THEN
            NCHJ=0
            DO NX=1,NN
              IX=JSYMM(NX,KX)
              IS=LSPI(IX)/10000
              IP=LSPI(IX)-IS*10000
              IL=IP/10
              IF(BPRNT0)THEN
                nwt=is
                if(il.gt.maxlx)nwt=-2*is+2
                WRITE(MW6,10120)IX,nwt,IL,IPJ
              ENDIF
              NCN=NCHG(IX)
              m1=1
              if(ij.gt.maxjfs)m1=nx
              DO MX=m1,NX
                JX=JSYMM(MX,KX)
                ISP=LSPI(JX)/10000
                IPP=LSPI(JX)-ISP*10000
                ILP=IPP/10
                NCNP=NCHG(JX)
!                write(mw0,*)'start symljs: ',kx,nx,mx,nnn2-ncorr2
                DO N=1,NCN
                  NC=ITARG(N,IX)
                  MC=NSL(NC)
                  L1=LLCH(1,N,IX)
                  L2=LLCH(2,N,IX)
                  LD=((L2-L1)/4+1)
                  NCH=MC*LD
                  if(bcorr)mci=ngrpi(nc)
                  if(ix.eq.jx)ncnp=n
                  DO NP=1,ncnp
                    ND=ITARG(NP,JX)
                    beqgrp=ix.eq.jx.and.nc.eq.nd
                    beqgrpl=beqgrpl0.and.beqgrp
                    btest1=(IS+ISP-2)*(IL+ILP).GT.0
                    btest2=abs(NMETAG(NC))+abs(NMETAG(ND)).lt.2
                    b2fs=ij.le.maxjfs.and.btest1.and.btest2
                    IF(NMETAG(NC)+NMETAG(ND).LT.2)THEN
                      IF(beqgrp)THEN
                        LDP=(LD*(LD+1))/2
                        LD=1
                        NCH=MC
                      ELSE
                        L1P=LLCH(1,NP,JX)
                        L2P=LLCH(2,NP,JX)
                        LDP=((L2P-L1P)/4+1)
                      ENDIF
                      MCP=NSL(ND)
                      NCHP=MCP*LDP
                      NADD=NCH*NCHP
                      NNN=NNN+NADD
                      if(b2fs)NNN2=NNN2+NADD
!
                      if(bcorr)then
                        nco=0
                        nce=0
!          do li=l1,l2,4
!            lf2=l2p
!            if(beqgrp)then
!              lf2=li
!              l1p=llch(1,np,ix)
!            endif
!            do lf=l1p,lf2,4
                        mcip=ngrpi(nd)
                        do m=1,mc
                          j1=m+mci
                          j=jndex(j1)
                          do mp=1,mcp
                            j1p=mp+mcip
!                if(ix.eq.jx.and.j1p.gt.j1-ione0.and.li.eq.lf)go to 61
                            jp=jndex(j1p)
                            if(j.lt.0.and.jp.lt.0)then
                              nco=nco+1                   !corr.-corr.
                              if(j1.eq.j1p)nce=nce+1
                            endif
                          enddo
!   61                   continue
                        enddo
!             enddo
!           enddo
                        naddc=nco*ld*ldp
                        ncorr=ncorr+naddc
                        if(b2fs)ncorr2=ncorr2+naddc
                      endif
                    ENDIF
                  ENDDO
                  if(beqgrpl.and.nmetag(nc).lt.1)then
                    LD=(L2-L1)/4+1
                    MM=MC+ione0
                    NADD=LD*(MM*(MM-1))/2
                    NNN=NNN-NADD             !FOR LI.EQ.LF
                    if(b2fs)NNN2=NNN2-NADD
                    if(bcorr)then
                      naddc=ld*(nco-nce)/2
                      ncorr=ncorr-naddc  !for li.eq.lf
                      if(b2fs)ncorr2=ncorr2-naddc
                    endif
                  endif
                  if(ix.eq.jx)nchj=nchj+nch
                ENDDO
!                write(mw0,*)'end symlsj: ',kx,nx,mx,nnn2-ncorr2
              ENDDO
            ENDDO
!                write(mw0,*)'end symlsj: ',kx,nnn2,-ncorr2
!       write(mw0,*)'nchj=',nchj
            NCHMXJ=MAX(NCHJ,NCHMXJ)
            NCHTOT=NCHTOT+NCHJ
          ENDIF
        ELSE                                            !QUIETLY DISCARD
          INASTJ=INASTJ-1
          jhold=jpi(kx)
          DO J=KX+1,INASTJ00
            NCHGJ(J-1)=NCHGJ(J)
            NADGJ(J-1)=NADGJ(J)
            JPI(J-1)=JPI(J)
          ENDDO
          nchgj(inastj00)=0                             !no j channels
          nadgj(inastj00)=-1                            !flag
          jpi(inastj00)=jhold                           !need?
          KX=KX-1
        ENDIF
!
      ENDDO
!
!      NASTJ=INASTJ                                              !RE-SET
!      IADJT=NNN-ncorr                               !NOT USED CURRENTLY
      IADJ=NNN2-ncorr2                                !ONLY USED BY 2-FS
!
      IF(JFAIL.GT.0)THEN
        WRITE(MW6,10150)JFAIL
        GO TO 300
      ENDIF
!
      CALL DIMUSE('MXSYJ',MXX)
      if(mxx.ne.ixsyj)then                          !should have aborted
        write(mw0,*)'ixsyj=',ixsyj,mxx
      endif
!
      IF(IXSYJ.GT.MXSYJ)THEN
        IF(MXSYJ.GT.0)WRITE(MW6,10030)IXSYJ
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
  300 WRITE(MW6,10010)
      NF=-1                       !<-------------------- ABNORMAL RETURN
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(' SR.SYMLSJ: FAILURE - CASE SKIPPED')
10020 FORMAT('***SR.SYMLSJ: ALLOCATION INCREASES NUMBER OF SYMMETRIES ',&
     &       ' IAXJG =',I3,' .GT. MAXJG=',I3)
10030 FORMAT('***SR.SYMLSJ: ALLOCATION INCREASES NUMBER OF LSP SYMMS',  &
     &       ' PER JP  IXSYJ =',I3,' .GT. MXSYJ=',I3)
10040 FORMAT(/' *** NO J-SYMMETRIES FOUND FOR BP RUN, CHECK INPUT'/)
10050 FORMAT(/' NOTE: REDUCING MAXJFS TO MAXJT')
10060 FORMAT(//1X,136('-')//)
10070 FORMAT(' *** PARTIAL WAVE LEVEL SYMMETRY RESTRICTIONS:',5X,       &
     &       'MAX EXCHANGE LAMDA=',I3//)
10080 FORMAT('  SYJ  2J   P')
10090 FORMAT(1X,3I4)
10100 FORMAT(' MINJT=',I2,3X,'MAXJT=',I3)
10110 FORMAT(' SYJ=',I3,4X,'2J P =',I3,I3,'    FORMED BY   SY=',I2,     &
     &       '  (2S+1)  L  P ')
10120 FORMAT(39X,I3,7X,I3,I4,I3)
10130 FORMAT(/' PARITY IPAR=',i2)
10140 FORMAT('***SR.SYMLSJ ERROR: REQUESTED TOTAL 2J NOT POSSIBLE FOR ',&
     &       'THIS ATOMIC TARGET - ADD/SUBTRACT 1 TO/FROM 2J')
10150 FORMAT(//'*** SR.SYMLSJ ERROR: SPECIFY THE MISSING',I4,           &
     &       ' LSP SYMMETRIES LISTED ABOVE AND RE-RUN'//)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE SYMLSJ
!
!                             *******************
!
      SUBROUTINE TARGET(TIME,TTIME)
!
!-----------------------------------------------------------------------
!
!  SR.TARGET EVALUATES ENERGY LEVELS, RADIATIVE & AUTOIONIZATION RATES,
!  AND PHOTOIONIZATION CROSS SECTIONS FROM (QUASI)-BOUND STATE TARGETS.
!
!  IT IS CALLED BY:
!    PR.MAIN
!
!  IT CALLS:
!    SR.ALGEB
!    SR.MINIM
!
!-----------------------------------------------------------------------
!par!                                                               !par
!par      use comm_interface, only : iam                            !par
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_MISC,   ONLY: NF0,BNAME
!
      use common_misc,   only: iw,iwp,btime,btimex
!
      USE COMMON_NRBDR,  ONLY: LNEW,LCON,LSUM,LMAX,lcmin,BLOOP
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
!      if(.not.btime.and.btimex)then        !btime/x not initialized yet
!par!       if(iam.eq.0)then                                        !par
!          write(iw,*)'Starting target'
!par!       endif                                                   !par
!      endif
!
! INITIALIZE FOR ANY RYDBERG L-LOOP
!
      BLOOP=.FALSE.
      LSUM=0
      LNEW=-1
!
!-----------------------------------------------------------------------
!
! SR.ALGEB EVALUATES ANGULAR ALGEBRA (CA, LS AND IC).
!
  100 CONTINUE
!
      CALL ALGEB(IRET)
!
      IF(NF.LE.0.OR.IRET.EQ.1)THEN                             !Le <- Lt
        IF(IRET.EQ.0)IRET=2
        GO TO 200
      ENDIF
!
      CALL NRB_TIME(TIME0)
!
      TIME0=TIME0/D60
      TIME=TIME0-TIME
      TTIME=TTIME+TIME
!
      WRITE(MW6,10010)TIME,TTIME
!
      TIME=TIME0
!
!-----------------------------------------------------------------------
!
! SR.MINIM SETS-UP & DIAGONALIZES H FOR LS & IC ENERGIES AND OPTIONALLY
!    EVALUATES RADIATIVE RATES (E_K & M_K), AUTOIONIZATION RATES,
!    PHOTOIONIZATION CROSS SECTIONS AND (INF &) FINITE ENERGY BORN
!    COLLISION STRENGTHS.
!
!
      CALL MINIM
!
!-----------------------------------------------------------------------
!
  200 CONTINUE
!
      CALL NRB_TIME(TIME0)
!
      times=time0-D60*time
      TIME0=TIME0/D60
      TIME=TIME0-TIME
      TTIME=TTIME+TIME
!
      WRITE(MW6,10010)TIME,TTIME
!
      TIME=TIME0
!
      if(.not.btime.and.btimex)then
!par        if(iam.eq.0)then                                        !par
        write(iw,*)'Ending target: time=',nint(times),'sec,     ',      &
     &             nint(times/60),'min'
!par        endif                                                   !par
      endif
!
      IF(IRET.EQ.0.AND.NF0.GT.0.AND.(.NOT.BNAME.OR.BLOOP))GO TO 100
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(//1X,'CPU TIME=',F9.3,' MIN',5X,'TOTAL CPU TIME=',F9.3,    &
     &       ' MIN')
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE TARGET
!
!                   *********************
!
      SUBROUTINE TFDAPO(Z,NION,MK,ADJUST,ADJUS1,ADJUS2,DX1,NPOINT,NI,NTI&
     &                 ,X,POT,TOL,MEND,CRRCT1,CRRCT2)              !,DXI
!
!-----------------------------------------------------------------------
!
!  SR.TFDAPO CALCULATES A THOMAS-FERMI-DIRAC-AMALDI POTENTIAL.
!
!   QUANTITIES REQUIRED: ALL ARGUMENTS TO X (DXI NO LONGER USED)
!                        PLUS DIP/QUAD POLARIZATION COEFFS CRRCT1,CRRCT2
!
!  Z=NUCLEAR CHARGE
!  NION=NUMBER OF ELECTRONS IN THE ION
!  ADJUST=SCALING PARAMETER (A VALUE GT 1.0 CONTRACTS THE EFFECTIVE
!  RADIAL SCALE, I.E. Z FALLS OFF MORE SLOWLY TOWARDS RESIDUAL ZN.
!  DXI(J),J=1,NI=STEP LENGTH IN THE J'TH INTERVAL -- STEP LENGTH IS
!  DOUBLED IN SUCCESSIVE INTERVALS, DX1=DXI(1) IS INPUT-SO ARE THE
!  NUMBERS NTI(J) OF STEPS IN THE NI INTERVALS J;
!  X(I),I=1,NPOINT=RADIAL DISTANCE AT THE NPOINT RADIAL POINTS I;
!  MEND=INDEX OF THE LAST POINT FOR WHICH THE EFFECTIVE CHARGE HAS
!  NOT NECESSARILY THE RESIDUAL VALUE ZN; FOR X.GT.X(MEND) THE
!  POTENTIAL IS ZN/X=(Z-NION+1)/X. IF THE RANGE X(NPOINT) IS TOO
!  SMALL FOR THE EFFECTIVE CHARGE TO DROP TO ZN CONTROL IS RETURNED
!  WITH DX1=2*DX1 -- WHILE DXI(1) CONTAINS THE ORIGINAL DX1.
!  POT(I),I=1,NPOINT=VALUE OF THE POTENTIAL AT THE POINTS X(I).
!  POT(I) WAS STORED IN /COM1/- POT,TOL,MEND NOW OUTPUT THROUGH
!  ARGUMENT LIST & THEN STORED IN /COM1/IN RADIAL FOR USE IN RADWAV.
!  TOL, TYPICALLY 1.E-6, =ACCURACY - ALSO USED FOR E-VALUE ACCURACY
!  IN RADWAV SO DON'T INCREASE!
!
!  IT IS CALLED BY:
!    SR.RADCON
!    SR.RADCX0
!    SR.RADIAL
!    SR.RADWIN
!
!  IT CALLS:
!    SR.CORTFD
!    SR.POTIN
!    SR.RK1ST
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: MHF,MRAD,MSTEP,IXTRA,xmax
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TBB=.079157174720_WP)  !(5/12)(E_X**2/E_K)=25/(32pi**2)
      PARAMETER (DMU0=.88534131027_WP)           !(1/4)(9pi**2/2)**(1/3)
      PARAMETER (TOLP=D1M5)          !SET POLARIZ=0 IF SMALLER THAN TOLP
!
      DIMENSION POT(*),X(*),NTI(*)                              !,DXI(*)
!
      DIMENSION F(2),FE(2)
!
!-----------------------------------------------------------------------
!
      IF(Z.EQ.DZERO)THEN
        WRITE(MW0,*)'*** ERROR: SR.TFDAPO NO LONGER INITIALS DX1,',     &
     &              ' CALL SR.MESH INSTEAD'
        WRITE(MW6,*)'*** ERROR: SR.TFDAPO NO LONGER INITIALS DX1,',     &
     &              ' CALL SR.MESH INSTEAD'
        GO TO 1500
      ENDIF
!
! SOME INITIALIZATIONS
!
      N=NION
      ZN=Z-N+1           !ASYMPTOTIC CHARGE AS SEEN BY A TAGRET ELECTRON
      TOLH=D1M2
!
! GO READ EXTERNAL POTENTIAL (MAYBE)
!
      IF(MHF*MK.GT.0)THEN
!
        CALL POTIN(Z,NION,MK,NPOINT,X,POT,MEND)
!
        GO TO 1400                                !RETURN
!
      ENDIF
!
! NEGATIVE SCALING PARAMETERS/LAMDAS FLAG SCREENED HYDROGENIC
!
      IF(ADJUST.LT.DZERO)THEN
        TA=-ADJUST*Z
        TB=(DONE+ADJUST)*Z
        ZH=Z/DTWO
        MEND=1
        DO J=1,NPOINT
          TT=EXP(-ZH*X(J))            !HISTORIC CUSP CONDITION AT ORIGIN
          TT=TT*TB
          POT(J)=(TA+TT)/X(J)
          IF(ABS(TT/TA).GT.TOLH)MEND=J
        ENDDO
        IF(MEND.LT.NPOINT)GO TO 1400              !RETURN
        DX1=DX1+DX1
        TT=TT/X(MEND)
        WRITE(MW6,10030)ADJUST,X(MEND),POT(MEND),TT
        GO TO 1400                                !RETURN
      ENDIF
!
! IF ONLY ONE ELECTRON IS PRESENT THE POTENTIAL IS PURELY COULOMBIC
!
      I=1
      MEND=1
      IF(N.EQ.1)GO TO 1300
!
! *** NON-HYDROGENIC
!
      DMUE=((N/(N-DONE))**2/Z)**(DONE/DTHREE)*DMU0*ADJUST
!
! WE SHALL TRANSFORM X OF EN 2.20 TO Y WITH Y*Y=X
!
      Y1=DX1/(DTWO*DTWO)
      YY1=SQRT(Y1/DMUE)
      IF(YY1.GT.D1M2)YY1=D1M2
      Y1=YY1*YY1*DMUE
      MEND=0
      DLOW=DZERO
      YLOW=DZERO
      ILOW=1
      ISTEP=1
      m0=max(mstep-10,itwo)
!
! TRY THE INTEGRATION FROM THE END OF EACH INTERVAL UNTIL THE
! FUNCTION REACHES A VALUE GT 1 AT Y.EQ.0.
!
      DO I=1,NI
!
        II=MEND+1
        NT0=NTI(I)
        IF(I.EQ.NI)NT0=min(nt0,m0*NTI(I-1))                !N.B. NI.GT.1
   50   MEND=MEND+NT0
        IF(MEND.GT.NPOINT.and.npoint.eq.iaxb1)THEN
          WRITE(MW6,10010)MEND,NPOINT
          WRITE(MW0,*)'*** DIMENSION MAXB1 EXCEEDED IN SR.TFDAPO?'
          GO TO 1500
        ENDIF
!
! FILL POT(I) TEMPORARILY WITH Y(I) CORRESPONDING TO X(I)
!
        DO J=II,MEND
          POT(J)=SQRT(X(J)/DMUE)
        ENDDO
        J=8
!
! IN THE FIRST INTERVAL THE INTEGRATION IS DONE FROM A SMALL
! DISTANCE TO ASSURE THAT THE FIRST FUNCTION VALUE AT Y.EQ.0 IS LT.1
!
        IF(I.EQ.1)GO TO 250
!
  100   ISTEP=7
        IF(I.EQ.NI)GO TO 150
        IF(I.LE.3)GO TO 400
        IF(ZN.LT.(DTWO+D1M1))GO TO 150
        IF(i.lt.8.and.MOD(I,ITWO).NE.0)GO TO 400   !MESH MAYBE TRUNCATED
  150   J=MEND
!
  200   ISTEP=ISTEP-1
        IF(ISTEP.EQ.1)GO TO 250
        IF(POT(J)-POT(J-ISTEP).GT.DHALF)GO TO 200
                                                 !REDUCE INTGRTN INTERVL
!
  250   IHIGH=J
        YHIGH=POT(J)
        Y0=YHIGH
!
        F(1)=TBB*Y0*Y0*DMUE/Z              !CALCULATE THE FUNCTION AT X0
!
        F(2)=DTWO*(F(1)-ZN/Z)/Y0   !CALCULATE THE FIRST DERIVATIVE AT X0
!
  300   Y0=POT(J)
        J=J-ISTEP
        BOOL=J.GT.0
        H=YY1-Y0
        IF(BOOL)H=POT(J)-Y0
!
        CALL RK1ST(Y0,F,H,ITWO,YY0,FE)     !INTEGRATE 1 STEP
!
        F(1)=FE(1)
        IF(FE(1).GT.D1P10)THEN
          J=IHIGH-NT0/10-1
          GO TO 250
        ENDIF
        F(2)=FE(2)
        IF(BOOL)GO TO 300
!
        HIGH=FE(1)+(SQRT(FE(1))*YY1)**3*D2THRD-FE(2)*(YY1/DTWO+YY1**4)
!
        IF(HIGH.GT.DONE)GO TO 500        !WE HAVE A WINNER
!
        IF(M0.GT.MSTEP)GO TO 400         !GIVE UP
!
        IF(I.EQ.NI)THEN                  !TREAT FINAL INTERVAL WITH TLC
          IF(MEND.GE.(II+17))THEN        !CUT IF TOO LONG
!            WRITE(MW6,994)MEND,HIGH       !SILENTLY
            MEND=(II-1+MEND)/2
!            WRITE(MW6,995)NI,II,MEND
            GO TO 100
          ELSE                           !CASE MESH TRUNACTED, GO TO END
            M0=999                       !FLAG FINAL ATTEMPT
            MEND=II-1
            NT0=NTI(NI)
            GO TO 50
          ENDIF
        ENDIF
!                                        !TRANSFER
        YLOW=YHIGH
        ILOW=IHIGH
        DLOW=HIGH
!
  400 ENDDO
!
! END INTERVAL LOOP
!
      DX1=DX1+DX1
      WRITE(MW6,10020)ADJUST,X(MEND),FE(1)
      GO TO 1400                         !RETURN
!
! FIND AN IMPROVED APPROXIMATION TO Y0
!
  500 Y0=YLOW+(DONE-DLOW)*(YHIGH-YLOW)/(HIGH-DLOW)
      YHIGH=YHIGH+DTHREE*TOL
      YLOW=YLOW-DTHREE*TOL
      Y0=(Y0+(YHIGH+YLOW)/DTWO)/DTWO
!
  600 DO J=ILOW,IHIGH
        IF(POT(J).GT.Y0)THEN
          MEND=J-1
          GO TO 700
        ENDIF
      ENDDO
!
  700 J=MEND
!
! BOUNDARY CONDITION
!
      F(1)=TBB*Y0*Y0*DMUE/Z
      F(2)=DTWO*(F(1)-ZN/Z)/Y0
!
      YY0=Y0
  800 J=J-ISTEP
      BOOL=(J.GT.0)
      H=YY1-YY0
      IF(BOOL)H=POT(J)-YY0
!
      CALL RK1ST(YY0,F,H,ITWO,YL,FE)
!
      F(1)=FE(1)
      F(2)=FE(2)
      IF(.NOT.BOOL)GO TO 900
      YY0=POT(J)
      GO TO 800
!
! EXPAND AT YY1 IN A TAYLOR SERIES TO CALCULATE FE AT Y.EQ.0.
!
  900 FE(1)=FE(1)+(SQRT(FE(1))*YY1)**3*D2THRD-FE(2)*(YY1/DTWO+YY1**4)
      TOL1=FE(1)-DONE
      IF(YHIGH-YLOW.LT.YHIGH*TOL/DTWO)THEN
        IF(TOL1.LT.DZERO)YHIGH=YHIGH-TOL1
        IF(TOL1.GT.DZERO)YLOW=YLOW-TOL1
      ENDIF
!
      ISTEP=1
      IF(ABS(FE(1)-DONE).GT.D1M1)ISTEP=2
      YL=(Y0*(DLOW-DONE)-YLOW*(FE(1)-DONE))/(DLOW-FE(1))
      YH=(Y0*(HIGH-DONE)-YHIGH*(FE(1)-DONE))/(HIGH-FE(1))
      IF(FE(1).LT.DONE)THEN
        YLOW=Y0
        DLOW=FE(1)
        ILOW=MEND
      ELSE
        YHIGH=Y0
        HIGH=FE(1)
        IHIGH=MEND+1
      ENDIF
!
      Y0=(YL+YH)/DTWO
      IF(Y0.LT.YLOW.OR.Y0.GE.YHIGH)Y0=(YLOW+YHIGH)/DTWO
      IF(ABS(FE(1)-DONE).GT.DTWO*TOL)GO TO 600
!
! FIND THE FINAL VALUE FOR Y0
!
 1000 RY0=Y0*Y0*DMUE
      V0=ZN/RY0-TBB
      DO I=1,NPOINT
        IF(X(I).GT.RY0)THEN
          MEND=I-1
          GO TO 1100
        ENDIF
      ENDDO
      WRITE(MW6,10010)NPOINT,MEND
      WRITE(MW0,*)'*** DIMENSION MAXB1 EXCEEDED IN SR.TFDAPO?'
      GO TO 1500
!
 1100 FE(1)=TBB*Y0*Y0*DMUE/Z
      FE(2)=DTWO*(FE(1)-ZN/Z)/Y0
      YY1=Y0
      I=MEND
 1200 IF(I.EQ.0)THEN
        YY0=YY1
        YY1=SQRT(Y1/DMUE)
      ELSE
        XB=X(I)
        YY0=YY1
        YY1=SQRT(XB/DMUE)
      ENDIF
      F(1)=FE(1)
      F(2)=FE(2)
      H=YY1-YY0
!
! INTEGRATE FROM YY0 TO YY0+H
!
      CALL RK1ST(YY0,F,H,ITWO,TOL1,FE)
!
      IF(I.NE.0)THEN
        POT(I)=FE(1)*Z/XB+V0
        I=I-1
        GO TO 1200
      ENDIF
!
! EXTRAPOLATE TO X=0
!
      FE(1)=FE(1)+(SQRT(FE(1))*YY1)**3*D2THRD-FE(2)*(YY1/DTWO+YY1**4)
      TOL1=FE(1)-DONE
      IF(YHIGH-YLOW.LT.YHIGH*TOL/DFIVE)THEN
        IF(TOL1.GT.DZERO)YLOW=YLOW-TOL1
        IF(TOL1.LT.DZERO)YHIGH=YHIGH-TOL1
      ENDIF
      YL=(Y0*(DLOW-DONE)-YLOW*(FE(1)-DONE))/(DLOW-FE(1))
      YH=(Y0*(HIGH-DONE)-YHIGH*(FE(1)-DONE))/(HIGH-FE(1))
      IF(FE(1).GT.DONE)THEN
        YHIGH=Y0
        HIGH=FE(1)
      ELSE
        YLOW=Y0
        DLOW=FE(1)
      ENDIF
      Y0=(YL+YH)/DTWO
      IF(Y0.LE.YLOW.OR.Y0.GE.YHIGH)Y0=(YLOW+YHIGH)/DTWO
!
! IF THE APPROXIMATION IS NOT GOOD ENOUGH REPEAT THE PROCESS
!
      IF(ABS(TOL1).GE.TOL)GO TO 1000
      I=MEND+1
!
! FILL THE REMAINING POTENTIAL AS A COULOMB POTENTIAL
!
 1300 DO J=I,NPOINT
        POT(J)=ZN/X(J)
      ENDDO
!
!      do j=1,i
!        write(65,*)x(j),pot(j),x(j)*pot(j)
!      enddo
!
! OPTIONALLY ADD-IN DIPOLE AND QUADRUPOLE POLARIZATION AS A PERTURBATION
!
      IF(ABS(ADJUS1-DONE).GT.TOLP.OR.ABS(ADJUS2-DONE).GT.TOLP)          &
     &   CALL CORTFD(X,POT,MEND,ADJUS1,ADJUS2,CRRCT1,CRRCT2)
!
!-----------------------------------------------------------------------
!
 1400 CONTINUE
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
 1500 NF=-1
      GO TO 1400
!
!-----------------------------------------------------------------------
!
10010 FORMAT(/' SR.TFDAPO:  MEND.GT.NPOINT, TRY INCREASING MAXB1:',2I6)
!  994 FORMAT(I15,1PE12.3)
!  995 FORMAT(3I5)
10020 FORMAT(' SR.TFDAPO  (ADJUST,X(MEND),FE(1)) =',                    &
     &       3F10.5/'  RETURN AND EXTEND RADIAL MESH')
10030 FORMAT(' SR.TFDAPO:  (ADJUST,X(MEND),COUL-POT(MEND),NON-COUL) =', &
     &       4F10.5/'  RETURN AND EXTEND RADIAL MESH')
!OLD  990 FORMAT(E14.7)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE TFDAPO
!
!                             *******************
!
      SUBROUTINE TLAM(LAM,K1,K2,K3,K4,TTLAM)
!
!-----------------------------------------------------------------------
!
!  SR.TLAM EVALUATES THE T-LAMDA INTEGRAL OF ORBIT-ORBIT INTERACTION.
!
!  IT IS CALLED BY:
!    SR.ZLAM
!
!  IT CALLS:
!    SR.DIFF
!    SR.WEDDLE
!    SR.YLAMK
!    SR.YLAMKR
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
!
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      use common_nrbtmp, only: rnorm
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      ALLOCATABLE :: D1(:),D2(:),D3(:)
!
!-----------------------------------------------------------------------
!
      BREL2=ABS(IREL).EQ.2
!
      ALLOCATE(D1(MAXRS),D2(MAXRS),D3(MAXRS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.TLAM: ALLOCATION FAILS FOR D1,D2,D3'
        TTLAM=DZERO
        NF=0                                                !NOT TRACKED
        RETURN
      ENDIF
!
      DO I=1,MAXRS
        D1(I)=DPNL(I,K3)/DX(I)
      ENDDO
!
      CALL DIFF(D1,D2,MNH,DHNS,MJH)
!
      DO I=1,MAXRS
        D1(I)=D2(I)*DPNL(I,K1)*DX(I)
      ENDDO
      M=QL(K1)/2+QL(K3)/2+1
      IF(QL(K3).EQ.0)M=M+1
!
      IF(BREL)THEN                       !SMALL R CORRECTION
        IK1=ICOL(K1,K1,IZERO)
        IK3=ICOL(K3,K3,IZERO)
        DE1=DEY(K1)-DUY(IK1)
        DE3=DEY(K3)-DUY(IK3)
        DEL=DE1-DE3                                   ! A.U.
        DZ=NZION
        T=DALF4*DTWO
        IF(BREL2)THEN
          DO I=1,MAXRS
            DD1=DONE+T*(DE1+DZ/DX(I))
            DD3=DONE+T*(DE3+DZ/DX(I))
!            DD1=DONE+T*(DE1+POT(I,1))
!            DD3=DONE+T*(DE3+POT(I,1))
            DSQ=DD1*DD3
            DSQ=SQRT(DSQ)
            D1(I)=D1(I)/DSQ
          ENDDO
        ELSE
          dd=rnorm(k1)*rnorm(k3)
          DO I=1,MAXRS
            DD1=DONE+DALF4*(DQNL(I,K1)/DPNL(I,K1)+DTWO*DZ/DX(I))
            DD3=DONE+DALF4*(DQNL(I,K3)/DPNL(I,K3)+DTWO*DZ/DX(I))
!            dd1=done+t*(de1+dz/dx(i))
!            dd3=done+t*(de3+dz/dx(i))
            DSQ=DD1*DD3
            DSQ=SQRT(DSQ)
            D1(I)=D1(I)*dd/DSQ
          ENDDO
        ENDIF
        CALL YLAMKR(LAM,M,DEL,D1,D2,DD1,DD2,MNH,DHNS,MJH,I1000)
      ELSE
        CALL YLAMK(LAM,M,D1,D2,DD1,DD2,MNH,DHNS,MJH,IZERO)
      ENDIF
!
      DO I=1,MAXRS
        D1(I)=DPNL(I,K4)/DX(I)
      ENDDO
!
      CALL DIFF(D1,D3,MNH,DHNS,MJH)
!
      DO I=1,MAXRS
        D1(I)=D2(I)*D3(I)*DX(I)*DPNL(I,K2)
      ENDDO
!
      IF(BREL)THEN                       !SMALL R CORRECTION
        IK2=ICOL(K2,K2,IZERO)
        IK4=ICOL(K4,K4,IZERO)
        DE2=DEY(K2)-DUY(IK2)
        DE4=DEY(K4)-DUY(IK4)
        DEL=DE2-DE4                                   ! A.U.
        IF(BREL2)THEN
          DO I=1,MAXRS
            DD2=DONE+T*(DE2+DZ/DX(I))
            DD4=DONE+T*(DE4+DZ/DX(I))
!            DD2=DONE+T*(DE2+POT(I,1))
!            DD4=DONE+T*(DE4+POT(I,1))
            DSQ=DD2*DD4
            DSQ=SQRT(DSQ)
            D1(I)=D1(I)/DSQ
          ENDDO
        ELSE
          dd=rnorm(k2)*rnorm(k4)
          DO I=1,MAXRS
            DD2=DONE+DALF4*(DQNL(I,K2)/DPNL(I,K2)+DTWO*DZ/DX(I))
            DD4=DONE+DALF4*(DQNL(I,K4)/DPNL(I,K4)+DTWO*DZ/DX(I))
!            dd2=done+t*(de2+dz/dx(i))
!            dd4=done+t*(de4+dz/dx(i))
            DSQ=DD2*DD4
            DSQ=SQRT(DSQ)
            D1(I)=D1(I)*dd/DSQ
          ENDDO
        ENDIF
      ENDIF
!
      CALL WEDDLE(DZERO,D1,TT,MNH,DHNS,MJH,MAXRS)
!
      TP=2*LAM+1
      TTLAM=DALF*TT/TP
!
      DEALLOCATE(D1,D2,D3,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.TLAM: DE-ALLOCATION FAILS FOR D1,D2,D3'
        NF=0                                                !NOT TRACKED
        RETURN
      ENDIF
!
!     WRITE(MW6,100) K1, K2, K3, K4, 2*LAM, TLAM
!100  FORMAT(8X,2(I5,I4),I6,F14.7,' =TLAM')
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE TLAM
!
!                             *******************
!
      SUBROUTINE TOP1(NZA,LITLAM,EI,EJ,SS,OMT)
!
!-----------------------------------------------------------------------
!
! SR.TOP1 CALCULATES BURGESS (1974) DIPOLE TOP-UP USING COULOMB-BETHE
!         PARTIAL COLLISION STRENGTHS, AS IMPLEMENTED IN FORMULA (3.10)
!         OF BURGESS & SHEOREY (1974).
!
!  IT IS CALLED BY:
!    SR.CADWX
!    SR.DWXBP_DAXPY
!    SR.DWXBP_DDOT
!    SR.DWXLS_DAXPY
!    SR.DWXLS_DDOT
!
!  IT CALLS
!    FN.DIP  (IONS)
!    FN.DIP0 (NEUTRALS)
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (D16O3=D6TEEN/DTHREE)
!
      PARAMETER (TOLE=D1M10)
      PARAMETER (DEPS=D1M5)
!
      DATA IPRTOP/0/
!
!-----------------------------------------------------------------------
!
      IF(SS.LT.DZERO)THEN                                        !DIPOLE
!
        COEF=-D16O3*SS*LITLAM
        DELE=MAX(EI-EJ,TOLE)
!
        IF(NZA.GT.0)THEN                                         !ION
!
          TZLMSQ=DONE/(LITLAM*LITLAM)
!
          IFAIL=IPRTOP
          FI=FDIP(EI,LITLAM,EJ,LITLAM-1,IFAIL)
!
          IF(IFAIL.NE.0.AND.IPRTOP.EQ.2)WRITE(MW6,10010)IFAIL,EI,LITLAM,&
     &       EJ,LITLAM-1
!
          IFAIL=IPRTOP
          FJ=FDIP(EI,LITLAM-1,EJ,LITLAM,IFAIL)
!
          IF(IFAIL.NE.0.AND.IPRTOP.EQ.2)WRITE(MW6,10010)IFAIL,EI,       &
     &       LITLAM-1,EJ,LITLAM
        ELSE                                                    !NEUTRAL
!
          TZLMSQ=DZERO
!
          IFAIL=IPRTOP
          FI=FDIP0(EI,LITLAM,EJ,LITLAM-1,DEPS,IFAIL)
!
          IF(IFAIL.NE.0.AND.IPRTOP.EQ.2)WRITE(MW6,10010)IFAIL,EI,LITLAM,&
     &       EJ,LITLAM-1
!
          IFAIL=IPRTOP
          FJ=FDIP0(EI,LITLAM-1,EJ,LITLAM,DEPS,IFAIL)
!
          IF(IFAIL.NE.0.AND.IPRTOP.EQ.2)WRITE(MW6,10010)IFAIL,EI,       &
     &       LITLAM-1,EJ,LITLAM
!
        ENDIF
!
        IF(FI*FJ.NE.DZERO)THEN
!
          OMI=COEF*FI*FI
          OMJ=COEF*FJ*FJ
          OMT=(TZLMSQ+EJ)*OMI-(TZLMSQ+EI)*OMJ
          OMT=OMT/DELE
!
          if(omt.lt.dzero)then                           !case unforseen
            if(iprtop.eq.2)then
              write(mw6,10020)ifail,ei,litlam-1,ej,litlam,fi,fj
            endif
            omt=dzero
          endif
!
        ELSE
          OMT=DZERO
        ENDIF
!
      ELSE
        OMT=DZERO
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT('SR.TOP1: FDIP FAILURE, IFAIL=',I2,' FOR E,L=',            &
     &       2(1PE13.5,I3))
10020 FORMAT('SR.TOP1: FDIP FAILURE, IFAIL=',I2,' FOR E,L=',            &
     &       2(1PE13.5,I3),': FI,FJ=',2E13.5)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE TOP1
!
!                             *******************
!
      SUBROUTINE TOP2(LITLAM,LRGLAM,EI,EJ,OMPW)
!
!-----------------------------------------------------------------------
!
! SR.TOP2 CALCULATES NON-DIPOLE (ALLOWED) TOP-UP USING GEOMETRIC
!         SERIES, GOING OVER TO DEGENERATE ENERGY LIMITING CASE.
!         SEE BURGESS, HUMMER & TULLY (1970) FOR BACKGROUND DETAILS.
!
!  IT IS CALLED BY:
!    SR.CADWX
!    SR.DWXBP_DAXPY
!    SR.DWXBP_DDOT
!    SR.DWXLS_DAXPY
!    SR.DWXLS_DDOT
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DATA ITOP/-2/,IPRTOP/0/                       !ITOP=STGICF DEFAULT
!
!-----------------------------------------------------------------------
!
      IF(OMPW.LT.DZERO)THEN
        OMPW=-OMPW
        IPRTOP=3
      ENDIF
!
      IF(LITLAM.GT.1)THEN                            !NON-DIPOLE ALLOWED
!
        TLTOP=LRGLAM
!
        IF(EI.EQ.DZERO)THEN
          AQ=DONE
        ELSE
          AQ=EJ/EI
        ENDIF
!
        IF(ITOP.EQ.-1)THEN
!
!      INTERPOLATE BETWEEN DEGENERATE AND NON-DEGENERATE LIMITS WHEN
!      L.LT.2*EJ/(EI-EJ), AS PER STGF DEFAULT
!
          O1=DONE+TLTOP/(LITLAM-DONE)
          O1=O1/DTWO
!
          IF(AQ.GT.0.99D0)THEN                              !CATCH EI=EJ
            OMPW=OMPW*O1
            IF(IPRTOP.EQ.3)WRITE(MW6,10020)AQ,O1
          ELSE
            O2=DONE/(DONE-AQ)
            DQ=AQ*O2
            IF(TLTOP.GT.DTWO*DQ)THEN
              OMPW=OMPW*O2
              IF(IPRTOP.EQ.3)WRITE(MW6,10030)DQ,O2
            ELSE
              T=TLTOP/(DQ*DTWO)
              O3=O2*T+O1*(DONE-T)
              OMPW=OMPW*O3
              IF(IPRTOP.EQ.3)WRITE(MW6,10010)AQ,DQ,O1,O2,O3
            ENDIF
          ENDIF
!
        ELSE
!
!      INTERPOLATE BETWEEN DEGENERATE AND NON-DEGENERATE LIMITS WHEN
!      ENERGY-RATIO EXCEEDS J-RATIO, AS PER STGICF DEFAULT
!
          DQ=TLTOP/(TLTOP+1)
          DQ=DQ**(2*LITLAM-1)
!
          IF(AQ.LT.DQ)THEN
            O1=DONE/(DONE-AQ)
            OMPW=OMPW*O1
            IF(IPRTOP.EQ.3)WRITE(MW6,10020)AQ,O1
          ELSE
            O2=DONE+TLTOP/(LITLAM-DONE)
            O2=O2/DTWO
            IF(AQ.LT.DONE)THEN
              O1=DONE/(DONE-AQ)
              O3=O1*((DONE-AQ)/(DONE-DQ))**2+O2*(AQ-DQ)*(DTWO-AQ-DQ)    &
     &           /(DONE-DQ)**2
            ELSE
              O3=O2
            ENDIF
            OMPW=OMPW*O3
            IF(IPRTOP.EQ.3)WRITE(MW6,10010)AQ,DQ,O1,O2,O3
          ENDIF
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(18X,5F10.3)
10020 FORMAT(18X,F10.3,10X,F10.3)
10030 FORMAT(18X,10X,F10.3,10X,F10.3)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE TOP2
!
!                             *******************
!
      FUNCTION TQDT(QD,NZ0,NE,N,L)
!
!-----------------------------------------------------------------------
!
!  FN.TQDT EVALUATES A ONE-ELECTRON ENERGY WITH NON-ZERO QUANTUM DEFECT
!
!   : QD0, UNIVERSAL QUANTUM DEFECT GIVEN BY
!         QD0*(NE**1.67-1)/(Z0**.67*Z**.33*(1+L**3))
!         CURRENT VALUE IN FUNCTION QDT IS QD0=0.182
!
!  IT IS CALLED BY:
!    SR.RADCN0
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
      REAL(WP)QD,QD0
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (QD0=0.182_WP)
!
!-----------------------------------------------------------------------
!
      IF(N.LE.0)THEN
        QD=DZERO
        TQDT=DZERO
        RETURN
      ENDIF
!
      TZ0=NZ0
      TZ=NZ0-NE+1
      IF(L.LT.0.OR.NE.LE.1)THEN
        QD=DZERO
      ELSE
        TL=L**3+1
        TE=NE
        QD=QD0*(TE**D5THRD-DONE)/(TZ0**D2THRD*TZ**D1THRD*TL)
      ENDIF
!
      TN=N
      TN=TN-QD
      TQDT=-(TZ/TN)**2
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION TQDT
!
!                             *******************
!
      SUBROUTINE TRIMAT(N,SA,SB,SC,SD,SY)
!
!-----------------------------------------------------------------------
!
! ALAN BURGESS, D.A.M.T.P. CAMBRIDGE.
!
! SOLUTION OF TRI-DIAGONAL MATRIX EQUATION BY FORWARD AND BACKWARD PASS
! (SEE 'MODERN COMPUTING METHODS', PAGES 97,98).
!  INPUT: N, (THE MATRIX IS N BY N)
!         SA(J), J=2,3...N (SUB-DIAGONAL ELEMENTS)
!         SB(J), J=1,2...N (DIAGONAL ELEMENTS)
!         SC(J), J=1,2...N-1 (SUPER-DIAGONAL ELEMENTS)
!         SD(J), J=1,2...N (RIGHT-HAND SIDE).
!  OUTPUT: N,SA,SB AND SC ARE PRESERVED, SD IS OVERWRITTEN
!         SY(J), J=1,2...N CONTAINS THE SOLUTION VECTOR.
!
!  IT IS CALLED BY:
!    SR.SPLYN
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION SA(N),SB(N),SC(N),SD(N),SY(N)
!
!-----------------------------------------------------------------------
!
      SY(1)=SB(1)
      DO J=2,N
        T=SA(J)/SY(J-1)
        SY(J)=SB(J)-T*SC(J-1)
        SD(J)=SD(J)-T*SD(J-1)
      ENDDO
      SY(N)=SD(N)/SY(N)
      DO I=2,N
        J=N-I+1
        SY(J)=(SD(J)-SC(J)*SY(J+1))/SY(J)
      ENDDO
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE TRIMAT
!
!                             *******************
!
      SUBROUTINE ULAM(LAM,K1,K2,K3,K4,TULAM)
!
!-----------------------------------------------------------------------
!
!  SR.ULAM EVALUATES THE U-LAMDA INTEGRAL OF ORBIT-ORBIT INTERACTION.
!
!  IT IS CALLED BY:
!    SR.ZLAM
!
!  IT CALLS:
!    SR.DIFF
!    SR.WEDDLE
!    SR.YLAMK
!    SR.YLAMKR
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
!
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      use common_nrbtmp, only: rnorm
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      ALLOCATABLE :: D1(:),D2(:),D3(:)
!
!-----------------------------------------------------------------------
!
      BREL2=ABS(IREL).EQ.2
!
      ALLOCATE(D1(MAXRS),D2(MAXRS),D3(MAXRS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.ULAM: ALLOCATION FAILS FOR D1,D2,D3'
        TULAM=DZERO
        NF=0                                                !NOT TRACKED
        RETURN
      ENDIF
!
      DO I=1,MAXRS
        D1(I)=DPNL(I,K1)*DPNL(I,K3)/DX(I)
        D2(I)=DPNL(I,K4)/DX(I)
      ENDDO
!
      CALL DIFF(D2,D3,MNH,DHNS,MJH)
!
      M=QL(K1)/2+QL(K3)/2+1
!
      IF(BREL)THEN                       !SMALL R CORRECTION
        IK1=ICOL(K1,K1,IZERO)
        IK3=ICOL(K3,K3,IZERO)
        DE1=DEY(K1)-DUY(IK1)
        DE3=DEY(K3)-DUY(IK3)
        DEL=DE1-DE3                                   ! A.U.
        DZ=NZION
        T=DALF4*DTWO
        IF(BREL2)THEN
          DO I=1,MAXRS
            DD1=DONE+T*(DE1+DZ/DX(I))
            DD3=DONE+T*(DE3+DZ/DX(I))
!            DD1=DONE+T*(DE1+POT(I,1))
!            DD3=DONE+T*(DE3+POT(I,1))
            DSQ=DD1*DD3
            DSQ=SQRT(DSQ)
            D1(I)=D1(I)/DSQ
          ENDDO
        ELSE
          dd=rnorm(k1)*rnorm(k3)
          DO I=1,MAXRS
            DD1=DONE+DALF4*(DQNL(I,K1)/DPNL(I,K1)+DTWO*DZ/DX(I))
            DD3=DONE+DALF4*(DQNL(I,K3)/DPNL(I,K3)+DTWO*DZ/DX(I))
!            dd1=done+t*(de1+dz/dx(i))
!            dd3=done+t*(de3+dz/dx(i))
            DSQ=DD1*DD3
            DSQ=SQRT(DSQ)
            D1(I)=D1(I)*dd/DSQ
          ENDDO
        ENDIF
        CALL YLAMKR(LAM,M,DEL,D1,D2,DD1,DD2,MNH,DHNS,MJH,IONE)
      ELSE
        CALL YLAMK(LAM,M,D1,D2,DD1,DD2,MNH,DHNS,MJH,IONE)
      ENDIF
!
      DO I=1,MAXRS
        D2(I)=D2(I)*D3(I)*DPNL(I,K2)*DX(I)
      ENDDO
!
      IF(BREL)THEN                       !SMALL R CORRECTION
        IK2=ICOL(K2,K2,IZERO)
        IK4=ICOL(K4,K4,IZERO)
        DE2=DEY(K2)-DUY(IK2)
        DE4=DEY(K4)-DUY(IK4)
        DEL=DE2-DE4                                   ! A.U.
        IF(BREL2)THEN
          DO I=1,MAXRS
            DD2=DONE+T*(DE2+DZ/DX(I))
            DD4=DONE+T*(DE4+DZ/DX(I))
!            DD2=DONE+T*(DE2+POT(I,1))
!            DD4=DONE+T*(DE4+POT(I,1))
            DSQ=DD2*DD4
            DSQ=SQRT(DSQ)
            D2(I)=D2(I)/DSQ
          ENDDO
        ELSE
          dd=rnorm(k2)*rnorm(k4)
          DO I=1,MAXRS
            DD2=DONE+DALF4*(DQNL(I,K2)/DPNL(I,K2)+DTWO*DZ/DX(I))
            DD4=DONE+DALF4*(DQNL(I,K4)/DPNL(I,K4)+DTWO*DZ/DX(I))
!            dd2=done+t*(de2+dz/dx(i))
!            dd4=done+t*(de4+dz/dx(i))
            DSQ=DD2*DD4
            DSQ=SQRT(DSQ)
            D2(I)=D2(I)*dd/DSQ
          ENDDO
        ENDIF
      ENDIF
!
      CALL WEDDLE(DZERO,D2,TT,MNH,DHNS,MJH,MAXRS)
!
      TP=LAM+2
      U=-TP*TT
!
      IF(LAM.NE.1)THEN
        DO I=1,MAXRS
          D2(I)=D3(I)*DPNL(I,K2)*DX(I)
        ENDDO
        M=1+QL(K2)/2+QL(K4)/2
        IF(QL(K4).EQ.0)M=M+1
!
        IF(BREL)THEN                       !SMALL R CORRECTION
          IK2=ICOL(K2,K2,IZERO)
          IK4=ICOL(K4,K4,IZERO)
          DE2=DEY(K2)-DUY(IK2)
          DE4=DEY(K4)-DUY(IK4)
          DEL=DE2-DE4                                   ! A.U.
          IF(BREL2)THEN
            DO I=1,MAXRS
              DD2=DONE+T*(DE2+DZ/DX(I))
              DD4=DONE+T*(DE4+DZ/DX(I))
!              DD2=DONE+T*(DE2+POT(I,1))
!              DD4=DONE+T*(DE4+POT(I,1))
              DSQ=DD2*DD4
              DSQ=SQRT(DSQ)
              D2(I)=D2(I)/DSQ
            ENDDO
          ELSE
            dd=rnorm(k2)*rnorm(k4)
            DO I=1,MAXRS
              DD2=DONE+DALF4*(DQNL(I,K2)/DPNL(I,K2)+DTWO*DZ/DX(I))
              DD4=DONE+DALF4*(DQNL(I,K4)/DPNL(I,K4)+DTWO*DZ/DX(I))
!              dd2=done+t*(de2+dz/dx(i))
!              dd4=done+t*(de4+dz/dx(i))
              DSQ=DD2*DD4
              DSQ=SQRT(DSQ)
              D2(I)=D2(I)*dd/DSQ
            ENDDO
          ENDIF
          CALL YLAMKR(LAM,M,DEL,D2,D3,DD1,DD2,MNH,DHNS,MJH,IONE)
        ELSE
          CALL YLAMK(LAM,M,D2,D3,DD1,DD2,MNH,DHNS,MJH,IONE)
        ENDIF
!
        DO I=1,MAXRS
          D2(I)=D1(I)*D3(I)
        ENDDO
!
        CALL WEDDLE(DZERO,D2,TT,MNH,DHNS,MJH,MAXRS)
!
        TP=LAM-1
        U=U+TP*TT
      ENDIF
!
      TP=2*(2*LAM+1)
      TULAM=DALF*U/TP
!
      DEALLOCATE(D1,D2,D3,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.ULAM: DE-ALLOCATION FAILS FOR D1,D2,D3'
        NF=0                                                !NOT TRACKED
        RETURN
      ENDIF
!
!     WRITE(MW6,100) K1, K2, K3, K4, 2*LAM, ULAM
!100  FORMAT(8X,2(I5,I4),I6,F14.7,' =ULAM')
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE ULAM
!
!                             *******************
!
      SUBROUTINE VA04A(X,E,N,NL,F,ESCALE,IPRINT,ICON,MAXIT)
!
!-----------------------------------------------------------------------
!
!  SR.VA04A HAS BEEN WRITTEN BY M.J.D.POWELL,
!  SEE REF.  M.J.D. POWELL, COMP.J.7(1965)303-7,
!  AND MODIFIED (BY WE) SO AS TO ACCEPT A RETURN VALUE NL=0 AFTER
!  CALL CALCFX(NL,X,F) AS A COMMAND TO QUIT WITHOUT FINISHING.
!  SR.CALCFX SUPPLIES THE VARIATIONAL FUNCTIONAL F.
!
!  IT IS CALLED BY:
!    SR.MINIM
!
!  IT CALLS:
!    SR.CALCFX
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      ALLOCATABLE :: W(:)
!
      DIMENSION  X(N),E(N)
!
!-----------------------------------------------------------------------
!
      IF(N.LE.0)RETURN                !NOTHING TO VARY, SILENT RETURN...
!
      IXDN3=N*(N+3)
      ALLOCATE(W(IXDN3))
!
      FHOLD=DZERO
      DDMAG=D0PT1*ESCALE
      SCER=D0PT05/ESCALE
      NFCC=1
      J=N+1
      JJ=J*N
      JJJ=JJ+N
      DO K=J,JJ
        W(K)=DZERO
      ENDDO
      ISGRAD=0
      ITERC=0
      IND=0
      INN=0
      K=0
      DO I=1,N
        K=K+J
        W(K)=ABS(E(I))
        W(I)=ESCALE
      ENDDO
!
      CALL CALCFX(NL,X,F)
!
      FKEEP=ABS(F)+ABS(F)
  100 ITONE=1
      ITERC=ITERC+1
      FP=F
      SUMM=DZERO
      IXP=JJ
      DO I=1,N
        IXP=IXP+1
        W(IXP)=X(I)
      ENDDO
!
      IF(NL.LE.0)GO TO 4100
!
      IDIRN=N+1
      ILINE=1
  200 DMAX=W(ILINE)
      DACC=DMAX*SCER
      D=D0PT1*DMAX
      IF(DDMAG.LT.D)D=DDMAG
      DDMAX=D20*DACC
      IF(DDMAX.GT.D)D=DDMAX
      DDMAX=DTEN*D
!
      IF(ITONE.LT.0)GO TO 1800
!
      DL=DZERO
      DA=DL
      FA=F
      FPREV=F
      IS=5
!
  300 DD=D-DL
      DL=D
  400 K=IDIRN
      DO I=1,N
        X(I)=X(I)+DD*W(K)
        K=K+1
      ENDDO
!
      CALL CALCFX(NL,X,F)
!
      IF(NL.LE.0)GO TO 4100
!
      NFCC=NFCC+1
!
      IF(IS.EQ.1)THEN
        GO TO 1900
      ELSEIF(IS.EQ.2)THEN
        GO TO 1700
      ELSEIF(IS.EQ.3)THEN
        GO TO 1600
      ELSEIF(IS.EQ.4)THEN
        GO TO 1300
      ELSEIF(IS.EQ.5)THEN
        GO TO 500
      ELSEIF(IS.EQ.6)THEN
        GO TO 3100
      ELSE
        STOP 'SR.VA04A: WE SHOULD NEVER GET HERE!'
      ENDIF
!
  500 IF(F.LT.FA)GO TO 600
      IF(F.GT.FA)GO TO 700
      IF(ABS(D).LT.DMAX)THEN
        D=D+D
        GO TO 300
      ELSE
        NL=0
        WRITE(MW6,10010)
        GO TO 4300
      ENDIF
!
  600 FB=F
      DB=D
      GO TO 800
!
  700 FB=FA
      DB=DA
      FA=F
      DA=D
  800 IF(ISGRAD.NE.0)GO TO 1000
  900 D=DB+DB-DA
      IS=1
      GO TO 300
!
 1000 D=DHALF*(DA+DB-(FA-FB)/(DA-DB))
      IS=4
      IF((DA-D)*(D-DB).GE.DZERO)GO TO 300
 1100 IS=1
      IF(ABS(D-DB).LE.DDMAX)GO TO 300
 1200 IS=1
      D=DB+SIGN(DDMAX,DB-DA)
      DDMAX=DDMAX+DDMAX
      DDMAG=DDMAG+DDMAG
      IF(DDMAX.LE.DMAX)GO TO 300
      DDMAX=DMAX
      GO TO 300
!
 1300 IF(F.GE.FA)GO TO 900
 1400 FC=FB
      DC=DB
 1500 FB=F
      DB=D
      GO TO 2000
!
 1600 IF(F.LE.FB)GO TO 1400
      FA=F
      DA=D
      GO TO 2000
!
 1700 IF(F.GE.FB)GO TO 1900
      FA=FB
      DA=DB
      GO TO 1500
!
 1800 DL=DONE
      DDMAX=DFIVE
      FA=FP
      DA=-DONE
      FB=FHOLD
      DB=DZERO
      D=DONE
 1900 FC=F
      DC=D
 2000 TA=(DB-DC)*(FA-FC)
      TB=(DC-DA)*(FB-FC)
      IF((TA+TB)*(DA-DC).GT.DZERO)GO TO 2100
      FA=FB
      DA=DB
      FB=FC
      DB=DC
      GO TO 1200
!
 2100 D=DHALF*(TA*(DB+DC)+TB*(DA+DC))/(TA+TB)
      DI=DB
      FI=FB
      IF(FB.LE.FC)GO TO 2200
      DI=DC
      FI=FC
 2200 IF(ITONE.LT.0)GO TO 2300
      IF(ABS(D-DI)-DACC.LE.DZERO)GO TO 2600
      IF(ABS(D-DI)-D0PT03*ABS(D).LE.DZERO)GO TO 2600
      GO TO 2400
!
 2300 ITONE=0
 2400 IF((DA-DC)*(DC-D).LT.DZERO)GO TO 2500
      FA=FB
      DA=DB
      FB=FC
      DB=DC
      GO TO 1100
!
 2500 IS=2
      IF((DB-D)*(D-DC).GE.DZERO)GO TO 300
      IS=3
      GO TO 300
!
 2600 F=FI
      D=DI-DL
      DD=SQRT((DC-DB)*(DC-DA)*(DA-DB)/(TA+TB))
      DO I=1,N
        X(I)=X(I)+D*W(IDIRN)
        W(IDIRN)=DD*W(IDIRN)
        IDIRN=IDIRN+1
      ENDDO
      W(ILINE)=W(ILINE)/DD
      ILINE=ILINE+1
!
      IF(IPRINT.NE.1)GO TO 2800
 2700 WRITE(MW6,10020)ITERC,NFCC,F,(X(I),I=1,N)
      IF(IPRINT.GT.1)GO TO 3500
!
 2800 IF(ITONE.LE.0)GO TO 3300
!
      IF(FPREV-F-SUMM.LT.DZERO)GO TO 2900
      SUMM=FPREV-F
      JIL=ILINE
 2900 IF(IDIRN.LE.JJ)GO TO 200
      IF(IND.NE.0)GO TO 3400
 3000 FHOLD=F
      IS=6
      IXP=JJ
      DO I=1,N
        IXP=IXP+1
        W(IXP)=X(I)-W(IXP)
      ENDDO
      DD=DONE
      GO TO 400
!
 3100 IF(IND.EQ.0)THEN
        IF(FP.LE.F)GO TO 3200
        D=DTWO*(FP+F-DTWO*FHOLD)/(FP-F)**2
        IF(D*(FP-FHOLD-SUMM)**2.GE.SUMM)GO TO 3200
      ENDIF
      J=JIL*N+1
      IF(J.LE.JJ)THEN
        DO I=J,JJ
          K=I-N
          W(K)=W(I)
        ENDDO
        DO I=JIL,N
          W(I-1)=W(I)
        ENDDO
      ENDIF
!
      ITONE=-1
      IDIRN=IDIRN-N
      K=IDIRN
      IXP=JJ
      AAA=DZERO
      DO I=1,N
        IXP=IXP+1
        W(K)=W(IXP)
        DDMAG=ABS(W(K)/E(I))
        IF(DDMAG.GT.AAA)AAA=DDMAG
        K=K+1
      ENDDO
      DDMAG=DONE
      W(N)=ESCALE/AAA
      ILINE=N
      GO TO 200
!
 3200 IXP=JJ
      AAA=DZERO
      F=FHOLD
      DO I=1,N
        IXP=IXP+1
        X(I)=X(I)-W(IXP)
        IF(AAA*ABS(E(I)).LT.ABS(W(IXP)))AAA=ABS(W(IXP)/E(I))
      ENDDO
      GO TO 3400
!
 3300 AAA=AAA*(DONE+DI)
      IF(IND.EQ.0)GO TO 3400
      INN=0
      IF(AAA.LE.D0PT1)GO TO 4300
      GO TO 3900
!
 3400 IF(IPRINT.GE.2)GO TO 2700
 3500 IF(IND.NE.0)GO TO 3800
      IF(AAA.GT.D0PT1)GO TO 3600
      IF(ICON.LE.1)GO TO 4300
      IND=2
      IF(INN.GT.0)GO TO 4400
      INN=2
      K=JJJ
      DO I=1,N
        K=K+1
        W(K)=X(I)
        X(I)=X(I)+DTEN*E(I)
      ENDDO
      FKEEP=F
!
      CALL CALCFX(NL,X,F)
!
      NFCC=NFCC+1
      DDMAG=DZERO
      GO TO 4000
!
 3600 IF(F.LT.FP)GO TO 3900
      fp=f                                     !assume diff small...
      go to 3900
 3700 NL=0
      WRITE(MW6,10040)F,FP
      GO TO 4300
!
 3800 IND=0
      if(fp.lt.f)fp=f                          !assume diff small...
 3900 ISGRAD=1
      DDMAG=D0PT4*SQRT(FP-F)
 4000 IF(ITERC.LT.MAXIT)GO TO 100
      GO TO 4200
!
 4100 IF(NL.LT.0)WRITE(MW6,10030)
      ITERC=ITERC-1
      IF(INN*IND.EQ.0)THEN
        FKEEP=FP
        JJJ=JJ
      ENDIF
!
 4200 WRITE(MW6,10050)ITERC
!
      IF(F.GT.FKEEP)THEN
        F=FKEEP
        DO I=1,N
          JJJ=JJJ+1
          X(I)=W(JJJ)
        ENDDO
      ENDIF
!
!-----------------------------------------------------------------------
!
 4300 DEALLOCATE(W)
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
!     IS.GT.0  ON ENTRY IN FOLLOWING OFF-LINE SECTION
!
!-----------------------------------------------------------------------
!
 4400 FP=FKEEP
      IF(F.EQ.FKEEP)GO TO 3700
      IF(F.GT.FKEEP)THEN
        IS=0
        FP=F
        F=FKEEP
      ENDIF
      IXP=JJ
      DO I=1,N
        IXP=IXP+1
        K=IXP+N
        FHOLD=W(K)
        IF(IS.EQ.0)THEN
          FHOLD=X(I)
          X(I)=W(K)
        ENDIF
        W(IXP)=FHOLD
      ENDDO
      JIL=2
      GO TO 3000
!
!-----------------------------------------------------------------------
!
10010 FORMAT(//' *** SR.VA04A: MAXIMUM CHANGE DOES NOT ALTER FUNCTION'/)
10020 FORMAT(//' ITERATION',I5,I15,' FUNCTION VALUES',9X,'F =',         &
     &       E21.14/(5E24.14))
10030 FORMAT(//' *** SR.VA04A: FLAGGED BY SR.CALCFX TO ABORT'/)
10040 FORMAT(//' *** SR.VA04A: ACCURACY LIMITED BY ERRORS IN F:',       &
     &       2E24.14/)
10050 FORMAT(I5,' ITERATIONS COMPLETED BY SR.VA04A')
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE VA04A
!
!                             *******************
!
      SUBROUTINE VACPOL(Z,RGRID,N,TB)
!
!-----------------------------------------------------------------------
!
!  This routine sets up the vacuum polarization potential for a point
!  charge Z at each grid point using the analytic functions defined by
!  L. Wayne Fullerton and G. A. Rinker Jr. in Phys. Rev. A Vol 13, page
!  1283,(1976).
!
!  The potential is accumulated in array TB(I),I=1,N .
!
!  Based on PHN's GRASP0 routine and freely adapted by NRB.
!
!  IT IS CALLED BY:
!    SR.QEDINT
!
!  IT CALLS:
!
!  IT CONTAINS:
!    FN.P, FN.S, FN.CF, FN.D, FN.E
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (P0=-0.71740181754_WP)
      PARAMETER (P1=1.1780972274_WP)
      PARAMETER (P2=-0.37499963087_WP)
      PARAMETER (P3=0.1308967553_WP)
      PARAMETER (P4=-0.038258286439_WP)
      PARAMETER (P5=-0.0000242972873_WP)
      PARAMETER (P6=-0.3592014867E-3_WP)
      PARAMETER (P7=-0.171700907E-4_WP)
      PARAMETER (S0=-64.0514843293_WP)
      PARAMETER (S1=0.711722714285_WP)
      PARAMETER (CF0=64.0514843287_WP)
      PARAMETER (CF1=-0.711722686403_WP)
      PARAMETER (CF2=0.0008042207748_WP)
      PARAMETER (D0=217.2386409_WP)
      PARAMETER (D1=1643.364528_WP)
      PARAMETER (D2=2122.244512_WP)
      PARAMETER (D3=-45.12004044_WP)
      PARAMETER (E0=115.5589983_WP)
      PARAMETER (E1=1292.191441_WP)
      PARAMETER (E2=3831.198012_WP)
      PARAMETER (E3=2904.410075_WP)
      PARAMETER (XX=163.0_WP)
!
      DIMENSION RGRID(*),TB(*)
!
!-----------------------------------------------------------------------
!
!  The following are the analytic functions needed:
!
!      P(X)=P0+X*(P1+X*(P2+X*(P3+X*(P4+X*(P5+X*(P6+X*P7))))))
!
!      S(X)=S0+X*(S1+X)
!
!      CF(X)=CF0+X*(CF1+X*CF2)
!
!      D(X)=D0+X*(D1+X*(D2+X*(D3+X)))
!
!      E(X)=E0+X*(E1+X*(E2+X*E3))
!
!-----------------------------------------------------------------------
!
      PI=ACOS(-DONE)
      FACTOR=-(DTWO*Z*DFSC)/(DTHREE*PI)
!
      DO I=1,N
        X=DTWO*RGRID(I)/DFSC
        IF(X.LE.DONE)THEN
          Y=X*X
          TB(I)=FACTOR*(P(X)+LOG(X)*S(Y)/CF(Y))
        ELSE
          IF(X.GE.XX)THEN
            TB(I)=DZERO
          ELSE
            Y=DONE/X
            TB(I)=FACTOR*EXP(-X)*D(Y)/E(Y)/X**(DTHREE/DTWO)
          ENDIF
        ENDIF
        TB(I)=TB(I)/RGRID(I)
      ENDDO
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION P(X)
!
      REAL(WP) X,P
!
      P=P0+X*(P1+X*(P2+X*(P3+X*(P4+X*(P5+X*(P6+X*P7))))))
!
      END FUNCTION P
!-----------------------------------------------------------------------
      FUNCTION S(X)
!
      REAL(WP) X,S
!
      S=S0+X*(S1+X)
!
      END FUNCTION S
!-----------------------------------------------------------------------
      FUNCTION CF(X)
!
      REAL(WP) X,CF
!
      CF=CF0+X*(CF1+X*CF2)
!
      END FUNCTION CF
!-----------------------------------------------------------------------
      FUNCTION D(X)
!
      REAL(WP) X,D
!
      D=D0+X*(D1+X*(D2+X*(D3+X)))
!
      END FUNCTION D
!-----------------------------------------------------------------------
      FUNCTION E(X)
!
      REAL(WP) X,E
!
      E=E0+X*(E1+X*(E2+X*E3))
!
      END FUNCTION E
!-----------------------------------------------------------------------
!
      END SUBROUTINE VACPOL
!
!                             *******************
!
      FUNCTION VCC(J1,J2,J,M1,M2,M)
!
!-----------------------------------------------------------------------
!
!  FN.VCC EVALUATES VECTOR COUPLING COEFFICIENTS.
!  THE SIX QUANTUM NUMBER ARGUMENTS HAVE TWICE THEIR PHYSICAL VALUE.
!
!  FACTORIALS DFS(I)=(I-1)!/LDFS**(I-1) FOR I=1,IXDFS ARE SUPPLIED
!  BY A PRIOR CALL TO SR.DFACT (CONTAINED IN MODULE CONSTAMTS_MATH).
!
!  CAN ALSO USE OLD STYLE DFS WHICH ALTERNATES FACTORIALS WITH PHASES,
!  ITS PHASE INFO IS NO LONGER USED. THE SWITCH IS TRANSPARENT.
!
!  IF THE ARGUMENTS ARE TOO LARGE FOR THE CURRENT PRECISION (FACTORIALS
!  AND/OR CANCELLATION) THEN SR.WIG3JRJ IS CALLED TO DETERMINE IT VIA
!  RECURSION. THIS IS LESS EFFICIENT.
!
!  N.B. WHILE USE OF LOG(I!) SOLVES ANY OVERFLOW PROBLEM, IT DOES NOT
!  SOLVE THE CANCELLATION PROBLEM AS THE VCC IS A SUM OF TERMS OF
!  ALTERNATING SIGN (AND SO EACH TERM MUST BE EXPONENTIATED FIRST).
!  THE PRODUCTS BELOW ARE ORGANIZED SUCH THAT CANCELLATION BECOMES AN
!  ISSUE BEFORE OVERFLOW.
!
!  IT IS CALLED BY:
!    SR.ALGEB2
!    SR.ALGEB3
!    SR.ALGEB4
!    SR.ALGX
!    SR.ALGXFS
!    SR.ALGXLS
!    SR.CAEKAL
!    SR.CAFLGL
!    SR.CAFLGL0
!    SR.CAFLGLX
!    SR.CAVE
!    SR.EKALG1
!    SR.FLGL1
!    SR.FLGLX1
!    SR.FLGLX3
!    SR.MKALG1
!    SR.RES1
!    SR.RESX1
!    SR.SOCC
!    SR.VCG
!    SR.VPNL
!
!  IT CALLS:
!    SR.DIMUSE
!    SR.WIG3JRJ
!    SR.WIG3JRM
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,XP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      INTEGER(SP) Z,ZMIN,ZMAX
!
      REAL(XP) XCC
!
      PARAMETER (DEPS2=1.D-5)
!
      DIMENSION IA(0:3),IB(0:3),JMN(3),JMX(3)
!
      ALLOCATABLE :: W3J(:)
!
      DATA BFIRST/.TRUE./
!
!-----------------------------------------------------------------------
!
      CC=DZERO
!
!      vc=dzero
!      w3=dzero
!
      IF(M1+M2.NE.M)GO TO 100
      IF(ABS(M1).GT.J1)GO TO 100
      IF(ABS(M2).GT.J2)GO TO 100
      IF(ABS(M).GT.J)GO TO 100
      IF(J.LT.ABS(J1-J2))GO TO 100
!
      IF(DFS(3).LT.DZERO)THEN
        IH=1                         !IH=1 USES OLD DFS ALIGNMENT
      ELSE
        IH=2                         !IH=2 USES NEW DFS ALIGNMENT
      ENDIF
!
      I1=2/IH
!
      K0=(J1+J2-J+2)/IH
      IF(K0.LE.0)GO TO 100           !DOESN'T SATISFY TRIANGLE
!
      JB=K0+I1
      JJ=JB+J*I1
!
!-----------------------------------------------------------------------
!
! WE CAN USE FACTORIALS, IF NOT TOO LARGE FOR CANCELLATION
!
!-----------------------------------------------------------------------
!
      IF(JJ.LE.IXDFS3)THEN
!
        CALL DIMUSE('MXDFS',JJ)
!
        ZMIN=0
        K4=(J-J2+M1)/IH
        IF(K4.LT.0)ZMIN=-K4
        K3=(J-J1-M2)/IH
        IF(K3+ZMIN.LT.0)ZMIN=-K3
        ZMAX=K0
        K2=(J2+M2+2)/IH
        IF(K2.LT.ZMAX)ZMAX=K2
        K1=(J1-M1+2)/IH
        IF(K1.LT.ZMAX)ZMAX=K1
        JC=K1+I1
        JD=K2+I1
!
        ZMIN=ZMIN+I1
!
        XCC=0
!
!        PHASE=MOD(IH*ZMAX-IONE,IFOUR)-2
!        DO Z=ZMAX,ZMIN,-I1        !REVERSE SUM TESTS CANCELLATION ERROR
!
        PHASE=MOD(IH*ZMIN-IONE,IFOUR)-2
        DO Z=ZMIN,ZMAX,I1                 !SUBJECT TO CANCELLATION ERROR
!
          PHASE=-PHASE
          XCC=PHASE/(DFS(Z)*DFS(JB-Z)*DFS(Z+K3)*DFS(JC-Z)*DFS(Z+K4)     &
     &        *DFS(JD-Z))+XCC
!
        ENDDO
!
        JB=K4+K1
        JC=K3+K2
        JD=K4+K0
        JG=K0+K3
        JH=K2+K4
        JI=K1+K3
!
        T=(REAL(J+1,XP)*DFS(K0)*DFS(JB)*DFS(JC)/(DFS(JJ)*LDFS))*DFS(K1) &
     &    *DFS(JG)*DFS(JH)*DFS(JI)*DFS(JD)*DFS(K2)
!
        if(t.lt.dzero)then        !graceful exit for any earlier problem
          write(mw6,*)'vcc:',J1,J2,J,M1,M2,M,t
          write(mw0,*)'vcc "failure"'
          t=dzero
!          stop 'vcc failure'
        endif
!
        CC=SQRT(T)*XCC
!
!        vc=cc
!!        write(mw6,*)'vcc=',cc
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! USE RECURSION IF CANCELLATION/TOO LARGE FOR FACTORIAL
!
!-----------------------------------------------------------------------
!
! USE RECURSION VIA SR.WIG3JRJ (DEFAULT)
!
      IF(JJ.GT.IXDFS3)THEN
!
        IF(BFIRST)THEN
          IF(XP.LT.16)THEN
!            WRITE(MW0,*)'*** FN.VCC: USING RECURSION, INCREASE XP?'
            WRITE(MW6,10010)JJ,IXDFS3,xp
          ENDIF
          BFIRST=.FALSE.
        ENDIF
!
! MAP VCC ORDER TO WIGNER 3J, PHASE TAKEN ACCOUNT OF LATER
!
! THEN RE-ORDER ARGUMENTS TO MINIMIZE LENGTH OF RECURSION
! (AS ONLY USED FOR LARGE ARGUMENT VALUES)
!
!        bcycle=.false.
        IA(1)=J1
        IA(2)=J2
        IA(3)=J
        IB(1)=M1
        IB(2)=M2
        IB(3)=-M                            !N.B. MINUS FOR WIG3J VS VCC
!2
!2        bcycle=.true.
!2        IA(1)=J2
!2        IA(2)=J
!2        IA(3)=J1
!2        IB(1)=M2
!2        IB(2)=-M
!2        IB(3)=M1
!3
!3        bcycle=.true.
!3        IA(1)=J
!3        IA(2)=J1
!3        IA(3)=J2
!3        IB(1)=-M
!3        IB(2)=M1
!3        IB(3)=M2
!
        JRNG1=99999
        DO IC=1,3
          JMN(IC)=MAX(ABS(IA(2)-IA(3)),ABS(IB(2)+IB(3)))          !TWICE
          JMX(IC)=IA(2)+IA(3)                                     !TWICE
          JRNG0=JMX(IC)-JMN(IC)
          IF(JRNG0.LT.JRNG1)THEN
            IC1=IC
            JRNG1=JRNG0
          ENDIF
          DO I=1,4              !OLD SCHOOL, COULD PROBABLY USE POINTERS
            I4=MOD(I,IFOUR)
            IA(I-1)=IA(I4)
            IB(I-1)=IB(I4)
          ENDDO
        ENDDO
!
!        NDIMW=JMX(IC1)/2
        IC1=IC1-1
        DO IC=1,IC1
!          bcycle=.true.
          DO I=1,4              !OLD SCHOOL, COULD PROBABLY USE POINTERS
            I4=MOD(I,IFOUR)
            IA(I-1)=IA(I4)
            IB(I-1)=IB(I4)
          ENDDO
        ENDDO
!
!        TA1=IA(1)
        TA2=IA(2)
        TA2=TA2/2
        TA3=IA(3)
        TA3=TA3/2
!        TB1=IB(1)
        TB2=IB(2)
        TB2=TB2/2
        TB3=IB(3)
        TB3=TB3/2
!
        NDIMW=NINT(TA2+TA3-DEPS2)        !NDIMW IS JUST JMAX
!
        ALLOCATE(W3J(-1:NDIMW+1))        !LBOUND ONLY NEEDS TO BE JMIN-1
!
        CALL WIG3JRJ(W3J,TA2,TA3,TB2,TB3,JMIN,JMAX,JH,NDIMW)
!
        IF(JMIN.LT.0)THEN
          IF(JMIN.EQ.-3)THEN                          !SHOULD NOT HAPPEN
            WRITE(MW0,*)                                                &
     &       '*** FN.VCC: WIG3JRJ DIMENSION FAILURE, INCREASE NDIMW TO '&
     &       ,JMAX
          ELSE
            WRITE(MW0,*)                                                &
     &  '*** FN.VCC: WIG3JRJ SELECTION RULE FAILURE, ALL 3J EQUAL ZERO!'
            IF(JMIN.EQ.-1)WRITE(MW0,*)                                  &
     &           '*** FN.VCC: WIG3JRJ FAILURE, NON-INTEGER TRIANGLE SUM'
            IF(JMIN.EQ.-2)WRITE(MW0,*)                                  &
     &              '*** FN.VCC: WIG3JRJ FAILURE, TRIANGLE RULE FAILURE'
          ENDIF
          DEALLOCATE(W3J)
          GO TO 100
        ENDIF
!
! THIS IS THE W3J LOCATION OF THE REQUIRED VCC
!
        JW=(IA(1)-JH)/2                 !NINT((TA1-JH)/DTWO)
!
! CONVERT W3J TO VCC
!
! PHASE - EDMONDS
        IP=ABS(J1-J2+M)
        IP=IP/2
        IP=MOD(IP,ITWO)
        IP=-IP-IP+1
! NORM
        TJ=J+1
        TJ=SQRT(TJ)
!
        CC=IP*TJ*W3J(JW)
!
!        w3=cc
!!        write(mw6,*)bcycle,'wig3jrj=',w3j(jw),ip,tj,cc
!
        DEALLOCATE(W3J)
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! USE RECURSION VIA SR.WIG3JRM (TEST ONLY AS NO ADVANTAGE OVER WIG3JRJ?)
!
      IF(-JJ.GT.IXDFS3)THEN
!
        IF(BFIRST)THEN
          IF(XP.LT.16)THEN
!            WRITE(MW0,*)'*** FN.VCC: USING RECURSION, INCREASE XP?'
            WRITE(MW6,10010)JJ,IXDFS3,XP
          ENDIF
          BFIRST=.FALSE.
        ENDIF
!
! COULD RE-ORDER ARGUMENTS TO MINIMIZE LENGTH OF RECURSION, IF NON TEST-
! -AS ABOVE FOR SR.WIG3JRJ (BUT WITH JMIN AS PER SR.WIG3JRM AS PER JMAX)
!
        TA1=J1
        TA1=TA1/2
        TA2=J2
        TA2=TA2/2
        TA3=J
        TA3=TA3/2
        TB1=M1
        TB1=TB1/2
!        TB2=M2
!        TB3=-M                                         !N.B. MINUS
!
        T=MAX(-TA2,-TA3-TB1)
        NL=NINT(T-DEPS2)
        T=MIN(TA2,TA3-TB1)
        NU=NINT(T-DEPS2)
!
        NDIMW=MAX(-NL,NU)
!
        ALLOCATE(W3J(-1-NDIMW:NDIMW+1))
!
        CALL WIG3JRM(W3J,TA1,TA2,TA3,TB1,JMIN,JMAX,JH,NDIMW)
!
        IF(JMAX.LT.JMIN)THEN
          IF(JMIN.EQ.-3)THEN                          !SHOULD NOT HAPPEN
            WRITE(MW0,*)                                                &
     &       '*** FN.VCC: WIG3JRM DIMENSION FAILURE, INCREASE NDIMW TO '&
     &       ,JMAX
          ELSE
            WRITE(MW0,*)                                                &
     &  '*** FN.VCC: WIG3JRM SELECTION RULE FAILURE, ALL 3J EQUAL ZERO!'
            IF(JMIN.EQ.-1)WRITE(MW0,*)                                  &
     &           '*** FN.VCC: WIG3JRM FAILURE, NON-INTEGER TRIANGLE SUM'
            IF(JMIN.EQ.-2)WRITE(MW0,*)                                  &
     &              '*** FN.VCC: WIG3JRM FAILURE, TRIANGLE RULE FAILURE'
          ENDIF
          DEALLOCATE(W3J)
          GO TO 100
        ENDIF
!
! THIS IS THE W3J LOCATION OF THE REQUIRED VCC
!
        JW=(M2-JH)/2                 !NINT((TB2-JH)/DTWO)
!
! CONVERT W3J TO VCC
!
! PHASE - EDMONDS
        IP=ABS(J1-J2+M)
        IP=IP/2
        IP=MOD(IP,ITWO)
        IP=-IP-IP+1
! NORM
        TJ=J+1
        TJ=SQRT(TJ)
!
        CC=IP*TJ*W3J(JW)
!
!        w3=cc
!!        write(mw6,*)'wig3jrm=',w3j(jw),ip,tj,cc
!
        DEALLOCATE(W3J)
!
      ENDIF
!
!-----------------------------------------------------------------------
!
! WE ARE DONE
!
  100 CONTINUE
!
!      if(abs(vc-w3).gt.1.d-12)then
!                          write(mw0,*)bcycle,'wig3jr=',w3,'vcc=',vc
!      endif
!
      VCC=CC
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(/' *** FN.VCC: FACTORIAL ARRAY TOO SHORT',I5,              &
     &       '.GT. IXDFS3=',I5,' WITH CURRENT WORD PRECISION XP=',I3,   &
     &       '; 3J-COEFFS ARE DETERMINED BY RECURSION'/)
!
!-----------------------------------------------------------------------
!
      END FUNCTION VCC
!
!                             *******************
!
      SUBROUTINE VCE(QLML,QLMS,QBML,QBMS,DU,DL,DS,NO,MAXEL)
!
!-----------------------------------------------------------------------
!
!  SR.VCE COMPUTES NB SIMULTANEOUS O.N. EIGENVECTORS DU(N,K),K=1,NB
!  WITH EIGENVALUES DS(K)/4 & DL(K)/4 OF TOTAL SPIN S AND ORBITAL L,
!  FROM A COMPLETE SET OF NB SLATER STATES J (=NO(N),N=1,NB),TO PAIRS
!  BIG MS,ML=QBMS/2,QBML/2 OF A CONFIGURATION KF WITH NF ELECTRONS;
!  TWICE LITTLE L,MS,ML OF I'TH ELECTRON  QL(QCGS(I)),QLMS,+L(I,J).
!
!  NRB: NOW ONLY CALLED FOR EQUIVALENT ELECTRON CONFIGURATION NL^Q
!       SO FAST (DIAGONALIZATION) *AND* MAXDF IS SMALL: 4F^7=119 !!!
!
!  INPUT: NB,NO,QLML,QLMS,QBML,QBMS, KF,NF,QCGS,QL; MAXEL
!
!  OUTPUT: DU,DL,DS;
!
!  N.B. WORKING ARRAYS: DV,DA (DU=DV*DA IN JACORD)
!
!  CONDITIONS: KF.LE.MAXCF, NF.LE.MAXEL.LE.MXEL0, NB.LE.MAXDF, NO.LE.MXS
!
!  REFERENCE: EQU'S 19-25 IN COMPUTER PHYS. COMMUN. 8(1974)270-306.
!
!  IT IS CALLED BY:
!    SR.VCU
!
!  IT CALLS:
!    SR.DIAG
!    SR.JACORD
!
!-----------------------------------------------------------------------
!
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY,QCGS
      USE COMMON_MISC,   ONLY: IDIAG
!
      USE COMMON_NRBAL1, ONLY: NF=>NFS,KF,NB,JA=>JAS,JB=>JBS            &
     &                        ,KSI,KSF,NTGA,NTGB
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TOL0=D1M14)
      PARAMETER (TOL1=3*D1M9)
!
      ALLOCATABLE :: DV(:,:),DA(:,:)                                    &
     &              ,DE(:),IWRK1(:),IWRK2(:)
!
      DIMENSION QLML(MAXEL,*),QLMS(MAXEL,*),QBML(*),QBMS(*)             &
     &         ,DU(IAXDF,*),DL(*),DS(*),NO(*)
!
!-----------------------------------------------------------------------
!
! FOR MODULE CAN JUST RENAME THESE IN USE XXX, ONLY NF=>NFS ETC.
!      POINTER :: NF,JA,JB
!      TARGET :: NFS,JAS,JBS
!
!-----------------------------------------------------------------------
!
!      NF=>NFS
!      JA=>JAS
!      JB=>JBS
!
!      EQUIVALENCE (NF,NFS),(JA,JAS),(JB,JBS)
!
!-----------------------------------------------------------------------
!
! LOCAL (IAXDF=NB HERE)
!
      ALLOCATE(DV(IAXDF,IAXDF),DA(IAXDF,IAXDF),DE(IAXDF),IWRK1(IAXDF),  &
     &         IWRK2(IAXDF),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'VCE: ALLOCATION FAILS FOR DV,DA,DE,IWRK'
        NF=0
        RETURN
      ENDIF
!
      IF(IDIAG.EQ.0)THEN
        STOL=TOL1
        DTOL=TOL0
      ELSE
        STOL=TOL1
        DTOL=STOL
      ENDIF
!
      BMSEQS=.TRUE.
!
      DO M12=1,2
!
        DO K=1,NB
!
          J=NO(K)
          DO I=1,NB
            DS(I)=DZERO
          ENDDO
          DS(K)=((M12-1)*QBML(J)+(2-M12)*QBMS(J))**2
!
          DO I=1,NF
!
            N3=QCGS(I)
            NI=QLMS(I,J)
            JD=2
            IF(.NOT.BMSEQS)THEN
              NI=QLML(I,J)
              JD=(QL(N3)+2)*QL(N3)-NI*NI
            ENDIF
            DS(K)=JD+DS(K)
!
            DO L=1,NF
!
              IF(L.EQ.I)GO TO 20
              N4=QCGS(L)
              DO JD=1,NF
                QLML(JD,1)=QLML(JD,J)
                QLMS(JD,1)=QLMS(JD,J)
              ENDDO
              IF(.NOT.BMSEQS)THEN
                QLML(I,1)=INT(NI-2,QP)
                KG=(QL(N3)+NI)*(QL(N3)-NI+2)
                QL0=QLML(L,J)
                QLML(L,1)=QL0+QTWO
                KP=(QL(N4)-QL0)*(QL(N4)+QL0+2)
              ELSE
                QLMS(I,1)=INT(NI-2,QP)
                KG=(1+NI)*(3-NI)
                QS0=QLMS(L,J)
                QLMS(L,1)=QS0+QTWO
                KP=(1-QS0)*(3+QS0)
              ENDIF
!
              IF(KG.LE.0.OR.KP.LE.0)GO TO 20
              DD=KG*KP
              DD=SQRT(DD)
!
              DO JD=1,NF
                KG=QCGS(JD)
                IF(N3.NE.KG.AND.N4.NE.KG)GO TO 10
                DO KP=JD,NF
                  IF(QCGS(KP).NE.KG)GO TO 6
                  IF(KP.EQ.JD)GO TO 6
                  NRJ=QLML(KP,1)
                  QS0=QLMS(JD,1)
                  QL0=QLML(JD,1)
                  IF(.NOT.BMSEQS)THEN
                    IF(QL0.GE.NRJ)GO TO 2
                    QLML(JD,1)=INT(NRJ,QP)
                    QLML(KP,1)=QL0
                    GO TO 4
                  ENDIF
                  IF(KP-JD.NE.1)GO TO 6
!            ASSUMING SLATER STATES IN SLATER ORDER -
    2             IF(QL0.NE.NRJ)GO TO 6
                  IF(QLMS(KP,1).EQ.QS0)GO TO 20
                  IF(QLMS(KP,1).LT.QS0)GO TO 6
    4             QLMS(JD,1)=QLMS(KP,1)
                  QLMS(KP,1)=QS0
                  DD=-DD
    6           ENDDO
   10         ENDDO
!
              DO KG=1,NB
                JD=NO(KG)
                DO KP=1,NF
                  IF(QLML(KP,JD).NE.QLML(KP,1))GO TO 15
                  IF(QLMS(KP,JD).NE.QLMS(KP,1))GO TO 15
                ENDDO
                DS(KG)=DS(KG)+DD
                GO TO 20
   15         ENDDO
!
   20       ENDDO
!
          ENDDO
!
!
! MATRIX S**2 (IF M12=1) OR L**2 IN DU; TAS CH.VII.4.8(P.221 IN 1964)
!
          IF(BMSEQS)THEN
            NLO=1                            !JACORD USES UPPER TRIANGLE
            IF(IDIAG.EQ.0)NLO=K              !DIAG USES LOWER TRIANGLE
            DO L=NLO,NB
              IF(ABS(DS(L)).LT.STOL)DS(L)=DZERO
              DU(L,K)=DS(L)
            ENDDO
          ELSE
            DO L=1,NB
              DU(L,K)=DS(L)
            ENDDO
          ENDIF
!
        ENDDO
!
!
        IF(.NOT.BMSEQS)THEN
!
          DO L=1,NB
            DO I=L+1,NB
              DU(I,L)=(DU(I,L)+DU(L,I))/DTWO                 !SYMMETRIZE
              DU(L,I)=DU(I,L)
            ENDDO
          ENDDO
!
          DO L=1,NB
            DO I=1,NB
              DA(I,L)=DZERO
              DO K=1,NB
                DA(I,L)=DV(K,I)*DU(K,L)+DA(I,L)
              ENDDO
            ENDDO
          ENDDO
!
          NLO=1                              !JACORD USES UPPER TRIANGLE
          DO L=1,NB
            IF(IDIAG.EQ.0)NLO=L              !DIAG USES LOWER TRIANGLE
            DO I=NLO,NB
              DU(I,L)=DZERO
            ENDDO
            DO K=1,NB
              DO I=NLO,NB
                DU(I,L)=DA(I,K)*DV(K,L)+DU(I,L)
              ENDDO
            ENDDO
            DO I=NLO,NB
              IF(ABS(DU(I,L)).LT.STOL)DU(I,L)=DZERO
            ENDDO
          ENDDO
!
        ENDIF
!
!
        IF(IDIAG.EQ.0)THEN
!
! TRY HOUSEHOLDER-QL METHOD FIRST
!
          CALL DIAG('V',NB,NB,-IONE,DU,DE,DS,IWRK1,IWRK2,IAXDF)
!
          IF(NB.EQ.0)GO TO 100
!
          IF(BMSEQS)THEN
            DO K=1,NB
              DO I=1,NB
                DD=DU(I,K)
                IF(ABS(DD).LT.DTOL)DD=DZERO
                DV(I,K)=DD
              ENDDO
            ENDDO
            BMSEQS=.FALSE.
          ELSE
            DO K=1,NB
              DS(K)=DZERO
              DO I=1,NB
                DD=DU(I,K)
                IF(ABS(DD).LT.DTOL)DD=DZERO
                DS(K)=DD*DL(I)*DD+DS(K)
                DA(I,K)=DD
              ENDDO
            ENDDO
          ENDIF
          DO K=1,NB
            DL(K)=DE(K)
          ENDDO
!
!
        ELSE
!
!
! TRY (SLOWER) JACOBI METHOD
!
          CALL JACORD('V',NB,DU,DA,IAXDF)
!
          IF(BMSEQS)THEN
            DO K=1,NB
              DO I=1,NB
                DD=DA(I,K)
                IF(ABS(DD).LT.DTOL)DD=DZERO
                DV(I,K)=DD
              ENDDO
            ENDDO
            BMSEQS=.FALSE.
          ELSE
            DO K=1,NB
              DS(K)=DZERO
              DO I=1,NB
                DD=DA(I,K)
                IF(ABS(DD).LT.DTOL)DD=DZERO
                DS(K)=DD*DL(I)*DD+DS(K)
                DA(I,K)=DD
              ENDDO
            ENDDO
          ENDIF
          DO K=1,NB
            DL(K)=DU(K,K)
          ENDDO
!
!
        ENDIF
!
!
      ENDDO                       ! END M12 LOOP
!
!
      DO L=1,NB
        DO I=1,NB
          DU(I,L)=DZERO
        ENDDO
        DO K=1,NB
          DO I=1,NB
            DU(I,L)=DV(I,K)*DA(K,L)+DU(I,L)
          ENDDO
        ENDDO
      ENDDO
!
!-----------------------------------------------------------------------
!
  100 CONTINUE
!
! LOCAL
!
      DEALLOCATE(DV,DA,DE,IWRK1,IWRK2,STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'VCE: DE-ALLOCATION FAILS FOR DV,DA,DE,IWRK'
        NF=0
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE VCE
!
!                             *******************
!
      SUBROUTINE VCG(QLML,QLMS,QBML,QBMS,IAXST,MAXEL)
!
!-----------------------------------------------------------------------
!
!  SR VCG COUPLES TWO SUBCONFIGURATIONS (OF SLATER STATES) TO FORM A
!  NEW SUBCONFIGURATION, COMPLETE WITH SLATERSTATE EXPANSION.
!  (SAME FUNCTION AS PJS'S OF THE SAME NAME OR WE'S COLLAG.)
!
!  INPUT: RESULTS FROM VCU FOR TWO SUBCONFIGURATIONS OF CONFIGURATION KF
!  THE FIRST IS STORED IN THE USUAL LOCATIONS (SEE BELOW) THE SECOND
!  USES THE SAME ARRAYS BUT INDEXED BY NFS,JAS,JBS,NTGA,NTGB,
!  QCGS(MXEL0).
!  NEL(K,KF) EQUIVALENT ELECTRONS WITH ANGULAR LITTLE L=QL(K)/2;
!  JB=HIGHEST INDEX TO SLATER STATE ARRAYS QBXX AND QLXX OCCUPIED
!  BY CONFIGURATIONS .LT.KF; NTG(KF-1)=HIGHEST PREVIOUS INDEX TO
!  TERM ARRAYS XTGX; VCC-ARRAY DC (OF LENGTH MXD) HAS BEEN FILLED
!  UP TO MTGD IN PREVIOUS CALL.
!  QCS0,QCL0=2*(SMAX,LMAX) IN CONFIGURATIONS .LT.KF
!
!  OUTPUT: RESULTANT, STORED IN USUAL LOCATIONS WITH INDEXES UPDATED.
!  VIZ. NF=NUMBER OF ELECTRONS, QCG(I,KF)=GROUP NUMBER OF I'TH
!  ELECTRON, SLATERSTATES QLML+QLMS(I,J),I=1,NF,J=JA,JB QBML+QBMS(J);
!  NUMBER OF SL-TERMS=NTG(KF)-NTG(KF-1), TERMS 2S,2L,NO=QTGS,L,D
!  (K),K=NTG(KF-1),NTG(KF), COUPLING COEFFICIENTS DC(J+JTGD(K)).
!  PARITY QCP(KF) (0,2 FOR EVEN,ODD). UPDATED JB, MTGD, QCS0,QCL0
!
!  IT IS CALLED BY:
!    SR.ALGEB1
!
!  IT CALLS:
!    SR.DIMUSE
!    SR.DISKDC
!    SR.RE_ALLOC
!    FN.VCC
!
!-----------------------------------------------------------------------
!
      USE COMMON_ALGEB,  ONLY: MPRINT
      USE COMMON_ALGEB,  ONLY: MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD     &
     &                        ,KFBUFF
!!      COMMON /BASIC/NF,KY,KG,JA,JB,JSP1,MSST,MGAP(5)
      USE COMMON_BASIC,  ONLY: NF                                       &
     &              ,KY=>IBSK2,KG=>IBSK3,JA=>IBSK4,JB=>IBSK5            &
     &              ,JSP1=>IBSK6,MSST=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9  &
     &              ,IBSK10=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY,QCGS
      USE COMMON_DC,     ONLY: BFAST,DC,IDC,IXIDC
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_QTG,    ONLY: MTGD,NTT,NTG,JTGD,QTGS,QTGL,QTGD         &
     &                        ,NFI,NFK,NFQ
      USE COMMON_TERMS,  ONLY: NSL0,NSL,QSI,QLI,QPI
!
      USE COMMON_NRBAL1, ONLY: NFS,KF,NB,JAS,JBS,KSI,KSF,NTGA,NTGB
      USE COMMON_NRBDW,  ONLY: IDW
      USE COMMON_NRBGCF, ONLY: KGSL,KGCF,NKSL
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,NASTJ                           &
     &                        ,MINJT,MAXJT,NEIGENJ
      USE COMMON_NRBKUT, ONLY: KCUTX,LSKUT,NASTK
      USE COMMON_NRBKUTP,ONLY: KCUTP,LSKUTP,NASTKP
      USE COMMON_NRBLIM, ONLY: ECNTRB,ITANAL,BANAL
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,NAST                          &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBLSP, ONLY: LSPIP,NLSPIP,NASTP                       &
     &                        ,MINSTP,MAXSTP,MINLTP,MAXLTP
      USE COMMON_NRBLSS, ONLY: NESSH,NASTS,MINSTS,MAXSTS,MINLTS,MAXLTS
      USE COMMON_NRBPNT, ONLY: NTGP,NTGS,NTP1,NTP2
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,IBUFF4
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (TYNY=D1M5)
      PARAMETER (TTYNY=TYNY*TYNY)
!
      INTEGER(EP) m8
!
      ALLOCATABLE :: NTJX(:),NTJXS(:),BSKP(:)
      ALLOCATABLE :: NX1(:),LX1(:)
      ALLOCATABLE :: JHOLD(:)
!
      DIMENSION QLML(MAXEL,*),QLMS(MAXEL,*),QBML(*),QBMS(*)
!      DIMENSION JHOLD(MAXSL)
!
      DATA MSST0/0/,KF0/0/
!
!-----------------------------------------------------------------------
!
      BLOCAL=.FALSE.
!
      BFINAL=IAXST.LT.0
      IF(BFINAL)IAXST=-IAXST
!
      BDISK=KF.GT.KUTDSK                   !USE DISKDC
      BDISK=BDISK.AND.BFINAL
!
      BDROP=.NOT.BFAST.AND.BFINAL
!
      IF(KF.LT.KF0)MSST0=0
      KF0=KF
!
      MTGD0=MTGD
!
      NF0=NF
      NF=NF+NFS
!
      DO I=1,NFS
        QCG(NF0+I,KF)=QCGS(I)
      ENDDO
!
! IF NO PREVIOUS TO COUPLE TO THEN INITIALIZE
!
      IF(NF0.EQ.0)THEN
        JA=JAS
        JB=JBS
        NTP1=0
        N1=NTGA+1
        QCS=QTGS(N1)
        QCL=QTGL(N1)
        K0=1
        J=0
        N=0
        DO I=N1,NTGB
          N=N+1
          NFI(N)=QTGS(I)
          NFK(N)=QTGL(I)
          NFQ(N)=QTGD(I)
          IF(QCS.EQ.QTGS(I).AND.QCL.EQ.QTGL(I))THEN
            J=J+1
          ELSE
            NKSL(K0,KF)=J
            QCS=QTGS(I)
            QCL=QTGL(I)
            K0=K0+1
            J=1
          ENDIF
        ENDDO
        NKSL(K0,KF)=J
        KSL0=K0
        NTP2=N
!
! IF FIRST AND FINAL THEN MUST COMPLETE FINAL TRANSFER ETC
!
        IF(BDROP)THEN                       !VARIABLE LENGTH
!
          CALL DIMUSE('MAXDC',MTGD)         !HOLD MAX BUFFER USED
!
! INDEX (SINCE NO GAPS)
!
          K=MTGD+1
          DO N=NTP2,1,-1
            DO J=JB,JA,-1
              K=K-1
              IDC(K)=J
            ENDDO
          ENDDO
!
          MTGD1=K
          K=K-1
          MTGD=K
          N=NTGA
!
          I11=1
          IF(BDISK)I11=-1
!
! REDUCE AND RE-INDEX
!
          DO K0=1,KSL0
            KTT=NKSL(K0,KF)
            DO KT=1,KTT
              N=N+1
!OLD          DO N=N1,NTGB
              DO J=JA,JB
                K=K+1
                IF(ABS(DC(K)).GT.TTYNY)THEN
                  MTGD=MTGD+1
                  IDC(MTGD)=J
                  DC(MTGD)=DC(K)
                ENDIF
              ENDDO
              JTGD(N)=MTGD
              IF(I11.LT.0)THEN
                JTGD(N)=-JTGD(N)                             !FLAG FIRST
                I11=1
              ENDIF
            ENDDO
            IF(BDISK)THEN                                  !DUMP TO DISK
              CALL DISKDC(IUD,MTGD1,MTGD,KF,K0,-IONE,IZERO)
              MTGD=MTGD1-1
              I11=-1
            ENDIF
          ENDDO
!
          NTG(KF)=NTGB
          NTGA=NTG(KF)
          MSST0=MAX(IZERO,MSST0)                !for old <0 I*2 overflow
!       write(mw6,*)'vcg 1: msst0=',msst0
          CALL DIMUSE('MXST0',MSST0)            !update
          CALL DIMUSE('MAXCT',NTGB)
!
          IF(NTP2.EQ.0)THEN         !NO TERMS   - POSSIBLE????
            WRITE(MW6,10150)KF
            IF(IDW.NE.0)NF=-1
          ENDIF
          GO TO 600
!
! FIXED LENGTH, COMPLETE SAVE ANY DISK WRITES, SO:
!
        ELSEIF(BDISK)THEN
!
          CALL DIMUSE('MAXDC',MTGD)                !HOLD MAX BUFFER USED
!
          JBA1=JB-JA+1
          NBA=NTGB-NTGA
          MTGD=MTGD-JBA1*NBA
          MTGD1=MTGD+1
!
          DO K0=1,KSL0
            KTT=NKSL(K0,KF)
            MTGD=MTGD+KTT*JBA1
            CALL DISKDC(IUD,MTGD1,MTGD,KF,K0,-IONE,IZERO)
            MTGD1=MTGD+1                             !SINCE DC HOLDS ALL
          ENDDO
!                             NEW INDEX
          MTGD=MTGD-JBA1*NBA
          MTGD1=MTGD+1
          N=NTGA
          DO K0=1,KSL0
            KTT=NKSL(K0,KF)
            DO KT=1,KTT
              N=N+1
              JTGD(N)=MTGD+1-JA
              MTGD=MTGD+JBA1
            ENDDO
            MTGD=MTGD1-1
          ENDDO
        ENDIF
!
        GO TO 500                   !AND RETURN EVNTLY
      ENDIF
!
      KSL0=0
      IF(NB.NE.0)GO TO 500          !VCU FAILURE - RETURN EVNTLY
!
! FLAG ANY TERMS TO BE SKIPPED, BASED ON ITANAL
!
      BSKP0=.FALSE.
      IF(ITANAL.GT.0)THEN                  !ONLY SET ON "FINAL" COUPLING
!
        ALLOCATE(NX1(IXEL0),LX1(IXEL0))
!
   50   READ(MRW31,10010,END=100)I00,NTT,KK,NFF,                        &
     &                           (NX1(IJ),LX1(IJ),IJ=1,NF)
!
        IF(NF.NE.NFF)THEN
          DO I=1,I00
            READ(MRW31,*)
          ENDDO
          GO TO 50
        ENDIF
!
        DO N=NF,1,-1
          J=QCG(N,KF)
          IF(QN(J).NE.NX1(N).OR.QL(J).NE.2*LX1(N))THEN     !SKIP RECORDS
            DO I=1,I00
              READ(MRW31,*)
            ENDDO
            GO TO 50
          ENDIF
        ENDDO
!
        BANAL(KF)=.TRUE.                   !FLAG MATCH SO DO NOT REWRITE
        IF(KF.LE.KCUT.AND.KK.LT.0)WRITE(MW6,10030)KF
        IF(KF.GT.KCUT.AND.KK.GT.0)WRITE(MW6,10040)KF
        BSKP0=.TRUE.
!
        ALLOCATE(BSKP(NTT))
!
        DO I=1,NTT
          BSKP(I)=.FALSE.
        ENDDO
        J0=0
        DO I=1,I00
          READ(MRW31,10020)I0,DD
          BSKP(I0)=DD.LT.ECNTRB
          IF(BSKP(I0))J0=J0+1
        ENDDO
!
        WRITE(MW6,10050)KF,J0
        IF(I00.NE.J0)WRITE(MW6,10060)I00-J0,ECNTRB
!
  100   DEALLOCATE(NX1,LX1)
!
      ENDIF
!
! INITIALIZE
!
      BCUT=KCUT**2.LT.KF*KCUT
      BCUTP=KCUTP**2.LT.KF*KCUTP
!
      BMSEQS=MPRINT+4.LT.0   !OLD+2. IF TRUE: SIZE CHECK ONLY - NO VCC'S
!      IF(BMSEQS)THEN
!        MTGDMX=0
!      ELSE
!        MTGDMX=MAXDC
!      ENDIF
!
! COUPLE THE TWO SUBCONFIG'S TERMS, STORED IN QTGX, TO FORM NEW SET.
! FIRST SET INDEXED BY NTG(KF-1)+1 THRU NTG(KF)
! SECOND SET INDEXED BY NTGA=NTG(KF)+1 THRU NTGB
! STORE RESULTANT (EVENTUALLY) IN QTGX, OVERWRITING ORIGINAL SETS,
! I.E RESULTANT STARTS AT NTG(KF-1)+1 STILL BUT WITH INCREMENTED NTG(KF)
!
      BMGE3=ABS(MODD).GE.3
!
      IF(.NOT.BMGE3)THEN                   !INITIALIZE FOR LOCAL MAX S,L
        QCS0=0
        QCL0=0
      ENDIF
!
! *TBD*: THE I,J LOOPS SHOULD REALLY BE OVER SYMMETRY GROUPS BECAUSE THE
!        TERMS ARE SYMMETRY ORDERED HERE - INELEGANT MORE THAN ANYTHING.
!
      K0=0
      K=NTGB
      DO I=NTG(KF-1)+1,NTG(KF)
        DO J=NTGA+1,NTGB
!
          QSTMN=QTGS(I)-QTGS(J)
          QSTMN=ABS(QSTMN)
          QSTMX=QTGS(I)+QTGS(J)
          QLTMN=QTGL(I)-QTGL(J)
          QLTMN=ABS(QLTMN)
          QLTMX=QTGL(I)+QTGL(J)
!
          DO QLT=QLTMX,QLTMN,-2
            DO QST=QSTMX,QSTMN,-2
!
              IF(BMGE3.AND.(QCS0.NE.QST.OR.QCL0.NE.QLT))GO TO 120
!
              LSPT=10000*(QST+1)+5*QLT+QCP(KF)/2     !QLT=2*L
! PARENT
              IF(NASTP.GT.0)THEN              !SEE IF PARENT TERM WANTED
                NASTP0=NLSPIP(KF)
                IF(NASTP0.EQ.0)GO TO 105          !UNRESTRICTED BY NASTP
                DO N=1,NASTP0
                  IF(LSPIP(N,KF).EQ.LSPT)GO TO 105   !YES
                ENDDO
                GO TO 120                            !NO
              ELSEIF(NASTP.LT.0)THEN
                IF(QST+1.LT.MINSTP.OR.QST+1.GT.MAXSTP)GO TO 120
                IF(QLT/2.LT.MINLTP.OR.QLT/2.GT.MAXLTP)GO TO 120
              ENDIF
!
  105         IF(KCUTP.GT.0)THEN           !LOOK FOR EXISTING PARENT SYM
                DO N=1,NASTKP
                  IF(LSKUTP(N).EQ.LSPT)GO TO 115    !FOUND
                ENDDO
                IF(BCUTP)GO TO 120                  !CORR, SO NOT WANTED
                NASTKP=NASTKP+1                     !WANTED, ADD TO LIST
                LSKUTP(NASTKP)=LSPT
!                write(mw6,*)'vcg',-nastkp,qst+1,qlt/2,qcp(kf)/2
                GO TO 115
              ENDIF
! FINAL CF
              IF(NAST.GT.0)THEN                      !SEE IF TERM WANTED
                DO N=1,NAST
                  IF(LSPI(N).EQ.LSPT)GO TO 110       !YES
                ENDDO
                GO TO 120                            !NO
              ELSEIF(NAST.LT.0)THEN
                IF(QST+1.LT.MINSP.OR.QST+1.GT.MAXSP)GO TO 120
                IF(QLT/2.LT.MINLT.OR.QLT/2.GT.MAXLT)GO TO 120
              ELSEIF(NASTJ.GT.0)THEN        !CHECK TRIANGLE CONTRIB TO J
                DO N=1,NASTJ
                  JT=JPI(N)/10
                  IF(QCP(KF)/2.EQ.JPI(N)-10*JT)THEN  !SAME PARITY
                    IF(QST+QLT.GE.JT.AND.ABS(QST-QLT).LE.JT)GO TO 110
                                                                    !YES
                  ENDIF
                ENDDO
                GO TO 120                           !NONE FOUND
              ELSEIF(NASTJ.LT.0)THEN        !CHECK TRIANGLE CONTRIB TO J
                IF(QST+QLT.LT.MINJT.OR.ABS(QST-QLT).GT.MAXJT)GO TO 120
              ENDIF
!
  110         IF(KCUT.GT.0)THEN              !LOOK FOR EXISTING SYMMETRY
                DO N=1,NASTK
                  IF(LSKUT(N).EQ.LSPT)GO TO 115     !FOUND
                ENDDO
                IF(BCUT)GO TO 120                   !CORR, SO NOT WANTED
                NASTK=NASTK+1                       !WANTED, ADD TO LIST
                LSKUT(NASTK)=LSPT
!                write(mw6,*)'vcg',nastk,qst+1,qlt/2,qcp(kf)/2
              ENDIF
!
  115         IF(BSKP0)THEN
                K0=K0+1
                IF(BSKP(K0))GO TO 120
              ENDIF
!
              QCS0=MAX(QCS0,QST)
              QCL0=MAX(QCL0,QLT)
!
              K=K+1
              IF(K.LE.IAXCT)THEN                     !MAXCT
                NTGP(K)=I
                NTGS(K)=J
                QTGS(K)=QST
                QTGL(K)=QLT
!
!                qtgd(k)=0
!                do n=ntgb+1,k
!                 if(qtgs(n).eq.qst.and.qtgl(n).eq.qlt)qtgd(k)=qtgd(k)+1
!                enddo
!          write(mw6,100)i,qtgs(i)+1,qtgl(i)/2,j,qtgs(j)+1,qtgl(j)/2
!     &    ,k-ntgb,qst+1,qlt/2,qtgd(k)
!  100     format(i5,i3,i2,i5,i3,i2,i7,i3,2i2)
!
              ENDIF
  120       ENDDO
          ENDDO
        ENDDO
      ENDDO
!
      IF(BSKP0)DEALLOCATE(BSKP)
!
      IF(K.GT.IAXCT)THEN !BUFFER IS INSUFFICIENT,WE KNOW ACTUAL NO TERMS
        WRITE(MW6,10090)K
        WRITE(MW0,*)'*** SR.VCG: INCREASE MAXCT BUFFER'
        NB=-2
        GO TO 500                                                !RETURN
      ELSE
        NTT=K
        CALL DIMUSE('MAXCT',NTT)
      ENDIF
!
      IF(NTT.EQ.NTGB)THEN                            !NO RESULTANT TERMS
        JB=JA-1
        NTGB=NTG(KF-1)
        IF(KF.GT.KUTDSK)THEN
          N0=NTG(KUTDSK)
        ELSE
          N0=NTGB
        ENDIF
        IF(BFAST)THEN
          MTGD=JTGD(N0+1)-1+JA
        ELSE
          MTGD=abs(JTGD(N0))
        ENDIF
!
        IF(NFS.EQ.0.OR.BMGE3)GO TO 500                      !WILL RETURN
!
        IF(BCUT.OR.BCUTP)THEN
          WRITE(MW6,10120)KF
          IF(IDW.EQ.0)GO TO 500
          NF=-1
          GO TO 600
        ELSE
          IF(ABS(NASTS)+NASTP+NAST+NASTJ.EQ.0)THEN
            WRITE(MW6,10100)KF
            NF=-1
            GO TO 600
          ELSE
            IF(NAST+NASTJ.NE.0)THEN
              WRITE(MW6,10110)KF
            ELSEIF(NASTP.NE.0)THEN
              WRITE(MW6,10160)KF
            ELSE
              WRITE(MW6,10170)KF
            ENDIF
            IF(IDW.EQ.0)GO TO 500
            NF=-1
            GO TO 600
          ENDIF
        ENDIF
      ENDIF
!
! SORT TERMS INTO STANDARD ORDER, BEFORE WE GENERATE SLATERSTATES
!
      K0=0
      N1=NTGB+1
      I=NTGB
!
      QCL=QCL0
!
  200 QCS=QCS0
!
  300 I0=I+1
      J=0
      DO K=N1,NTT
        IF(QTGL(K).EQ.QCL.AND.QTGS(K).EQ.QCS)THEN
          I=I+1
          NFI(I)=K
          J=J-1
          QTGD(I)=INT(J,QP)
        ENDIF
      ENDDO
!
      IF(J.LT.0)THEN
        J=-J
        J0=J+1
        DO II=I0,I
          QTGD(II)=QTGD(II)+INT(J0,QP)
        ENDDO
!
        K0=K0+1
        NKSL(K0,KF)=J               !NO. TERMS IN SL GROUP
      ENDIF
!
      QCS=QCS-QTWO
      IF(QCS.GE.0)GO TO 300         !LOOP UP FOR NEXT SPIN
!
      QCL=QCL-QTWO
      IF(QCL.GE.0)GO TO 200         !LOOP UP FOR NEXT ORB A.M.
!
      KSL0=K0                       !NO. OF SL GROUPS IN CF
!
! NOW RE-INDEX
!
      DO K=N1,NTT
        I=NFI(K)
        NFK(K)=QTGS(I)
        NFQ(K)=QTGL(I)
      ENDDO
!
! AND TRANSFER BACK
!
      DO K=N1,NTT
        QTGS(K)=INT(NFK(K),QP)
        QTGL(K)=INT(NFQ(K),QP)
!        write(mw6,*)k-ntgb,qtgs(k)+1,qtgl(k)/2,qtgd(k)
      ENDDO
!
! DITTO PARENT INFO
!
      DO K=N1,NTT
        I=NFI(K)
        NFK(K)=NTGS(I)
        NFQ(K)=NTGP(I)
      ENDDO
!
! AND TRANSFER BACK
!
      DO K=N1,NTT
        NTGS(K)=NFK(K)
        NTGP(K)=NFQ(K)
      ENDDO
!
!
! NOW FORM RESULTANT SLATERSTATES FROM THE TWO SUBCONFIG SETS
! FIRST SET INDEXED BY JA,JB
! SECOND SET INDEXED BY JAS,JBS
! RESULTANT INDEXED(EVENTUALLY) BY JA THRU NEW JB,
! OVERWRITING ORIGINAL SETS, ALL STORED IN DC.
! ORDERED BY DESCENDING ML, FOR IDW.GT.0.
! DOES NOT YET ASSUME THE ORIGINAL SETS WERE SO ORDERED,
! ALTHOUGH THEY MUST BE FOR IDW.NE.0 IN CASE VCG NOT NEEDED
! E.G. CF WITH SINGLE OPEN SUBSHELL.
!
      IF(MODD.GT.0.AND..NOT.BMGE3)THEN                        !RESET MOD
        MODD=-MODD
        WRITE(MW6,10070)MODD
      ENDIF
!
      MSMAX=QCS0
      MLMAX=QCL0
!
      IF(MODD.EQ.0)THEN
        MSMIN=-MSMAX
        MLMIN=-MLMAX
        MJMIN=-999
        if(idw.ne.0)then
          if(jsp1.le.0)msmin=-NF+2*(NF/2)      !LS: ASSUMES MTMS=MST !!!
!          write(mw0,*)'jsp, msmin=',jsp1,msmin
        endif
      ELSEIF(MODD.EQ.-1)THEN
        MSMIN=-MSMAX
        MLMIN=-MLMAX
        MJMIN=NF-2*(NF/2)
      ELSEIF(MODD.EQ.-2)THEN
        MSMIN=NF-2*(NF/2)
        MLMIN=0
        MJMIN=-999
      ELSEIF(BMGE3)THEN                          !HAS LITTLE MEANING NOW
        MSMIN=QCS0
        MLMIN=QCL0
        MJMIN=-999
      ELSE
        WRITE(MW6,10080)MODD
        WRITE(MW0,*)'*** SR.VCG: ILLEGAL MOD VALUE'
        NF=-1
        GO TO 600
      ENDIF
!
! LOCAL (TBD: USE ACTUAL DIMENSIONS)
      ALLOCATE(NTJX(IAXST),NTJXS(IAXST),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'VCG: ALLOCATION FAILS FOR  NTJX,NTJXS'
        NF=0
        GO TO 600
      ENDIF
      BLOCAL=.TRUE.
!
      JBT=JBS
      JAT=JBT+1
      NTS=0
!
      MTML=MLMAX
!
  400 DO JS=JAS,JBS                                  !SLATERSTATE LOOP
        MBLS=QBML(JS)
        MBSS=QBMS(JS)
!
        DO J=JA,JB                                   !SLATERSTATE LOOP
          MBL=QBML(J)
          MBLT=MBL+MBLS
          IF(MBLT.NE.MTML)GO TO 450
!
          MBS=QBMS(J)
          MBST=MBS+MBSS
          MBJT=MBST+MBLT
!
!              APPLY SELECTION RULES
!     &        MBLT.GE.MLMIN .AND. MBLT.LE.MLMAX .AND.    !OMIT
          IF(MBST.GE.MSMIN.AND.MBST.LE.MSMAX.AND.MBJT.GE.MJMIN)THEN
!
            JBT=JBT+1
            IF(JBT.GT.IAXST)THEN                     !FLAG VIA VCU SS
              MSST=(JB-JA+1)*(JBS-JAS+1)+JBS
              IF(IAXST.LT.MXST0)THEN                 !CANNOT HAPPEN NOW
                write(mw0,*)iaxst,maxel
                WRITE(MW6,10130)MSST,MSST*NF
                WRITE(MW0,*)                                            &
     &                  '*** SR.VCG: DIMENSION EXCEEDED, INCREASE MXEST'
              ELSE                                   !THIS CAN STILL
                WRITE(MW6,10140)MSST
                WRITE(MW0,*)                                            &
     &                  '*** SR.VCG: DIMENSION EXCEEDED, INCREASE MXST0'
              ENDIF
              NB=-3
              GO TO 500                              !RETURN
            ENDIF
            QBMS(JBT)=INT(MBST,QP)
            QBML(JBT)=INT(MBLT,QP)
            DO I=1,NF0
              QLMS(I,JBT)=QLMS(I,J)
              QLML(I,JBT)=QLML(I,J)
            ENDDO
            DO I=1,NFS
              QLMS(NF0+I,JBT)=QLMS(I,JS)
              QLML(NF0+I,JBT)=QLML(I,JS)
            ENDDO
            NTS=NTS+1
            NTJX(NTS)=J
            NTJXS(NTS)=JS
          ENDIF
  450   ENDDO
      ENDDO
!
      MTML=MTML-2
      IF(MTML.GE.MLMIN)GO TO 400
!
      MSST0=MAX(MSST0,JBT)                 !MAX SS STORAGE NEEDED BY VCG
!
      MTGD1=MTGD+1
      J1=JA-1
!
      m8=int(mtgd,ep)
!
!      iv=mtgd
!      jcmax=0
!
!      write(mw0,*)'kf=',kf,' mtgd=',mtgd
!
      IF(BDROP)ALLOCATE(JHOLD(KSL0))        !LOCAL
!                                           !TERM LOOP
      NT=NTGB
      DO K0=1,KSL0                          !SYMETRY GROUP 1 LOOP FOR KF
!
        KTT=NKSL(K0,KF)
!
        MTGDMX=KTT*NTS+MTGD                 !MAXIMAL, EXCLUDING TINY...
!
        IF(.NOT.BMSEQS.AND.MTGDMX.GT.0)THEN !mtgdmx.le.0 -> I*4 overflow
          IF(MTGDMX.GT.IAXDC)THEN
!
            IXXX=7*(IAXDC/5+1)
            if(IXXX.le.0)then               !IXXX.le.0 -> I*4 overflow
              m8=IAXDC/5+1
              m8=7*m8
              WRITE(MW6,10180)m8
              WRITE(MW0,*)'*** SR.VCG: TOO MANY VCCs FOR I*4'
              NB=-1
              GO TO 600
            endif
            IXXX=MAX(IXXX,MTGDMX)
!
            WRITE(MW6,*)'*** VCG: increasing MAXDC from ',IAXDC,' to: ',&
     &                  IXXX
            WRITE(MW0,*)'*** VCG: increasing MAXDC from ',IAXDC,' to: ',&
     &                  IXXX
!
            CALL RE_ALLOC(DC,IZERO,MTGD,IXXX,IERR)
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'VCG: RE-ALLOCATION FAILS FOR DC'
              NF=0
              GO TO 600
            ENDIF
!
            IF(DC(0).GT.DZERO)THEN
!
              IF(BFINAL)MTGD0=MTGD
              CALL RE_ALLOC(IDC,IONE,MTGD0,IXXX,IERR)
!
              IF(IERR.NE.0)THEN
                WRITE(MW0,*)'VCG: RE-ALLOCATION FAILS FOR IDC'
                NF=0
                GO TO 600
              ENDIF
!
            ENDIF
!
            IAXDC=IXXX
!
          ENDIF
        ENDIF
!
        DO KT=1,KTT                         !TERM LOOP FOR GROUP 1
          NT=NT+1
!      DO NT=N1,NTT
!
          JTGD(NT)=MTGD+1-JAT
          QST=QTGS(NT)
          QLT=QTGL(NT)
          NP=NTGP(NT)
          NS=NTGS(NT)
          QSP=QTGS(NP)
          QLP=QTGL(NP)
          QSS=QTGS(NS)
          QLS=QTGL(NS)
          JT=JTGD(NP)
          JTS=JTGD(NS)
!
!        write(mw6,*)qst,qlt
!        jcount=0
!
          DO N=1,NTS                         !TERM LOOP 2, OF NEXT SUBCF
!
            JS=NTJXS(N)
            MBSS=QBMS(JS)
            MBLS=QBML(JS)
!
            J=NTJX(N)
            MBS=QBMS(J)
            MBL=QBML(J)
!
            MBST=MBS+MBSS
            MBLT=MBL+MBLS
!
!          MTGD=MTGD+1
            m8=m8+1
            mtgd=int(m8,sp)
!
!          IF(MTGD.LE.MTGDMX)THEN
            DC(MTGD)=DZERO
            VC1=DC(JT+J)
            IF(ABS(VC1).GT.TYNY)THEN
              VC2=DC(JTS+JS)
              IF(ABS(VC2).GT.TYNY)THEN
                V1=VCC(INT(QSP,SP),INT(QSS,SP),INT(QST,SP),MBS,MBSS,    &
     &             MBST)
                V2=VCC(INT(QLP,SP),INT(QLS,SP),INT(QLT,SP),MBL,MBLS,    &
     &             MBLT)
                T=VC1*VC2*V1*V2
!
!                write(mw6,*)qsp,qss,qst,mbs,mbss,mbst
!     &              ,'  ',qlp,qls,qlt,mbl,mbls,mblt
!                write(mw6,*)nt,n,v1,v2,vc1,vc2,mtgd,t
!                if(abs(t).gt.tyny)then
!                  iv=iv+1
!                  jcount=jcount+1
!                endif
!
                IF(ABS(T).GT.TTYNY)THEN                    !<--- TTYNY
                  DC(MTGD)=T
                  IF(BDROP)IDC(MTGD)=N+J1
                ELSEIF(BDROP)THEN
                  MTGD=MTGD-1
                ENDIF
              ELSEIF(BDROP)THEN
                MTGD=MTGD-1
              ENDIF
            ELSEIF(BDROP)THEN
              MTGD=MTGD-1
            ENDIF
            m8=int(mtgd,ep)
!          endif
!
          ENDDO                                    !TERM LOOP 2
!          write(mw6,*)nt-ntgb,jcount
!        jcmax=max(jcmax,jcount)
        ENDDO                                      !TERM LOOP OF GROUP 1
!
        itest4=ibuff4
        itest4=itest4+1
        if(m8.gt.ibuff4.and.itest4.lt.ibuff4)then
          WRITE(MW6,10180)m8
          WRITE(MW0,*)'*** SR.VCG: TOO MANY VCCs FOR I*4'
          NB=-1
          GO TO 600
        endif
!
        IF(BDROP)JHOLD(K0)=MTGD                          !FINALIZE
        IF(BDISK)THEN
!         write(mw0,*)'k0=',k0,' mtgd=',mtgd-mtgd1+1
          IEND=MIN(MTGD,IAXDC)                                    !MAXDC
          CALL DISKDC(IUD,MTGD1,IEND,KF,K0,-IONE,IZERO)
          CALL DIMUSE('MAXDC',MTGD)                !HOLD MAX BUFFER USED
          MTGD=MTGD1-1
          m8=int(mtgd,ep)
        ENDIF
!
      ENDDO                                       !SYMMETRY GROUP 1 LOOP
!
!      write(mw0,*)kf,jcmax,iv-mtgd1+1,mtgd-mtgd1+1
      IF(BDISK)THEN
        MTGDMX=0
        CALL DIMUSE('MAXDC',MTGDMX)         !GET MAX USED
      ELSE
        MTGDMX=int(m8,sp)                   !MTGD
      ENDIF
      IF(MTGDMX.le.0)THEN             !.le.0 -> I*4 overflow
        WRITE(MW6,10180)m8
        WRITE(MW0,*)'*** SR.VCG: TOO MANY VCCs FOR I*4'
        NB=-1
        GO TO 600
      ENDIF
      IF(MTGDMX.GT.IAXDC)THEN                       !SHOULD NOT BE SO...
        WRITE(MW0,*)'*** SR.VCG: RE-ALLOCATION ERROR...'
        WRITE(MW6,*)'*** SR.VCG: RE-ALLOCATION ERROR...'
        NF=-1
        GO TO 600
      ENDIF
!
      IF(BMSEQS)THEN                        !FILL-IN FOR DIMENSION CHECK
        DO J=MTGD1,MTGD
          DC(J)=DONE
        ENDDO
        DO NT=N1,NTT
          QTGD(NT)=-QTGD(NT)
        ENDDO
        IF(BDROP)THEN
          M=MTGD1-1
          DO NT=N1,NTT
            DO N=1,NTS
              M=M+1
              IDC(M)=N+J1
            ENDDO
          ENDDO
        ENDIF
      ENDIF
!
! NOW OVERWRITE SUBCONFIGURATION STORAGE WITH RESULTANT
! (BACK-UP PARENT SLP FOR OPTIONAL PRINTING IN ALGEB1.)
!
      I0=NTG(KF-1)+1
      I1=JTGD(I0)-1+JA
!
      I=I1
      DO J=MTGD1,MTGD
        I=I+1
        DC(I)=DC(J)
      ENDDO
      IF(BDROP)THEN
        MHOLD=MTGD1-I1-1
        I=I1
        DO J=MTGD1,MTGD
          I=I+1
          IDC(I)=IDC(J)
        ENDDO
      ENDIF
!
      CALL DIMUSE('MAXDC',MTGD)                    !HOLD MAX BUFFER USED
      MTGD=I
!
      K=JA-1
      DO J=JAT,JBT
        K=K+1
        QBMS(K)=QBMS(J)
        QBML(K)=QBML(J)
        DO I=1,NF
          QLMS(I,K)=QLMS(I,J)
          QLML(I,K)=QLML(I,J)
        ENDDO
      ENDDO
!
      JB=K
!
      N=0
      DO I=NTG(KF-1)+1,NTG(KF)
        N=N+1
        NFI(N)=QTGS(I)
        NFK(N)=QTGL(I)
        NFQ(N)=QTGD(I)
      ENDDO
      NTP1=N
!
      DO I=NTGA+1,NTGB
        N=N+1
        NFI(N)=QTGS(I)
        NFK(N)=QTGL(I)
        NFQ(N)=QTGD(I)
      ENDDO
      NTP2=N
!
      J=NTG(KF-1)
      J0=JTGD(N1)-JTGD(J+1)               !AS  JA <- JAT
      DO N=N1,NTT
        J=J+1
        JTGD(J)=JTGD(N)-J0
        QTGS(J)=QTGS(N)
        QTGL(J)=QTGL(N)
        QTGD(J)=QTGD(N)
        NTGS(J)=NTGS(N)
        NTGP(J)=NTGP(N)
      ENDDO
!
      NTGB=J
!
  500 CONTINUE
!
      NTG(KF)=NTGB
      NTGA=NTG(KF)
!
! FINALLY, RE-DEFINE JTGD(N) TO GIVE THE *ABSOLUTE* POSITION OF
! THE *END* OF THE DC(I) ARRAY FOR TERM N.
! (ABSOLUTE SIMPLIFIES SPECIFICATION OF THE VARIABLE ARRAY LENGTH
!  WHILE *END* MEANS WE JUST NEED TO START AT JTGD(0)=0.)
!
      IF(BDROP)THEN
        JA1=JA-1
        N=NTG(KF-1)
        I11=1
        IF(BDISK)I11=-1
        DO K0=1,KSL0
          KTT=NKSL(K0,KF)
          DO KT=1,KTT-1
            N=N+1
            JTGD(N)=JTGD(N+1)+JA1
            IF(I11.LT.0)THEN
              JTGD(N)=-JTGD(N)                               !FLAG FIRST
              I11=1
            ENDIF
          ENDDO
          N=N+1
          JTGD(N)=JHOLD(K0)-MHOLD
          IF(I11.LT.0)JTGD(N)=-JTGD(N)                       !CASE KTT=1
          IF(BDISK)I11=-1
        ENDDO
!        if(n*ntgb.ne.ntgb*ntgb)stop 'vcg'
! for .not.bdisk only
!        DO N=NTG(KF-1)+1,NTG(KF)-1
!          JTGD(N)=JTGD(N+1)+JA1
!        ENDDO
!        JTGD(NTGB)=MTGD
!       write(mw6,*)'vcg 2: msst0=',msst0
        CALL DIMUSE('MXST0',MSST0)
        IF(ALLOCATED(JHOLD))DEALLOCATE(JHOLD)                     !LOCAL
      ENDIF
!
!-----------------------------------------------------------------------
!
  600 CONTINUE
!
      IF(BFINAL)KGCF(KF)=KSL0
!
!      if(bdcwr)then
!        n=ntg(kf-1)
!        do k0=1,ksl0
!         ktt=nksl(k0,kf)
!         do kt=1,ktt
!          n=n+1
!         write(mw6,*)kf,k0,n,jtgd(n)
!         enddo
!        enddo
!      endif
!
!-----------------------------------------------------------------------
!
      IF(BLOCAL)THEN
        DEALLOCATE(NTJX,NTJXS,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'VCG: DE-ALLOCATION FAILS FOR  NTJX,NTJXS'
          IF(NF.GT.0)NF=0
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(3I6,I3,100(I3,I2))
10020 FORMAT(I6,6X,F13.3)
10030 FORMAT(/'*** ATTENTION: CONFIGURATION',I5,' IS NOW SPECTROSCOPIC',&
     &       ' BUT WAS CORRELATION IN ITANAL...')
10040 FORMAT(/'*** ATTENTION: CONFIGURATION',I5,' IS NOW CORRELATION',  &
     &       ' BUT WAS SPECTROSCOPIC IN ITANAL...')
10050 FORMAT(//' CONFIGURATION CF=',I5,' DROPS',I5,' TERMS, BASED ON',  &
     &       ' USER SUPPLIED ITANAL FILE')
10060 FORMAT(22X,' NOTE:',I5,' TERMS WERE RETAINED BECAUSE YOU HAVE',   &
     &       ' REDUCED ECNTRB TO',F8.2,' /CM')
10070 FORMAT(/'*** SR.VCG: MOD RESET TO -MOD:',I3)
10080 FORMAT(/'*** SR.VCG: ILLEGAL MOD VALUE: ',I3)
10090 FORMAT(/'*** SR.VCG: INCREASE IAXCT BUFFER TO;',I6)
10100 FORMAT(/'*** VCG ERROR COUPLING SUBCONFIGURATIONS OF KF=',I5)
10110 FORMAT(/'*** ATTENTION: BECAUSE OF NAST/J THE FOLLOWING',' CF=',  &
     &       I5,' CONTRIBUTES NO TERMS/LEVELS...')
10120 FORMAT(/'*** ATTENTION: THE FOLLOWING CORRELATION CF=',I5,        &
     &       ' CONTRIBUTES NO TERMS/LEVELS...')
10130 FORMAT(/'*** SR.VCG: SLATER-STATE STORAGE (MAXST) NEEDED: ',      &
     &       I9/'    TRY INCREASING MXEST TO AT LEAST ',I10)
10140 FORMAT(/'*** SR.VCG: INCREASE MXST0 TO AT LEAST:',I9)
! 504  FORMAT(/'*** SR.VCG: INCREASE MAXDC TO AT LEAST:',I11)
10150 FORMAT(/'*** ATTENTION: THE FOLLOWING CONFIGURATION CF=',I5,      &
     &       ' CONTRIBUTES NO TERMS/LEVELS...')
10160 FORMAT(/'*** ATTENTION: BECAUSE OF NASTP  THE FOLLOWING',' CF=',  &
     &       I5,' CONTRIBUTES NO TERMS/LEVELS...')
10170 FORMAT(/'*** ATTENTION: BECAUSE OF NASTS  THE FOLLOWING',' CF=',  &
     &       I5,' CONTRIBUTES NO TERMS/LEVELS...')
10180 FORMAT(//'*** SR.VCG: I*4 OVERFLOW FOR DC ARRAY INDEX, MTGD=',I11,&
     &     ' - SET DEFAULT INTEGER SP=8 IN MODULE PRECSN, OR USE KUTDSK'&
     &     //)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE VCG
!
!                             *******************
!
      SUBROUTINE VCU(QLML,QLMS,QBML,QBMS,IAXST,MAXEL)
!
!-----------------------------------------------------------------------
!
!  SR VCU SETS UP SLATER STATES TO A CONFIGURATION GIVEN AS GROUPS OF
!  EQUIVALENT ELECTRONS,  AND COMPUTES VECTOR COUPLING COEFFICIENTS
!  (VCC) FOR CONSTRUCTING TERMS OF TOTAL SL FROM THE SLATER STATES.
!  IT REQUIRES SR VCE (WHICH REQUIRES SR JACORD AND ROTSYM).
!  MODD, IN /MQVC/, RULES DIFFERENT MODES, SEE COMMENT AT THE END.
!  NB=0: SUCCESSFUL RUN; OTHERWISE STUDY RETURN-COMMENTS AND CHECK NB
!
!  INPUT: CONFIGURATION KF, CONSISTING OF GROUPS K=1,2..MAXGR OF
!  NEL(K,KF) EQUIVALENT ELECTRONS WITH ANGULAR LITTLE L=QL(K)/2;
!  NEL.LT.0 IS IGNORED IN THIS PROGRAM (MIGHT BE USED FOR MARKING
!  CLOSED SUBSHELLS ELSEWHERE). FOR A KF.GT.KCUT SEE NOTE AT END.
!  JB=HIGHEST INDEX TO SLATER STATE ARRAYS QBXX AND QLXX OCCUPIED
!  BY CONFIGURATIONS .LT.KF; NTG(KF-1)=HIGHEST PREVIOUS INDEX TO
!  TERM ARRAYS XTGX; VCC-ARRAY DC (OF LENGTH MXD) HAS BEEN FILLED
!  UP TO MTGD IN PREVIOUS CALL.
!  QCS0,QCL0=2*(SMAX,LMAX) IN CONFIGURATIONS .LT.KF
!
!  OUTPUT: NF=NUMBER OF ELECTRONS, QCGS(I)=GROUP NUMBER OF I'TH
!  ELECTRON, SLATERSTATES QLML+QLMS(I,J),I=1,NF,J=JA,JB QBML+QBMS(J);
!  NUMBER OF SL-TERMS ND=NTGB-NTGA, TERMS 2S,2L,NO=QTGS,L,D
!  (K),K=NTG(KF-1),NTG(KF), COUPLING COEFFICIENTS DC(J+JTGD(K)).
!  PARITY QCP(KF) (0,2 FOR EVEN,ODD). UPDATED JB, MTGD, QCS0,QCL0
!
!  IT IS CALLED BY:
!    SR.ALGEB
!    SR.ALGEB1
!
!  IT CALLS:
!    SR.DIMUSE
!    SR.RE_ALLOC
!    SR.VCE
!
!-----------------------------------------------------------------------
!
      USE COMMON_ALGEB,  ONLY: MPRINT
      USE COMMON_ALGEB,  ONLY: MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD     &
     &                        ,KFBUFF
!!      COMMON /BASIC/MGAP1(6),MSST,MGAP2(5)
      USE COMMON_BASIC,  ONLY: NF0=>NF                                  &
     &              ,IBSK2=>IBSK2,IBSK3=>IBSK3,IBSK4=>IBSK4,IBSK5=>IBSK5&
     &              ,IBSK6=>IBSK6,MSST=>IBSK7,IBSK8=>IBSK8,IBSK9=>IBSK9 &
     &              ,IBSK10=>IBSK10,IBSK11=>IBSK11,IBSK12=>IBSK12
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY,QCGS
      USE COMMON_DC,     ONLY: BFAST,DC,IDC,IXIDC
      USE COMMON_MISC,   ONLY: IDIAG
      USE COMMON_MQVC,   ONLY: MODD,KCUT,QCL0,QCS0,NEL,KMAX
      USE COMMON_QTG,    ONLY: MTGD,NTT,NTG,JTGD,QTGS,QTGL,QTGD
!
      USE COMMON_NRBAL1, ONLY: NF=>NFS,KF,NB,JA=>JAS,JB=>JBS            &
     &                        ,KSI,KSF,NTGA,NTGB
      USE COMMON_NRBJ,   ONLY: JPI,NJPI,NASTJ                           &
     &                        ,MINJT,MAXJT,NEIGENJ
      USE COMMON_NRBKUT, ONLY: KCUTX,LSKUT,NASTK
      USE COMMON_NRBKUTP,ONLY: KCUTP,LSKUTP,NASTKP
      USE COMMON_NRBLS,  ONLY: LSPI,NLSPI,NAST                          &
     &                        ,MINSP,MAXSP,MINLT,MAXLT,IPAR,NEIGEN
      USE COMMON_NRBLSP, ONLY: LSPIP,NLSPIP,NASTP                       &
     &                        ,MINSTP,MAXSTP,MINLTP,MAXLTP
      USE COMMON_NRBLSS, ONLY: NESSH,NASTS,MINSTS,MAXSTS,MINLTS,MAXLTS
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
      USE REALLOCATE, ONLY: RE_ALLOC
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (STOL=D1M6)
      PARAMETER (TYNY=D1M5)
      PARAMETER (TTYNY=TYNY*TYNY)
!
      ALLOCATABLE :: DU(:,:)
      ALLOCATABLE :: DL(:),DS(:),NO(:)
!
      DIMENSION QLML(MAXEL,*),QLMS(MAXEL,*),QBML(*),QBMS(*)
!
! FOR MODULE CAN JUST RENAME THESE IN USE XXX, ONLY NF=>NFS ETC.
! OR SIMPLY REPLACE WITH SUBSHELL NAMES THROUGHOUT
!      POINTER :: NF,JA,JB
!      TARGET :: NFS,JAS,JBS
!
!-----------------------------------------------------------------------
!
!      NF=>NFS
!      JA=>JAS
!      JB=>JBS
!
!      EQUIVALENCE (NF,NFS),(JA,JAS),(JB,JBS)
!
!     data timev/0/
!     save timev
!
!-----------------------------------------------------------------------
!
      BCUT=KCUT**2.LT.KF*KCUT
      BCUTP=KCUTP**2.LT.KF*KCUTP
!
      IDIAG0=IDIAG
      JB0=JB
      MTGD0=MTGD
!
! store resultant at end of arrays so can sort by M_L on moving down.
!
      ja0=ja
      mshift=IAXST+jb0+1
!
  100 JB=JB0
      MTGD=MTGD0
      BMSEQS=MPRINT+2.LT.0  !OLD+2. IF TRUE: SIZE CHECK ONLY -- NO VCC'S
!
! COMPILE ALL THE SLATER STATES THAT FORM THE GIVEN CONFIGURATION --
! IN ARRAY LOCATIONS J=JA,JB, FOR NF ELECTRONS I=1,NF
!
      NB=-3
      ND=0
      KG=JB+2
      JA=KG-1
      NF=0
      KP=0
!
! LOOP OVER SUBCONFIGURATION DEFINED BY KSI,KSF
!
      DO K=KSI,KSF
        NRJ=NEL(K,KF)
        IF(NRJ.LE.0)GO TO 200         !CLOSED-SUBSHELL OR EMPTY
!
        NI=NF+1
        NU=NF+NRJ
        NF=NU
        IF(NU.GT.MAXEL)THEN           !TOO MANY ELECTRONS
          NB=-4
          GO TO 2800
        ENDIF
!
        KP=NRJ*QL(K)+KP
        J=JA
        JD=KG-J
!
  150   KG=J+JD
        JB=KG-1
!
! MAX VCU SS STORAGE DETERMINED BY *UNCOUPLED* PARENT+SUBSHELL HERE.
        jmx=2*kg-jb0-1                  !~2*JB
!        write(mw6,*)'vcu: jmx=',jmx
        CALL DIMUSE('MXST0',jmx)
        IF(mshift.lt.2*kg)THEN  !NOT ENOUGH SS BUFFER STORAGE JMX.GE.MXS
          MSST=jmx
          GO TO 2800
        ENDIF
!
        jx=mshift-j
        IF(NU.GE.NI)THEN
          MS=1
          ML=QL(K)
          DO I=NI,NU
            QCGS(I)=INT(K,QP)
            QLMS(I,Jx)=INT(MS,QP)
            QLML(I,Jx)=INT(ML,QP)
            MS=-MS
            ML=ML-1-MS
          ENDDO
        ENDIF
!
        DO L=J,KG
          NU=L-JD
          IF(NU.LT.JA)NU=L
          lx=mshift-l
          DO I=1,NF
            IF(I.EQ.NI)NU=J
            nux=mshift-nu
            QLML(I,Lx)=QLML(I,NUx)
            QLMS(I,Lx)=QLMS(I,NUx)
          ENDDO
        ENDDO
!
        J=KG
        jx=mshift-j
        DO I=NI,NF
          MS=QLMS(I,Jx)
          ML=QLML(I,Jx)-1+MS
          IF(ML.LT.-QL(K))GO TO 200
          QLMS(I,Jx)=-INT(MS,QP)
          QLML(I,Jx)=INT(ML,QP)
          NU=I-1
          IF(I.EQ.NF)GO TO 150
          IF(QLMS(I+1,Jx).EQ.MS)GO TO 150
          IF(QLML(I+1,Jx).NE.ML)GO TO 150
        ENDDO
!
  200 ENDDO
!
      QCP(KF)=INT(MOD(QCP(KF)+KP,IFOUR),QP)       !ACCUMULATE SUB-SHELLS
!
! ACCUMULATE SUBSHELL SS WEIGHTS, TO FORM WHOLE CONFIG.
!
      MSST=(MSST-1)*(JB-JA+1)+1
!      write(mw0,*)ja-1,jb-1,msst-1
!
! FORM M_X
!
      mlmax=-999
      mlmin=999
      DO jj=JA,JB
        j=mshift-jj
        QBML(J)=0
        QBMS(J)=0
        DO I=1,NF
          QBML(J)=QLML(I,J)+QBML(J)
          QBMS(J)=QLMS(I,J)+QBMS(J)
        ENDDO
        mlmin=min(mlmin,INT(qbml(j),SP))
        mlmax=max(mlmax,INT(qbml(j),SP))
      ENDDO
!
! order by descending M_L.
!
      mtml=mlmax
      j0=jb0
  300 do jj=ja,jb
        j=mshift-jj
        if(qbml(j).eq.mtml)then
          j0=j0+1
          qbml(j0)=qbml(j)
          qbms(j0)=qbms(j)
          do i=1,nf
            qlml(i,j0)=qlml(i,j)
            qlms(i,j0)=qlms(i,j)
          enddo
        endif
      enddo
!
      mtml=mtml-2
      if(mtml.ge.mlmin)go to 300
!
      if(j0.ne.jb)then
        write(mw0,*)ja0,jb0,ja,jb,j0,mshift
        stop 'indexing error'
      endif
!
! LISTING OF ND TERMS (SL) CONTAINED IN THE (JB-JA+1) SLATER STATES
! IN ARRAY LOCATIONS K=NTG(KF-1)+1,NTG(KF) (FOR NTG(KF-1)-NTG(KF).LE.ND)
!
      BMGE3=ABS(MODD).GE.3
      NB=-2
      N2=NTGA                                     !NTG(KF-1) IF WHOLE CF
      N1=N2+1
      QCS=0                                       !LOCAL MAX S
      QCL=0                                       !LOCAL MAX L
!     QDS=999                                     !LOCAL MIN S
!     QDL=999                                     !LOCAL MIN L
      IF(.NOT.BMGE3)THEN
        QCS0=0                                    !WAS GLOBAL, NOW LOCAL
        QCL0=0                                    !WAS GLOBAL, NOW LOCAL
      ENDIF
      NF21=NF+NF+1
!
      KG=0
      IF(MODD.LE.-3)KG=2
!
! START TERM GENERATION LOOP
!
  400 QL0=-1
      QS0=0
      DO J=JA,JB
        MS=QBMS(J)
        ML=QBML(J)
        IF(MS.GE.-NF.AND.ML.GE.QL0)THEN
          IF(ML.GT.QL0.OR.MS.GT.QS0)THEN
            QL0=INT(ML,QP)
            QS0=INT(MS,QP)
          ENDIF
        ENDIF
      ENDDO
!
      IF(QL0.LT.0)GO TO 1300
!
      IF(BMGE3)THEN
        IF(QL0.LT.QCL0-KG)GO TO 1000
        IF(QS0.LT.QCS0)GO TO 1000
        IF(QS0.GT.QCS0)GO TO 900
        IF(QL0.NE.QCL0)GO TO 900
      ENDIF
!
! APPLY USER SELECTIONS
!
      NRJ=NEL(KSF,KF)
      IF(NRJ.GT.0)THEN                     !KSI=KSF NORMALLY, NRJ<0 CORE
        IF(NASTS.GT.0)THEN                 !SEE IF SUB-SHELL/TERM WANTED
          BSKIP=.FALSE.
          NELS0=100000*KSF+1000*NRJ
          NELS=NELS0+10*(QS0+1)+QL0/2
          DO I=1,NASTS
            IF(NESSH(I).EQ.NELS0)THEN                        !SL NOT SET
              IF(QS0+1.GE.MINSTS.AND.QS0+1.LE.MAXSTS.AND.               &
     &           QL0/2.GE.MINLTS.AND.QL0/2.LE.MAXLTS)GO TO 500
              BSKIP=.TRUE.
            ELSE
              IO=NESSH(I)/100000
              IQ=(NESSH(I)-IO*100000)/1000
              IF(IO.EQ.KSF.AND.IQ.EQ.NRJ)THEN       !SPECTATOR SUB-SHELL
                IF(NESSH(I).EQ.NELS)GO TO 500
                BSKIP=.TRUE.
              ENDIF
            ENDIF
          ENDDO
          IF(BSKIP)GO TO 900
        ELSEIF(NASTS.LT.0)THEN
          NELS=100000*KSF+1000*NRJ
          DO I=1,-NASTS
            IF(NESSH(I).EQ.NELS)THEN                !SPECTATOR SUB-SHELL
              IF(QS0+1.LT.MINSTS.OR.QS0+1.GT.MAXSTS)GO TO 900
              IF(QL0/2.LT.MINLTS.OR.QL0/2.GT.MAXLTS)GO TO 900
            ENDIF
          ENDDO
        ENDIF
      ENDIF
!
  500 LSPT=10000*(QS0+1)+5*QL0+QCP(KF)/2    !QL0=2*L
!
      IF(NASTP.GT.0)THEN                    !SEE IF PARENT TERM WANTED
        NASTP0=NLSPIP(KF)
        IF(NASTP0.EQ.0)GO TO 600            !UNRESTRICTED BY NASTP
        DO I=1,NASTP0
          IF(LSPIP(I,KF).EQ.LSPT)GO TO 600
        ENDDO
        GO TO 900
      ELSEIF(NASTP.LT.0)THEN
        IF(QS0+1.LT.MINSTP.OR.QS0+1.GT.MAXSTP)GO TO 900
        IF(QL0/2.LT.MINLTP.OR.QL0/2.GT.MAXLTP)GO TO 900
      ENDIF
!
  600 IF(KCUTP.GT.0)THEN                   !LOOK FOR EXISTING PARENT SYM
        DO I=1,NASTKP
          IF(LSKUTP(I).EQ.LSPT)GO TO 800    !FOUND
        ENDDO
        IF(BCUTP)GO TO 900                  !CORR, SO NOT WANTED
        NASTKP=NASTKP+1                     !WANTED, ADD TO LIST
        LSKUTP(NASTKP)=LSPT
!        write(mw6,*)'vcu0',-nastkp,qs0+1,ql0/2,qcp(kf)/2
        GO TO 800
      ENDIF
! FINAL CF
      IF(NAST.GT.0)THEN                     !SEE IF TERM WANTED
        DO I=1,NAST
          IF(LSPI(I).EQ.LSPT)GO TO 700      !YES
        ENDDO
        GO TO 900                           !NO
      ELSEIF(NAST.LT.0)THEN
        IF(QS0+1.LT.MINSP.OR.QS0+1.GT.MAXSP)GO TO 900
        IF(QL0/2.LT.MINLT.OR.QL0/2.GT.MAXLT)GO TO 900
      ELSEIF(NASTJ.GT.0)THEN                !CHECK TRIANGLE CONTRIB TO J
        DO I=1,NASTJ
          JT=JPI(I)/10
          IF(QCP(KF)/2.EQ.JPI(I)-10*JT)THEN !SAME PARITY
            IF(QS0+QL0.GE.JT.AND.ABS(QS0-QL0).LE.JT)GO TO 700       !YES
          ENDIF
        ENDDO
        GO TO 900                           !NONE FOUND
      ELSEIF(NASTJ.LT.0)THEN                !CHECK TRIANGLE CONTRIB TO J
        IF(QS0+QL0.LT.MINJT.OR.ABS(QS0-QL0).GT.MAXJT)GO TO 900
      ENDIF
!
  700 IF(KCUT.GT.0)THEN                     !LOOK FOR EXISTING SYMMETRY
        DO I=1,NASTK
          IF(LSKUT(I).EQ.LSPT)GO TO 800     !FOUND
        ENDDO
        IF(BCUT)GO TO 900                   !CORR, SO NOT WANTED
        NASTK=NASTK+1                       !WANTED, ADD TO LIST
        LSKUT(NASTK)=LSPT
!        write(mw6,*)'vcu0',nastk,qs0+1,ql0/2,qcp(kf)/2
      ENDIF
!
! END USER SELECTION
!
  800 N2=N2+1                                     !NO. OF TERMS SELECTED
      IF(N2.GT.IAXCT)GO TO 900        !TERM ARRAYS TOO SMALL FOR PROBLEM
!
! DETERMINE  LOCAL MAX{S} AND MAX{L}
      IF(QCS.LT.QS0)QCS=QS0
      IF(QCL.LT.QL0)QCL=QL0
!
! DETERMINE LOCAL MIN{S} AND MIN{L}
!     IF(QDS.GT.QS0)QDS=QS0
!     IF(QDL.GT.QL0)QDL=QL0
!
      QTGS(N2)=QS0
      QTGL(N2)=QL0
      QTGD(N2)=0
      DO K=N1,N2
        IF(QTGL(K).EQ.QL0.AND.QTGS(K).EQ.QS0)QTGD(K)=QTGD(K)-QONE
      ENDDO
!
  900 ND=ND+1                             !NO. OF TERMS IN CF (NOT USED)
!
! STRIKE-OUT QBMS FOR THIS TERM
!
      jb0=ja-1
      ML=QL0                              !SINCE M_L IN DESCENDING ORDER
 1000 MS=QS0
!
      bflag=.true.
      ja0=jb0+1
      ja00=ja0
      do j=ja0,jb
        if(qbml(j).gt.ml)then                   !not needed for this m_l
          ja00=j+1
        elseif(qbml(j).lt.ml)then     !have moved on to next (lower) m_l
          jb0=j-1
          go to 1100
        elseif(bflag)then
          if(qbms(j).ge.-nf)then           !we have first non-strike-out
            ja00=j
            bflag=.false.
          endif
        endif
      enddo
      jb0=jb
!
 1100 DO J=ja00,jb0
        IF(QBMS(J).EQ.MS)THEN                    !NOW QBML(J).EQ.ML HERE
          QBMS(J)=QBMS(J)-INT(NF21,QP)                       !SO .LT.-NF
          GO TO 1200
        ENDIF
      ENDDO
!                       NOTE LOOPS FROM MAX TO MIN - REVERSE OF HISTORIC
 1200 MS=MS-2
      IF(MS.GE.-QS0)GO TO 1100
!
      ML=ML-2
      IF(ML.GE.-QL0)GO TO 1000
!
      GO TO 400
!
! TERMS COMPLETE
!
 1300 NTGB=N2                                      !=NTG(KF) IF WHOLE CF
!
      IF(N2.GT.IAXCT)GO TO 2800       !TERM ARRAYS TOO SMALL FOR PROBLEM
!
! CROSS OUT UNWANTED SLATER STATES J, SET UP VCC ORGANIZATION
! (AND FOR M=1, 2ND ENTRY THROUGH 30  NB=0, CANCEL FURTHER STATES)
!
      NB=-1
      NU=NF-(NF/2)*2
      NI=QCS+NU
      IF(BMSEQS)THEN                                    !SIZE CHECK ONLY
        DD=DONE
        IAXDC=-ABS(IAXDC)                   !.LT.0 TO SKIP DC SIZE CHECK
      ELSE
        DD=-DZERO
!        IAXDC=MAXDC
      ENDIF
!
! RE-ENTRY POINT
!
 1400 L=JA-1
      IF(N2.LT.N1)GO TO 1700
!
      DO J=JA,JB
!
        ML=QBML(J)
        IF(ABS(ML).GT.QCL)GO TO 1600
!
        I=L+1
        IF(NB.EQ.0)THEN
          MTGD=MTGD+N1-N2-1                 !can only decrease
          MS=QBMS(J)
          IF(ML+MS.NE.NU)GO TO 1600
          IF(MTGD.LE.IAXDC)THEN             !case iaxdc.lt.0
            DO K=N1,N2
              JD=JTGD(K)
              DC(JD+I)=DC(JD+J)
            ENDDO
          ENDIF
          GO TO 1500
        ENDIF
!
        MS=QBMS(J)+NF+NF+1
        IF(ABS(MS).GT.QCS)GO TO 1600
!
        IF(BMGE3)THEN
          IF(MS.NE.QCS)GO TO 1600
          IF(ML.GT.QCL)GO TO 1600
          IF(ML.LT.QCL-KG)GO TO 1600
          GO TO 1500
        ENDIF
!
! MOD=0 (NOW NEED ALL MS,ML FOR SUB-SHELL RE-COUPLING)
        IF(MODD.EQ.0)GO TO 1500
! MOD<0
        IF(MODD.LT.0.AND.ML+MS.LT.0)GO TO 1600
! MOD>0
        IF(MODD.GT.0)THEN
          IF(MODD.EQ.1)THEN
            IF(ML.GT.NI)GO TO 1600
            IF(ML+MS.LT.0)GO TO 1600
          ELSE
            IF(ML.NE.0)GO TO 1600
            IF(MS.NE.NU)GO TO 1600
            GO TO 1500
          ENDIF
        ENDIF
!
        DO K=N1,N2
!WE MOD=0
!WE          IF(MODD.EQ.0)THEN
!WE            IF(KCUT.EQ.0)GO TO 36!APPLY TO CORR ONLY? ->IF(.NOT.BCUT)
!WE            IF(MS.GT.QTGS(K)+2)GO TO 19
!WE            IF(MS.GE.-1)GO TO 36
!OLFS   IF(MS+ML.GE.-1)GO TO 36
!WE            GO TO 33
!WE          ENDIF
!
          IF(ABS(MS).GT.QTGS(K))GO TO 1450
          IF(ABS(ML).GT.QTGL(K))GO TO 1450
!     IF(MODD.GE.-1)GO TO 36
          IF(MODD.GE.-1)THEN                       ! OR ABS(MODD)=1 NOW
            IF(NAST.NE.0.AND.MODD.EQ.-1)THEN
              MDF=QTGS(K)-QTGL(K)
              IF(MS+ML.LT.ABS(MDF))GO TO 1450
            ENDIF
            GO TO 1500
          ENDIF
          IF(MS*ML.LT.0)GO TO 1600
          IF(NAST.NE.0.AND.MODD.EQ.-2)THEN
!            IF(MS.LT.QDS)GO TO 33
!            IF(ML.LT.QDL)GO TO 33
            IF(MS.LT.QTGS(K))GO TO 1450
            IF(ML.LT.QTGL(K))GO TO 1450
          ENDIF
          GO TO 1500
!
 1450   ENDDO
!
        GO TO 1600
!
 1500   L=I
        QBML(L)=INT(ML,QP)
        QBMS(L)=INT(MS,QP)
        DO I=1,NF
          QLML(I,L)=QLML(I,J)
          QLMS(I,L)=QLMS(I,J)
        ENDDO
!
 1600 ENDDO
!
      LJA1=L-JA+1
!
      MTGDMX=LJA1*(N2-N1+1)+MTGD
!
      IF(IAXDC.GT.0.AND.MTGDMX.GT.0)THEN    !mtgdmx.le.0 -> I*4 overflow
!
        IF(MTGDMX.GT.IAXDC)THEN
!
          IXXX=7*(IAXDC/5+1)
          IXXX=MAX(IXXX,MTGDMX)
!
          WRITE(MW6,*)'*** VCU: increasing MAXDC from ',IAXDC,' to: ',  &
     &                IXXX
          WRITE(MW0,*)'*** VCU: increasing MAXDC from ',IAXDC,' to: ',  &
     &                IXXX
!                               !MTGD???
          CALL RE_ALLOC(DC,IZERO,IAXDC,IXXX,IERR)
!
          IF(IERR.NE.0)THEN
            WRITE(MW0,*)'VCU: RE-ALLOCATION FAILS FOR DC'
            NF=0
            GO TO 2800
          ENDIF
!
          IF(DC(0).GT.DZERO)THEN
!
            CALL RE_ALLOC(IDC,IONE,MTGD0,IXXX,IERR) !ONLY MTGD0 SO FAR
!
            IF(IERR.NE.0)THEN
              WRITE(MW0,*)'VCU: RE-ALLOCATION FAILS FOR IDC'
              NF=0
              GO TO 2800
            ENDIF
!
          ENDIF
!
          IAXDC=IXXX
!
        ENDIF
!
        DO K=N1,N2
          MTGD=LJA1+MTGD
          JD=MTGD-L
          DO J=JA,L
            IF(NB.EQ.0)THEN
              I=JTGD(K)
              DD=DC(J+I)
            ENDIF
            DC(J+JD)=DD
          ENDDO
          JTGD(K)=JD
        ENDDO
!
      ELSE                         !FOR DIMENSION CHECK
!
        MTGD=MTGDMX
!
        IF(DC(0).NE.DZERO)THEN
          DO K=N1,N2
            JTGD(K)=JD
          ENDDO
          DO J=MTGD0+1,MTGD
            DC(J)=DZERO
          ENDDO
        ENDIF
!
      ENDIF
!
 1700 JB=L
!
! NORMAL RETURN (NB=0) FOR MODD.EQ.1 (AFTER 2ND ENTRY, THROUGH 30);
!
      IF(NB.EQ.0)GO TO 2800
!
! INCASES BMGE3=T OR KF.GT.KCUT: RETURN (NB=0) IF NO TERMS SL IN KF.
!
      IF(N2.LT.N1)GO TO 2700
!
! AS PROBLEM TOO LARGE FOR VCC ARRAY DC(MAXDC).
!
      IF(MTGD.le.0)THEN             !.le.0 -> I*4 overflow
        WRITE(MW0,*)'*** SR.VCU: TOO MANY VCCs FOR I*4'
        WRITE(MW6,*)'*** SR.VCU: TOO MANY VCCs FOR I*4',                &
     &              ', SET DEFAULT INTEGER SP=8 IN MODULE PRECSN'
        IF(KF.LE.KUTDSK)WRITE(MW6,*)'*** OR USE KUTDSK ***'
        NB=-1
        GO TO 2800
      ENDIF
      IF(IAXDC.LT.0)THEN
        IAXDC=-IAXDC
      ELSEIF(MTGD.GT.IAXDC)THEN                     !SHOULD NOT BE SO...
        WRITE(MW0,*)'*** SR.VCU: RE-ALLOCATION ERROR...'
        WRITE(MW6,*)'*** SR.VCU: RE-ALLOCATION ERROR...'
        NF=-1
        GO TO 2800
      ENDIF
!
!-----------------------------------------------------------------
!  VCE BY SIMULTANEOUSLY DIAGONALIZING  L**2 AND S**2  (IN SR VCE)
!-----------------------------------------------------------------
!
      IF(QCL0.LT.QCL)QCL0=QCL                              !GLOBAL MAX L
      IF(QCS0.LT.QCS)QCS0=QCS                              !GLOBAL MAX S
!
!     NO VCC'S WILL BE COMPUTED IN 'DIMENSION CHECK ONLY'
!
      IF(BMSEQS)GO TO 2700                     !SO RETURN
!
      ML=QCL
      IF(MODD.GT.1)QCL=0
!
      IAXDF1=0
!
 1800 MS=QCS
!
 1900 IAXDF=0
!
 2000 NB=0
!
      DO J=JA,JB
        IF(QBML(J).EQ.ML.AND.QBMS(J).EQ.MS)THEN
          NB=NB+1
          IF(NB.LE.IAXDF)NO(NB)=J
        ENDIF
      ENDDO
!
      IF(NB.EQ.0)GO TO 2500
!
      IF(IAXDF.EQ.0)THEN
        IAXDF=NB
        ALLOCATE(DL(IAXDF),DS(IAXDF),NO(IAXDF),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'VCU: ALLOCATION FAILS FOR DL,DS,NO'
          NF=0
          GO TO 2800
        ENDIF
        GO TO 2000
      ENDIF
!
      ALLOCATE(DU(IAXDF,IAXDF),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'VCU: ALLOCATION FAILS FOR DU'
        NF=0
        GO TO 2800                                               !RETURN
      ENDIF
!
      IF(IAXDF.GT.MAXDF)THEN
        IF(MAXDF.GT.0)WRITE(MW6,*)'WORKING ARRAY ALLOCATION IAXDF=',    &
     &                            IAXDF
      ENDIF
!
      IAXDF1=MAX(IAXDF1,IAXDF)                                    !LOCAL
!
      CALL DIMUSE('MAXDF',IAXDF)                                 !GLOBAL
!
! THIS CALL CAN BE REPLACED BY THE WHOLE BODY OF SR VCE.
!
      NB0=NB
!
!     call nrb_time(timei)
!
      CALL VCE(QLML,QLMS,QBML,QBMS,DU,DL,DS,NO,MAXEL)
!
      IF(NF.LE.0)GO TO 2800
!
!     call nrb_time(timef)
!     write(71,*)'vce',nb,ml,ms,timef-timei
!     timev=timev+timef-timei
!
      IF(NB.EQ.0)THEN                                  !VCE DIAG FAILURE
        NB=NB0
        GO TO 2800
      ENDIF
!
      DO L=1,NB
!
        DO J=N1,N2
          NRJ=JTGD(J)
          QL0=QTGL(J)
          QS0=QTGS(J)
!
! IDENTIFY L'TH TERM, RESULTING FROM DIAGONALIZING S*(S+1) AND
! 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*STOL*D0PT1)GO TO 2050
!
! AND CROSS OUT THE EXHAUSTED TERM
!
          QTGS(J)=QS0+QONE
!
! SET UP VCC (EIGENV OF DIAGON.) IN APPROPRIATE LOCATION OF DC:
!
          DO I=1,NB
            JD=NO(I)+NRJ
            DC(JD)=DU(I,L)
          ENDDO
!
! ESTABLISH PROPER PHASES WITH PREVIOUS (MS,ML); FOR DEGENERATE SL,
! DO SO AFTER THE LAST TERM, QTGD=1, HAS BEEN FOUND.(NEW USE FOR BMSEQS)
!
          BMSEQS=QTGD(J).LT.0
          QTGD(J)=ABS(QTGD(J))
          IF(BMSEQS.OR.QTGD(J).GT.1)GO TO 2300
!
! NOTE HOW THE (IF-)LOOPS FOR MS AND ML ARE NESTED: STEP DOWN S
! WITHIN EACH ML=CONST COMPLEX, AND APPLY L- ONLY IF MS=S
!
          BMSEQS=MS.EQ.QS0
          N4=J
          N3=N4
          GO TO 2100
 2050   ENDDO
!
        GO TO 2300
!
! ONLY IN CASE BMGE3=T OR KF.GT.KCUT; SEE COMPLETENESS CHECK IN DO84
!
 2100   IF(N3.GT.N1)THEN              !FOR STUPID COMPILERS
          IF(QTGD(N3-1).GT.1)THEN     !BREAK INTO TWO
            N3=N3-1
            GO TO 2100
          ENDIF
        ENDIF
!
        IF(BMSEQS)THEN
          DI=(QL0+ML+2)*(QL0-ML)
        ELSE
          DI=(QS0+MS+2)*(QS0-MS)
        ENDIF
!
        DO I=1,NB
          JD=NO(I)
          DD=DZERO
          DO J=N3,N4
            NI=JTGD(J)+JD
            DD=DC(NI)**2+DD
            DC(NI)=DZERO
          ENDDO
!
          IF(DD.LT.TTYNY)GO TO 2150
!
          DO J=JA,JB
!
            K=0
            IF(BMSEQS)K=2
            IF(QBML(J)-K.NE.ML)GO TO 2120
            IF(QBMS(J)+K-2.NE.MS)GO TO 2120
!
            DD=DZERO
            DO K=N3,N4
              NI=JTGD(K)+J
              DD=DC(NI)**2+DD
            ENDDO
!
            IF(DD.LT.TTYNY)GO TO 2120
!
            KG=0
            KP=0
!
            DO NI=1,NF
              KP=KP+NI
              DO K=1,NF
                IF(QLML(K,J).EQ.QLML(NI,JD))THEN
!                IF(QLMS(K,J).NE.QLMS(NI,JD) .OR. QCGS(K).NE.QCGS(NI))
                  IF(QCGS(K)*QLMS(K,J).EQ.QCGS(NI)*QLMS(NI,JD))THEN
                    KP=KP-K
                    GO TO 2110
                  ENDIF
                ENDIF
              ENDDO
              IF(KG.NE.0)GO TO 2120
              KG=NI
 2110       ENDDO
!
! SLATER STATES J AND JD DIFFER IN ONE INDIVIDUAL SET, IN POSITION
! KP AND KG; ENSURE THAT THE PAIR DOES NOT DIFFER IN NL:
!
            NI=QCGS(KP)
            IF(QCGS(KG).EQ.NI)THEN
              IF(BMSEQS)THEN
                DD=(QL(NI)+QLML(KP,J))*(QL(NI)-QLML(KG,JD))
              ELSE
                DD=(1+QLMS(KP,J))*2
              ENDIF
              ISGN=1-2*mod(abs(KG+KP),ITWO)           !(-1)**(KG+KP)
              DD=ISGN*SQRT(DD/DI)
              DO K=N3,N4
                NI=JTGD(K)+JD
                DC(NI)=DD*DC(NI+J-JD)+DC(NI)
              ENDDO
            ENDIF
 2120     ENDDO
!
! SIGN ONLY NEEDS TO BE ESTABLISHED IF L'TH TERM SL NOT DEGENERATE
!
          IF(N4.EQ.N3)THEN
            IF(ABS(DC(NRJ+JD)).GT.TYNY)GO TO 2200
          ENDIF
!
 2150   ENDDO
!
        GO TO 2300
 2200   DD=DC(NRJ+JD)/DU(I,L)
!
! VCC MAYBE TOO INACCURATE
!
        IF(ABS(ABS(DD)-DONE).GT.STOL)THEN
          WRITE(MW6,*)"SR.VCU: ARE VCC'S ACCURATE ENOUGH? "
          WRITE(MW6,*)DC(NRJ+JD),DU(I,L),ABS(DD)-DONE
          IF(ABS(ABS(DD)-DONE).GT.100*STOL)THEN
            IF(IDIAG.EQ.0)THEN
              WRITE(MW6,10020)KF
              IDIAG=-1
              GO TO 100
            ENDIF
            GO TO 2800
          ENDIF
        ENDIF
!
        IF(DD.LT.DZERO)THEN
          DO I=1,NB
            JD=NO(I)+NRJ
            DC(JD)=-DU(I,L)
          ENDDO
        ENDIF
!
 2300 ENDDO
!
!
! RESTORE 2*S-ARRAY, WHICH HAS BEEN USED FOR MARKING:
!
      DO J=N1,N2
        IF((QTGS(J)/2)*2.EQ.QTGS(J)-NU)THEN
          IF(QTGL(J).LT.ABS(ML))GO TO 2400
          IF(QTGS(J).LT.ABS(MS))GO TO 2400
!
          IF(IDIAG.EQ.0)THEN
            WRITE(MW6,10020)KF
!            IDIAG=-1
!            GO TO 52
          ENDIF
          IF(IDIAG.NE.0)WRITE(MW6,10010)
          WRITE(MW6,10030)J,MS,ML,NB,(DS(I),DL(I),I=1,NB)
          GO TO 2800
        ELSE
          QTGS(J)=QTGS(J)-QONE
        ENDIF
 2400 ENDDO
!
      DEALLOCATE(DU,DL,DS,NO,STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'VCU: DE-ALLOCATION FAILS FOR DU,DL,DS,NO'
        NF=0
      ENDIF
!
 2500 IF(BMGE3)GO TO 2600                   !NORMAL RETURN FOR MODD.GE.3
!
      MS=MS-2
      IF(MS+QCS.GE.0)GO TO 1900
!
 2600 ML=ML-2
      IF(ML+QCL.GE.0)GO TO 1800
!
 2700 NB=0
!
! CANCEL AUXILIARY SLATER STATES AND COEFFICIENTS BEFORE RETURNING;
!
      IF(MODD.EQ.1)GO TO 1400
!
!-----------------------------------------------------------------------
!
 2800 CONTINUE
!
      IDIAG=IDIAG0
!
      IAXDF=IAXDF1                                  !PASS BACK TO ALGEB1
!
!-----------------------------------------------------------------------
!
      IF(ALLOCATED(DU))THEN
        DEALLOCATE(DU,DL,DS,NO,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(MW0,*)'VCU: DE-ALLOCATION FAILS FOR DU,DL,DS,NO'
          NF=0
        ENDIF
      ENDIF
!
!
!     write(71,*)'vce total',timev
!     call flush(71)
!     timev=0.d0
!
!-----------------------------------------------------------------------
!
      RETURN                  !NORMAL RETURN FOR MODD.NE.1 (SINGLE PASS)
!
!-----------------------------------------------------------------------
!
!  KF.GT.KCUT(.GT.0):  ONLY THOSE TERMS RETAINED THAT SERVE AS
!           CORRELATION TERMS TO TERMS OF PREVIOUS CONFIGURATIONS KF.
!
!  MODD.EQ.0:
!      ALL VCC FOR ALL COMPLETE TERMS I OF CONFIG C  STORED IN DC
!WE    PROVIDED KCUT=0 IS SPECIFIED (WHICH DEFAULTS TO KCUT.GE.KF)
!WE    OTHERWISE RESTRICTIONS ON MS APPLY: SEE LOOP DO33.
!WE    COLFS MAY HAVE TO BE OPENED FOR FS-COLLISION PROBLEMS.
!NRB***OLD RESTRICTIONS SUPPRESSED NOW THAT WE RE-COUPLE SUB-SHELLS
!
!  MODD.EQ.1:
!      ONLY VCC FOR SLATER-STATES WITH /ML=MS/=MIN OF ALL TERMS I OF C
!
!  MODD.EQ.2:
!      ONLY VCC FOR SLATER-STATES WITH ML=0,MS=MIN OF ALL TERMS I OF C
!
!  MODD.EQ.-1,-2
!      EQUIV TO +1,+2 FOR ML,MS.LT.0, BUT ALL -,-.GT.0 RETAINED
!
!  MODD.GE.3:
!      ONLY SLATER-STATES AND VCC WITH ML=L,MS=S OF TERM 2S=QCS0,2L=QCL0
!
!  MODD.LE.-3:
!      ANY ML=L-1 ALSO INCLUDED (KCUT IGNORED FOR ABS(MODD).GE.3)
!
!  NOTE: AT THE BEGINNING FOR ANY MODD STORAGE FOR ALL SLATER-STATES
!       REQUIRED, AND FOR MODD=1 SOME VCC BUFFER IN DC (SEE LOOP 33).
!
!  CODE OF UNSUCCESSFUL RETURNS (NB.NE.0):
!  NB.EQ.-5: TOO MANY CONFIGURATIONS  - NOT USED
!        -4: TOO MANY ELECTRONS; AFFECTS QLMS,QLML
!        -3: TOO MANY SLATER STATES; "  " AND QBMS,QBML
!        -2: TOO MANY TERMS; AFFECTS QTGS,QTGL,QTGD,JTGD
!        -1: TOO MANY VCC; AFFECTS DC(MAXDC)
!    .GT. MAXDF: BUFFER ARRAYS DA,DU,DV,DL,DS,NO TOO SMALL
!    .GT. 0: NUMERICAL TROUBLE-ACCURACY.
!
!-----------------------------------------------------------------------
!
10010 FORMAT(//' VCE FAILS -- EIGENVALUES INACCURATE-CHECK FOR ENOUGH', &
     &       ' SWEEPS IN JACORD')
! 1001 FORMAT(//' HOUSEHOLDER-QL METHOD FAILS FOR SIMULTANEOUS',
!     &' DIAGONALIZATION OF S**2 AND L**2 MATRICES'/' TRY THE (SLOWER)'
!     &,' JACOBI METHOD INSTEAD: ***SET IDIAG=1*** IN NAMELIST SALGEB')
10020 FORMAT(//' NOTE: HOUSEHOLDER-QL METHOD FAILS FOR SIMULTANEOUS',   &
     &       ' DIAGONALIZATION OF S**2 AND L**2 MATRICES'/' TRYING THE',&
     &       ' (SLOWER) JACOBI METHOD INSTEAD FOR THIS CF=',I3,' ONLY.')
10030 FORMAT(/4I5,10F10.5/(20X,10F10.5))
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE VCU
!
!                     *******************
!
      SUBROUTINE VERTS(V,LV,N,W,IERR)
!
!-----------------------------------------------------------------------
!
!        INVERT A SYMMETRIC MATRIX WITHOUT PIVOTING
!
! NRB: MODIFIED TO ALLOW INPUT/OUTPUT OF UNPACKED MATRIX V
!
!     INPUT:
!
!         V     --ARRAY CONTAINING MATRIX
!                 (ONLY THE LOWER HALF NEED BE DEFINED)
!
!         LV    --LEADING (ROW) DIMENSION OF ARRAY V
!                 SET .LE. 0 IF V ALREADY PACKED
!
!         N     --MATRIX DIMENSION
!
!         W     --WORK ARRAY WITH LENGTH AT LEAST N
!
!     OUTPUT:
!
!         V     --INVERSE (IN LOWER HALF ONLY)
!
!  IT IS CALLED BY:
!    SR.PQ
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION V(*),W(*)
!
!-----------------------------------------------------------------------
!
      IERR=0
!
      IF(LV.LE.0)GO TO 200     !ALREADY PACKED
!     ----------------
!NRB |*** PACK V ***|
!     ----------------
      NH=LV-N
      I=0
      M=0
      L=N
      NG=(N*(N+1))/2
  100 IF(L.EQ.NG)GO TO 200
      K=L+1
      M=M+1
      L=L+N-M
      I=I+NH+M
      DO J=K,L
        V(J)=V(I+J)
      ENDDO
      GO TO 100
!
  200 NH=N
      K=1
  300 IF(NH.EQ.1)GO TO 500
!     --------------------------
!     |*** SAVE PIVOT ENTRY ***|
!     --------------------------
      S=V(K)
      K=K+NH
      NG=K
      NH=NH-1
      M=NH
      IF(S.EQ.DZERO)GO TO 600
      J=0
  400 J=J-M
      M=M-1
      L=NG+M
      T=V(NG+J)/S
!     ---------------------------
!     |*** ELIMINATE BY ROWS ***|
!     ---------------------------
      DO I=NG,L
        V(I)=V(I)-T*V(I+J)
      ENDDO
      NG=L+1
      IF(M.GT.0)GO TO 400
      GO TO 300
  500 IF(V(K).NE.DZERO)GO TO 700
      IERR=2
      RETURN
  600 IERR=1
      RETURN
!     ------------------------------------------
!     |*** SOLVE FOR ROWS OF INVERSE MATRIX ***|
!     ------------------------------------------
  700 NG=N+N
      DO M=1,N
        L=((NG-M)*(M-1))/2
        NH=L
        K=M
        DO I=M,N
          W(I)=DZERO
        ENDDO
        W(M)=DONE
  750   IF(K.EQ.N)GO TO 800
        T=W(K)/V(K+L)
        J=L
        L=L+N-K
        K=K+1
        IF(T.EQ.DZERO)GO TO 750
        DO I=K,N
          W(I)=W(I)-T*V(I+J)
        ENDDO
        GO TO 750
!     -----------------------------------
!     |*** BACK SUBSTITUTION BY ROWS ***|
!     -----------------------------------
  800   W(N)=W(N)/V(K+L)
  850   IF(K.EQ.M)GO TO 900
        J=K
        K=K-1
        L=L+K-N
        T=W(K)
        DO I=J,N
          T=T-W(I)*V(I+L)
        ENDDO
        W(K)=T/V(K+L)
        GO TO 850
  900   DO I=M,N
          V(I+NH)=W(I)
        ENDDO
      ENDDO
!
      IF(LV.LE.0)RETURN                !LEAVE PACKED
!
!     ------------------
!NRB  |*** UNPACK V ***|
!     ------------------
      NH=LV-N
      I=(N-1)*NH+(N*(N-1))/2
      M=N-1
      L=(N*(N+1))/2
      K=L
!
 1000 IF(I.EQ.0)RETURN
!
      DO J=L,K,-1
        V(I+J)=V(J)
      ENDDO
      I=I-NH-M
      L=K-1
      M=M-1
      K=K-N+M
      GO TO 1000
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE VERTS
!
!                             *******************
!
      SUBROUTINE VFREE(YFREE,EFREE,NION,TPLASMA,Z,RION,MAXP,MKK)
!
!-----------------------------------------------------------------------
!
!  SR.VFREE EVALUATES A SELF-CONSISTENT FREE ELECTRON PLASMA POTENTIAL
!  FOR A FIXED BOUND STATE CONFIGURATION.
!
!  IT IS CALLED BY:
!    SR.VMPOT
!
!  IT CALLS:
!    SR.VXC
!    SR.WXC
!
!  IT CONTAINS:
!    FN.ERF
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
      USE COMMON_NRBSTO, ONLY: ALF,TEL,MSHELL,MCFSTO,MC,MCFMX,MEXPOT    &
     &                        ,NOCC,NLSTOE,BFIX,BSTO,MXSHLL
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (EPS=D1M2)                           !CONVERGENCE FACTOR
      PARAMETER (PAR=D1P1)      !ASYMPTOTIC PARAMETER FOR ERROR FUNCTION
!
      ALLOCATABLE :: DENB(:),DENF(:),DENF1(:),YXC(:),EDP(:)
      ALLOCATABLE :: MEL(:)
!
      DIMENSION YFREE(*)                        !=VSC(MAXRS) IN /NRBDEN/
!
!-----------------------------------------------------------------------
!
! ERROR FUNCTION
!
!      ERF(XX)=DONE-(A1/(DONE+PP*XX)+A2/(DONE+PP*XX)**2+A3/(DONE+PP*XX)
!     &        **3)*EXP(-XX**2)
!
!-----------------------------------------------------------------------
!
      PI=ACOS(-DONE)
!
! NO. OF SELF-CONSISTENT ITERATIONS ALLOWED
!
      NITT=20
!
! USER INPUT OCCUPATION NOS
!
      NOCCM=MOD(NOCC,I1000)
      IF(NOCCM.NE.0)THEN
        NWF=ABS(NOCCM)
        GO TO 200
      ENDIF
!
! DETERMINE OCCUPATION NUMBERS
!
      ALLOCATE(MEL(MXORB))
!
      NWF0=MXORB
      DO J=1,NWF0
        TEL(J)=DZERO
        MEL(J)=0
        IF(DEY(J).NE.DZERO)NWF=J
      ENDDO
!
      MK=ABS(MKK)
!
      IF(MORT.LT.0.AND.BSTO.AND.MK.NE.0)THEN
! CHECK FOR COMMON CORE
        IF(IRLX.LT.0)THEN              !NO COMMON CORE, CASE IEQ(0).GT.0
          MA0=0
          MB0=0
        ELSE                                                !COMMON CORE
          MA0=MA
          MB0=MB
        ENDIF
        BCORE=IEQ(MK).GE.MA0.AND.IEQ(MK).LE.MB0            !IEQ UNNECESS
! DETERMINE OCCUPTN NUMBERS FOR CONFIGURATION SPECIFIED FOR THIS ORBITAL
        KAV=0
        IF(MCFMX.GT.0)THEN
          IF(MK.GT.MCFMX)THEN
            KS=MCFSTO(MCFMX)
          ELSE
            KS=MCFSTO(MK)
          ENDIF
          KF=KS
        ELSE
! USE CONFIGURATION AVERAGE
          KS=1
          KF=KMAX
          IF(IEQ(0).eq.0)THEN
            IF(KCUT.GT.0)KF=MIN(KCUT,KMAX)
            IF(MCFMX.GT.I1000)KF=MIN(MOD(MCFMX,I1000),KMAX) !SO NOT KCUT
            IF(mcfmx.lt.0)kf=min(-mcfmx,kmax)
          ENDIF
        ENDIF
!
        DO K=KS,KF
          IF(.NOT.BCORE.and.mcfmx.ge.0)THEN
!
! AVERAGE OVER ONLY THOSE CONFIGS THAT CONTAIN MK.
            DO I=1,NF
              IF(QCG(I,K).EQ.MK)GO TO 20
            ENDDO
            IF(MCFMX.LE.0)GO TO 50
            IF(IEQ(0).GT.0.AND.IEQ(MK).LE.MB)GO TO 20
            IF(IEQ(0).LT.0)GO TO 50
            WRITE(MW6,10020)MK,K
            WRITE(MW0,*)                                                &
     &                 '*****ERROR IN SR.VFREE, ORBITAL NOT FOUND IN CF'
            GO TO 600
          ENDIF
! USE MCFMX.LT.0 TO AVERAGE OVER ALL CONFIGS
!
   20     KAV=KAV+1
!
! EQUAL WEIGHTING, COULD TRY ALTERNATIVE......
          DO L=1,NF
            I=QCG(L,K)
            IF(QN(I).GT.0.AND.QN(I).LT.90)MEL(I)=MEL(I)+1
          ENDDO
   50   ENDDO
!
        IF(MB.GT.0)THEN
          DO I=MA,MB
            MEL(I)=MEL(I)+2*(QL(I)+1)*KAV
          ENDDO
        ENDIF
        T1=KAV
!       WRITE(MW6,*) MK
        DO J=1,NWF
          T2=MEL(J)
          TEL(J)=T2/T1
!         WRITE(MW6,*)J,TEL(J)
        ENDDO
!
      ELSE
!
! CHOOSE FIRST SUITABLE BOUND (MKK.GE.0) OR CONTINUUM (MKK.LT.0) CONFIG.
!
        IF(MA*MB.GT.0)THEN
          DO I=MA,MB
            TEL(I)=2*(QL(I)+1)
          ENDDO
        ENDIF
!
        DO M=1,KMAX
          I=QCG(NF,M)
          IF(MKK.GE.0.AND.QN(I).GE.0.AND.QN(I).LT.90)GO TO 100
          IF(MKK.LT.0.AND.(QN(I).LT.0.OR.QN(I).GE.90))GO TO 100
        ENDDO
!
  100   DO N=1,NF
          I=QCG(N,M)
          IF(QN(I).GT.0.AND.QN(I).LT.90)TEL(I)=TEL(I)+DONE
        ENDDO
!
      ENDIF
!
! RE-ENTRY POINT FOR USER SUPPLIED OCCUPATION NOS
!
  200 CONTINUE
!
!     RION=(0.2387*(Z-N)/DPLASMA)**0.3333
!
      MAXR=NION                      !LIMITED BY YFREE(MAXRS)
!
      DO I=1,MAXR
        IF(DX(I).GT.RION)GO TO 300
      ENDDO
      I=MAXR
!
      IF(RION.GT.D1PT1*DX(MAXR))THEN             !wiggle room
        WRITE(MW6,10010)RION,DX(MAXR)
        GO TO 600
      ENDIF
!
  300 NION=I
      IF(MAXP.GT.0)THEN
        NO=MIN(NION,MAXP)
      ELSE
        NO=NION
      ENDIF
!
! INITIALIZE ARRAYS
!
      ALLOCATE(DENB(NION),DENF(NION),DENF1(NION),YXC(NION),EDP(NION))
!
      DO I=1,NION
        DENB(I)=DZERO
        DENF(I)=DZERO
        DENF1(I)=DZERO
        YFREE(I)=DZERO
        YXC(I)=DZERO
        EDP(I)=DZERO
      ENDDO
!
! CALCULATE BOUND ELECTRON DENSITY
!
      WOCC=DZERO
      DO J=1,NWF
        IF(TEL(J).NE.DZERO)THEN
          WOCC=WOCC+TEL(J)
          C=TEL(J)/(DFOUR*PI)
          DO I=1,NO
            DENB(I)=DENB(I)+C*(DPNL(I,J)/DX(I))**2   !DX(I)**2 NOT DX(I)
          ENDDO
        ENDIF
      ENDDO
!
! CALCULATE UNIFORM FREE ELECTRON DENSITY
!
      DO I=1,NION
        DENF(I)=(Z-WOCC)/((DFOUR/DTHREE)*PI*RION**3)
      ENDDO
!
! BEGIN SELF-CONSISTENT LOOP
!
      DO ITT=1,NITT
!
! CALCULATE TOTAL POTENTIAL AND THEN FREE ELECTRON DENSITY
!
        DO K=1,NION
!
! CALCULATE ELECTROSTATIC POTENTIAL
!
          V1=(DX(1)/DTWO)*((DENF(1)+DENB(1))*DX(1)**2)/DX(K)
          IF(K.GE.2)THEN
            DO J=2,K
              V1=V1+((DX(J)-DX(J-1))/DTWO)                              &
     &           *((DENF(J)+DENB(J))*DX(J)**2+(DENF(J-1)+DENB(J-1))     &
     &           *DX(J-1)**2)/DX(K)
            ENDDO
          ENDIF
          V2=DZERO
          DO J=K+1,NION
            V2=V2+((DX(J)-DX(J-1))/DTWO)                                &
     &         *((DENF(J)+DENB(J))*DX(J)+(DENF(J-1)+DENB(J-1))*DX(J-1))
          ENDDO
!
! CALCULATE EXCHANGE-CORRELATION POTENTIAL
!         WITH SELF-INTERACTION CORRECTION
!
          DENT=DENB(K)+DENF(K)
          CALL VXC(DENT,TPLASMA,UXCT)
!
          DENT=DENB(K)
          CALL VXC(DENT,TPLASMA,UXCB)
!
          VTOT=DFOUR*PI*(V1+V2)+UXCT-UXCB-Z/DX(K)
!
! CALCULATE FREE ELECTRON DENSITY FOR NEW POTENTIAL
!
          WA=-VTOT/TPLASMA
          IF(WA.LE.DZERO)THEN
            DENF1(K)=EXP(WA)
          ELSEIF(WA.GT.DZERO.AND.WA.LE.PAR)THEN
            DENF1(K)=EXP(WA)*(DONE-ERF(SQRT(WA)))+DTWO/SQRT(PI/WA)
          ELSEIF(WA.GT.PAR)THEN
            DENF1(K)=DTWO*SQRT(WA/PI)+DONE/SQRT(PI*WA)
          ENDIF
!
          IF(K.EQ.1)THEN
            ANF=(DX(K)/DTWO)*DFOUR*PI*(DENF1(K)*DX(K)**2)
          ELSE
            ANF=ANF+((DX(K)-DX(K-1))/DTWO)                              &
     &          *DFOUR*PI*(DENF1(K)*DX(K)**2+DENF1(K-1)*DX(K-1)**2)
          ENDIF
!
        ENDDO
!
! NORMALIZE FREE ELECTRON DENSITY
!
        DO K=1,NION
          DENF1(K)=DENF1(K)*(Z-WOCC)/ANF
        ENDDO
!
! SELF-CONSISTENT CHECK
!
        TA=ABS(DENF(1)-DENF1(1))
        T=(DX(1)/DTWO)*DFOUR*PI*TA*DX(1)**2
        QU=INT(T,QP)
        DO K=2,NION
          TA=ABS(DENF(K)-DENF1(K))
          TB=ABS(DENF(K-1)-DENF1(K-1))
          T=((DX(K)-DX(K-1))/DTWO)*DFOUR*PI*(TA*DX(K)**2+TB*DX(K-1)**2)
          QU=QU+INT(T,QP)
        ENDDO
!
        IF(QU.LE.EPS*(Z-WOCC))GO TO 400
!
        DO K=1,NION
          DENF(K)=DENF1(K)
        ENDDO
      ENDDO
!
      WRITE(MW6,*)'CONVERGENCE FAILURE IN VFREE'
      WRITE(MW0,*)'CONVERGENCE FAILURE IN VFREE'
      GO TO 600
!
! END SELF-CONSISTENT LOOP
!
  400 CONTINUE
!
! FINAL CALCULATION FOR FREE ELECTRON POTENTIAL
!
      DO K=1,NION
!
        V1=(DX(1)/DTWO)*(DENF1(1)*DX(1)**2)/DX(K)
        IF(K.GE.2)THEN
          DO J=2,K
            V1=V1+((DX(J)-DX(J-1))/DTWO)                                &
     &         *(DENF1(J)*DX(J)**2+DENF1(J-1)*DX(J-1)**2)/DX(K)
          ENDDO
        ENDIF
        V2=DZERO
        DO J=K+1,NION
          V2=V2+((DX(J)-DX(J-1))/DTWO)                                  &
     &       *(DENF1(J)*DX(J)+DENF1(J-1)*DX(J-1))
        ENDDO
!
        DENT=DENF1(K)
        CALL VXC(DENT,TPLASMA,UXC)
!
        YXC(K)=UXC
        YFREE(K)=DFOUR*PI*(V1+V2)+UXC
!
        DENT=DENB(K)+DENF1(K)
        CALL WXC(DENT,TPLASMA,FXCT)
!
        DENT=DENB(K)
        CALL WXC(DENT,TPLASMA,FXCB)
!
        EDP(K)=DENB(K)*(YFREE(K)-YXC(K))+FXCT-FXCB
!
      ENDDO
!
! SCREENING CORRECTION TO BOUND ELECTRON ENERGY
!
      EFREE=(DX(1)/DTWO)*EDP(1)*DX(1)**2
      DO J=2,NION
        EFREE=EFREE+((DX(J)-DX(J-1))/DTWO)                              &
     &        *(EDP(J)*DX(J)**2+EDP(J-1)*DX(J-1)**2)
      ENDDO
!
      EFREE=DFOUR*PI*EFREE
!
!-----------------------------------------------------------------------
!
  500 CONTINUE
!
      IF(ALLOCATED(DENB))DEALLOCATE(DENB,DENF,DENF1,YXC,EDP)
      IF(ALLOCATED(MEL))DEALLOCATE(MEL)
!
!-----------------------------------------------------------------------
!
      RETURN
!
  600 NF=-1
      GO TO 500
!
!-----------------------------------------------------------------------
!
10010 FORMAT(' ***SR.VFREE: RION=',1PD9.2,' EXCEEDS RADIAL MESH LIMIT', &
     &       ' DX(MAXRS)=',1PD9.2,' - PLASMA POTENTIAL TRUNCATED...')
10020 FORMAT(' *****ERROR IN SR.VMPOT, ORBITAL',I4,' NOT FOUND IN',     &
     &       ' CONFIGURATION',I4)
!
!-----------------------------------------------------------------------
!
      CONTAINS
!
!-----------------------------------------------------------------------
!
      FUNCTION ERF(XX)
!
! ERROR FUNCTION
!
      REAL(WP) XX,ERF
      REAL(WP) A1,A2,A3,PP
!
      PARAMETER (A1=+0.3480242_WP)
      PARAMETER (A2=-0.0958798_WP)
      PARAMETER (A3=+0.7478556_WP)
      PARAMETER (PP=0.47047_WP)
!
      ERF=DONE-(A1/(DONE+PP*XX)+A2/(DONE+PP*XX)**2+A3/(DONE+PP*XX)**3)  &
     &    *EXP(-XX**2)
!
      END FUNCTION ERF
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE VFREE
!
!                             *******************
!
      SUBROUTINE VLAM(LAM,K1,K2,K3,K4,TVLAM)
!
!-----------------------------------------------------------------------
!
!  SR.VLAM EVALUATES THE V-LAMDA INTEGRAL OF ORBIT-ORBIT INTERACTION, IT
!  IS NOT QUITE SAME AS V-LAMDA INTEGRAL OF SPIN-ORBIT, NO PARTIAL DIFF.
!
!  IT IS CALLED BY:
!    SR.ELAM
!    SR.ZLAM
!
!  IT CALLS:
!    SR.WEDDLE
!    SR.YLAMK
!    SR.YLAMKR
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
!
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      use common_nrbtmp, only: rnorm
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      ALLOCATABLE :: D1(:),D2(:)
!
!-----------------------------------------------------------------------
!
      BREL2=ABS(IREL).EQ.2
!
      ALLOCATE(D1(MAXRS),D2(MAXRS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.VLAM: ALLOCATION FAILS FOR D1,D2'
        TVLAM=DZERO
        NF=0                                                !NOT TRACKED
        RETURN
      ENDIF
!
      DO I=1,MAXRS
        D1(I)=DPNL(I,K2)*DPNL(I,K4)
      ENDDO
      M=QL(K2)/2+QL(K4)/2+2
!
      IF(BREL)THEN                       !SMALL R CORRECTION
        IK2=ICOL(K2,K2,IZERO)
        IK4=ICOL(K4,K4,IZERO)
        DE2=DEY(K2)-DUY(IK2)
        DE4=DEY(K4)-DUY(IK4)
        DEL=DE2-DE4                                   ! A.U.
        DZ=NZION
        T=DALF4*DTWO
        IF(BREL2)THEN
          DO I=1,MAXRS
            DD2=DONE+T*(DE2+DZ/DX(I))
            DD4=DONE+T*(DE4+DZ/DX(I))
!            DD2=DONE+T*(DE2+POT(I,1))
!            DD4=DONE+T*(DE4+POT(I,1))
            DSQ=DD2*DD4
            DSQ=SQRT(DSQ)
            D1(I)=D1(I)/DSQ
          ENDDO
        ELSE
          dd=rnorm(k2)*rnorm(k4)
          DO I=1,MAXRS
            DD2=DONE+DALF4*(DQNL(I,K2)/DPNL(I,K2)+DTWO*DZ/DX(I))
            DD4=DONE+DALF4*(DQNL(I,K4)/DPNL(I,K4)+DTWO*DZ/DX(I))
!            dd2=done+t*(de2+dz/dx(i))
!            dd4=done+t*(de4+dz/dx(i))
            DSQ=DD2*DD4
            DSQ=SQRT(DSQ)
            D1(I)=D1(I)*dd/DSQ
          ENDDO
        ENDIF
        CALL YLAMKR(LAM,M,DEL,D1,D2,DD1,DD2,MNH,DHNS,MJH,-ITHREE)
      ELSE
        CALL YLAMK(LAM,M,D1,D2,DD1,DD2,MNH,DHNS,MJH,-ITHREE)
      ENDIF
!
      DO I=1,MAXRS
        D1(I)=D2(I)*DPNL(I,K1)*DPNL(I,K3)
      ENDDO
!
      IF(BREL)THEN                       !SMALL R CORRECTION
        IK1=ICOL(K1,K1,IZERO)
        IK3=ICOL(K3,K3,IZERO)
        DE1=DEY(K1)-DUY(IK1)
        DE3=DEY(K3)-DUY(IK3)
        DEL=DE1-DE3                                   ! A.U.
        IF(BREL2)THEN
          DO I=1,MAXRS
            DD1=DONE+T*(DE1+DZ/DX(I))
            DD3=DONE+T*(DE3+DZ/DX(I))
!            DD1=DONE+T*(DE1+POT(I,1))
!            DD3=DONE+T*(DE3+POT(I,1))
            DSQ=DD1*DD3
            DSQ=SQRT(DSQ)
            D1(I)=D1(I)/DSQ
          ENDDO
        ELSE
          dd=rnorm(k1)*rnorm(k3)
          DO I=1,MAXRS
            DD1=DONE+DALF4*(DQNL(I,K1)/DPNL(I,K1)+DTWO*DZ/DX(I))
            DD3=DONE+DALF4*(DQNL(I,K3)/DPNL(I,K3)+DTWO*DZ/DX(I))
!            dd1=done+t*(de1+dz/dx(i))
!            dd3=done+t*(de3+dz/dx(i))
            DSQ=DD1*DD3
            DSQ=SQRT(DSQ)
            D1(I)=D1(I)*dd/DSQ
          ENDDO
        ENDIF
      ENDIF
!
      CALL WEDDLE(DZERO,D1,TT,MNH,DHNS,MJH,MAXRS)
!
      TVLAM=DALF*TT/DFOUR
!
      DEALLOCATE(D1,D2,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.VLAM: DE-ALLOCATION FAILS FOR D1,D2'
        NF=0                                                !NOT TRACKED
        RETURN
      ENDIF
!
!     WRITE(MW6,100) K1, K2, K3, K4, 2*LAM, VLAM
!100  FORMAT(8X,2(I5,I4),I6,F14.7,' =VLAM')
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE VLAM
!
!                             *******************
!
      SUBROUTINE VLAM0(M0,K1,K2,K3,K4,K,TVLAM0)
!
!-----------------------------------------------------------------------
!
!  SR.VLAM0 EVALUATES THE V-INTEGRALS OF THE SPIN-ORBIT INTERACTION.
!
!  IT IS CALLED BY:
!    SR.SOCC
!
!  IT CALLS:
!    SR.DIFF
!    SR.WEDDLE
!    SR.YLAMK
!    SR.YLAMKR
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
!
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBREL, ONLY: RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0
      USE COMMON_NRBREL, ONLY: DNUK0,DNUK1,DNUK2,DNUK
      use common_nrbtmp, only: rnorm
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      ALLOCATABLE :: DPA(:),DP(:)
!
!-----------------------------------------------------------------------
!
! THE NAMES HERE ARE NOT NECESSARILY SIGNIFICANT THEY ARE COMMON LEGACY.
!
! LOCAL
      ALLOCATE(DPA(MAXRS),DP(MAXRS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.VLAM0: ALLOCATION FAILS FOR DPA,DP'
        TVLAM0=DZERO
        NF=0                                                !NOT TRACKED
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
      BREL2=ABS(IREL).EQ.2
!
      DZ=NZION
      DD=DONE
      INUKP=INUK+1
!
      DO I=1,MAXRS
        DPA(I)=DPNL(I,K3)/DX(I)
      ENDDO
!
      CALL DIFF(DPA,DP,MNH,DHNS,MJH)
!
      DO I=1,MAXRS
        DPA(I)=DPNL(I,K1)*DP(I)*DX(I)
      ENDDO
!
      I=(QL(K1)+QL(K3))/2+1
      IF(QL(K3).EQ.0)I=I+1
!
      IF(BREL)THEN                       !SMALL R CORRECTION
        IK1=ICOL(K1,K1,IZERO)
        IK3=ICOL(K3,K3,IZERO)
        DE1=DEY(K1)-DUY(IK1)
        DE3=DEY(K3)-DUY(IK3)
        DEL=DE1-DE3                                   ! A.U.
        T=DALF4*DTWO
        IF(BREL2)THEN
          DO I=INUKP,MAXRS
            DD1=DONE+T*(DE1+DZ/DX(I))
            DD3=DONE+T*(DE3+DZ/DX(I))
!            DD1=DONE+T*(DE1+POT(I,1))
!            DD3=DONE+T*(DE3+POT(I,1))
            D13=DD1*DD3
            d13=abs(d13)
            DPA(I)=DPA(I)/SQRT(D13)
          ENDDO
        ELSE
          DO I=INUKP,MAXRS
            DD1=DONE+DALF4*(DQNL(I,K1)/DPNL(I,K1)+DTWO*DZ/DX(I))
            DD3=DONE+DALF4*(DQNL(I,K3)/DPNL(I,K3)+DTWO*DZ/DX(I))
!            dd1=done+t*(de1+dz/dx(i))
!            dd3=done+t*(de3+dz/dx(i))
            D13=DD1*DD3
            d13=abs(d13)
            DPA(I)=DPA(I)/SQRT(D13)
          ENDDO
          dd=dd*rnorm(k1)*rnorm(k3)
        ENDIF
        DO I=1,INUK
          DD1=DONE+T*(DE1+DNUK0(I))
          DD3=DONE+T*(DE3+DNUK0(I))
          DPA(I)=DPA(I)/SQRT(DD1*DD3)
        ENDDO
        CALL YLAMKR(K,I,DEL,DPA,DP,DD1,DD2,MNH,DHNS,MJH,M0)
      ELSE
        CALL YLAMK(K,I,DPA,DP,DD1,DD2,MNH,DHNS,MJH,M0)
      ENDIF
!
      DO I=1,MAXRS
        DP(I)=DPNL(I,K2)*DPNL(I,K4)*DP(I)*DX(I)
      ENDDO
!
      IF(BREL)THEN                       !SMALL R CORRECTION
        IK2=ICOL(K2,K2,IZERO)
        IK4=ICOL(K4,K4,IZERO)
        DE2=DEY(K2)-DUY(IK2)
        DE4=DEY(K4)-DUY(IK4)
        DEL=DE2-DE4                                   ! A.U.
        T=DALF4*DTWO
        IF(BREL2)THEN
          DO I=INUKP,MAXRS
            DD2=DONE+T*(DE2+DZ/DX(I))
            DD4=DONE+T*(DE4+DZ/DX(I))
!            DD2=DONE+T*(DE2+POT(I,1))
!            DD4=DONE+T*(DE4+POT(I,1))
            D24=DD2*DD4
            d24=abs(d24)
            DP(I)=DP(I)/SQRT(D24)
          ENDDO
        ELSE
          DO I=INUKP,MAXRS
            DD2=DONE+DALF4*(DQNL(I,K2)/DPNL(I,K2)+DTWO*DZ/DX(I))
            DD4=DONE+DALF4*(DQNL(I,K4)/DPNL(I,K4)+DTWO*DZ/DX(I))
!            dd2=done+t*(de2+dz/dx(i))
!            dd4=done+t*(de4+dz/dx(i))
            D24=DD2*DD4
            d24=abs(d24)
            DP(I)=DP(I)/SQRT(D24)
          ENDDO
          dd=dd*rnorm(k2)*rnorm(k4)
        ENDIF
        DO I=1,INUK
          DD2=DONE+T*(DE2+DNUK0(I))
          DD4=DONE+T*(DE4+DNUK0(I))
          DP(I)=DP(I)/SQRT(DD2*DD4)
        ENDDO
      ENDIF
!
      CALL WEDDLE(DZERO,DP,DKU,MNH,DHNS,MJH,MAXRS)
!
      TVLAM0=DKU*DD*DALF4
!
!-----------------------------------------------------------------------
!
! LOCAL
      DEALLOCATE(DPA,DP,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.VLAM0: DE-ALLOCATION FAILS FOR DPA,DP'
        NF=0
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE VLAM0
!
!                             *******************
!
      SUBROUTINE VMPOT(ZN,L,MAXRS,DX,DZ,MAXPS,MPP,MK,MXORB)
!
!-----------------------------------------------------------------------
!
!  SR.VMPOT EVALUATES A MODEL POTENTIAL
!
!  POLARIZATION: NORCROSS OR BAYLISS FORM
!  OR
!  DENSE PLASMA POTENTAL: DEBYE-HUCKEL, ION-SPHERE OR SELF-CONSISTENT
!                         FREE-ELECTRON.
!
! IT USES THE SR.RADIAL/RADWAV FORM OF /COM1/DPOT, SO SR.RADCON CALL
! MUST BE BEFORE CONVERSION FOR SR/FCF6.
!
!  IT IS CALLED BY:
!    SR.RADCON
!    SR.RADCX0
!    SR.RADIAL
!
!  IT CALLS:
!    SR.STORAD
!    SR.VFREE
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
!
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,XBEE,VSC,XC1,XC2,NPITER
      USE COMMON_NRBPOT, ONLY: DPOT,TOL,MEND
      USE COMMON_NRBPOT, ONLY: ALFD,RCUT,ALAV,RCAV,IPOLFN
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (DCON1=0.23873_WP)                  !=DTHREE/(DFOUR*XPI)
!
      DIMENSION DX(*)
!
      DATA MK0/0/ !MOVE TO VSC MODULE AND INITIALIZE AT EVERY ALLOCATE
!
!-----------------------------------------------------------------------
!
      PI=ACOS(-DONE)
!
      IF(ZNP0.EQ.ZN.AND.MK0*MK.GT.0.AND.MDEN.LE.2)GO TO 400 !RETURN AS
!                                                    NO CHANGE TO VSC
      MK0=MK
!
      DO I=1,MAXRS
        VSC(I)=DZERO
      ENDDO
!
! Add C60 potential !!!
!
!      do i=1,maxrs
!        if(dx(i).gt.5.8.and.dx(i).lt.7.5)vsc(i)=vsc(i)+.604154/2
!      enddo
!      vsc(1)=d1m50                           !flag
!
      IF(L.LT.0)GO TO 400                    !RETURN
!
      ZNP0=ZN
!
      IF(IPOLFN.LE.0)GO TO 100
!
      LP=L+1
      IF(LP.GT.3)LP=3
!old      IF(ALFD(LP)*RCUT(LP).EQ.DZERO)GO TO 6
!
! ONE-BODY POLARIZATION POTENTIAL
!
      ZNP0=-99
      IPOLF1=MOD(IPOLFN,ITEN)
!
      IF(IPOLF1.EQ.1)THEN
! NORCROSS
        DO I=1,MAXRS
          VSC(I)=ALFD(LP)*(DONE-EXP(-(DX(I)/RCUT(LP))**6))/DX(I)**4
        ENDDO
      ELSEIF(IPOLF1.EQ.2)THEN
! BAYLISS
        DO I=1,MAXRS
          VSC(I)=ALFD(LP)*DX(I)*DX(I)/(DX(I)*DX(I)+RCUT(LP)*RCUT(LP))**3
        ENDDO
      ENDIF
!
! EVALUATE PLASMA SCREENING POTENTIAL:
! CAN NEGLECT PLASMA SCREENING POTENTIAL COMPARED TO NUCLEAR
! (TO WITHIN 100*TF%) FOR X.LT.XC1.
! PLASMA SCREENING COMPLETE FOR X.GT.XC2.
!
  100 IF(MDEN.LE.0)GO TO 400                 !RETURN
      IF(DENE.LE.DZERO)GO TO 400
!
      TF=D0PT05
      MDEN10=MOD(MDEN,ITEN)
      IF(MDEN10.NE.1)GO TO 200
!
! DEBYE-HUCKEL
!
      IF(IPOLFN.GT.0)THEN
        WRITE(MW0,*)                                                    &
     &   '*** ATTENTION: POLARIZATION POTENTIALS ARE BEING SCREENED BY '&
     &   ,'DEBYE-HUCKEL POTENTIAL'
        WRITE(MW6,*)                                                    &
     &   '*** ATTENTION: POLARIZATION POTENTIALS ARE BEING SCREENED BY '&
     &   ,'DEBYE-HUCKEL POTENTIAL'
      ENDIF
!
!      write(mw0,*)mk,zn
      XC1=-LOG(DONE-TF)*DEBYE                       !-on +off
      XC2=-LOG(TF)*DEBYE                            !-on +off
!      write(mw0,*)xc1,xc2
!
!      IF(MDEN10.EQ.1)THEN
      IF(NPITER.GE.0)THEN
!          write(77,*)'mk,zn=',mk,zn
!          ifort=70+mk
        DO I=1,MAXRS
          T=DX(I)
!old            TZ=-ZN/T                             !LONG-RANGE ONLY
          T=-T/DEBYE
!old            VSC(I)=(VSC(I)+TZ)*(DONE-EXP(T))     !ADD TO TF/STO POTL
          VSC(I)=(VSC(I)-DPOT(I))*(DONE-EXP(T))      !INC. SHORT-RANGE
!
!            write(77,*)i,dx(i),t,tz*(done-exp(t))*dx(i)
!     &               ,-dpot(i)*(done-exp(t))*dx(i),dpot(i)*dx(i)
!            write(ifort,*)i,dx(i),vsc(i),vsc(i)*dx(i),dpot(i)*dx(i)
        ENDDO
!        ELSE               !use unperturbed radial orbital, pert H only
!          DO I=1,MAXRS
!            VSC(I)=DZERO
!          ENDDO
      ENDIF
      ZNP0=-98                               !CASE DPOT CHANGES
!      ENDIF
      GO TO 400                              !RETURN
!
! ION-SPHERE
!
  200 CONTINUE
!
      IF(IPOLFN.GT.0)THEN
        WRITE(MW0,*)                                                    &
     &    '*** WARNING: POLARIZATION POTENTIALS ARE NOT NEUTRALIZED BY '&
     &    ,'ION-SPHERE POTENTIAL'
        WRITE(MW6,*)                                                    &
     &    '*** WARNING: POLARIZATION POTENTIALS ARE NOT NEUTRALIZED BY '&
     &    ,'ION-SPHERE POTENTIAL'
      ENDIF
!
      IF(NINT(ZN,SP).EQ.IZERO)GO TO 400      !NEUTRAL ATOM
!                                            !DEFINE NEUTRALIZATION
      ZN1=ZN                                 !Z-N+1
!OLD      IF(MK.GE.0)ZN1=ZN1-DONE            !Z-N
!USER      ZN1=DENE/DENI
!      write(mw0,*)mk,zn,zn1
!
      R0=DCON1*ZN1/DENE                      !DCON1/DENI
      R0=R0**(DONE/DTHREE)
      XC1=(DTWO/DTHREE)*TF*R0
      XC2=R0
!      write(mw0,*)xc1,xc2
!
      IF(MDEN.NE.2)GO TO 300
      IF(DENE.LT.D1M20)GO TO 400             !RETURN
!
!      ifort=70 !+mk
!      write(ifort,*)'mk,zn1=',mk,zn1
!
      TZ=ZN1/R0
!
      IF(XBEE.EQ.DZERO)THEN                  !UNIFORM
!
        TZ=TZ/DTWO
!
        DO I=1,MAXRS
          T=DX(I)/R0
          IF(T.LT.DONE)THEN
            VSC(I)=VSC(I)-TZ*(DTHREE-T*T)
!t            VSC(I)=-DX(I)*DPOT(I)*(DTHREE-T*T)/(R0*DTWO)
          ELSE
            VSC(I)=VSC(I)-ZN1/DX(I)
!t            VSC(I)=-DPOT(I)
          ENDIF
!             write(ifort,*)i,dx(i),vsc(i),vsc(i)*dx(i),dpot(i)*dx(i)
        ENDDO
!
      ELSE                                 !NON-UNIFORM
!
        IF(TKAY.NE.DZERO)THEN
          T=TZ*DTWO/TKAY
          A=XBEE*SQRT(T)/PI
          XM1=DTWO-A
!       write(*,*)'xm1=',xm1
        ELSE
          XM1=-DONE
        ENDIF
!
        IF(XM1.LT.DHALF)THEN               !SAY...
          XM1=DTWO                         !RE-SET TO UNIFORM
          WRITE(MW0,*)                                                  &
     &    '*** WARNING: TEMPERATURE TOO LOW FOR NON-UNIFORM ION-SPHERE '&
     &    ,'POTENTIAL,'
          WRITE(MW0,*)'             RE-SETTING TO UNIFORM FOR T(RYD) = '&
     &                ,TKAY
          WRITE(MW6,*)                                                  &
     &    '*** WARNING: TEMPERATURE TOO LOW FOR NON-UNIFORM ION-SPHERE '&
     &    ,'POTENTIAL, RE-SETTING TO UNIFORM FOR T(RYD)=',TKAY
        ENDIF
!
        DO I=1,MAXRS
          T=DX(I)/R0
          IF(T.LT.DONE)THEN
            VSC(I)=VSC(I)-TZ*(DONE+(DONE-T**XM1)/XM1)
!t            VSC(I)=-DX(I)*DPOT(I)*(DONE+(DONE-T**XM1)/XM1)/(R0*DTWO)
          ELSE
            VSC(I)=VSC(I)-ZN1/DX(I)
!t            VSC(I)=-DPOT(I)
          ENDIF
!             write(ifort,*)i,dx(i),vsc(i),vsc(i)*dx(i),dpot(i)*dx(i)
        ENDDO
!
      ENDIF
!
!t      ZNP0=-98                               !CASE DPOT CHANGES
      GO TO 400                              !RETURN
!
! SELF-CONSISTENT FREE ELECTRON POTENTIAL
!
  300 MP0=MP0+1
!     write(mw6,*)mpp,mp0,mk
!
! USE STORAD TO INITIALIZE PNL WITH STO'S AND SO DO NOT RETURN
!
      IF(MPP.EQ.1.AND.MP0.EQ.1.AND.MK.GE.0)                             &
     &   CALL STORAD(ZN,MAXRS,MAXPS,MXORB)
!
!      r0=1.2*r0
      NION=MAXRS
      CALL VFREE(VSC,T,NION,TKAY,DZ,R0,MAXPS,MK)
!
      IF(NF.LE.0)GO TO 400                   !RETURN
!
      DO I=1,NION
        VSC(I)=-VSC(I)
!       write(mw6,*)i,dx(i),vsc(i)
      ENDDO
!
!      ZN1=ZN                                 !Z-N+1
!      IF(MK.GE.0)ZN1=ZN1-DONE                !Z-N
      ZN1=-DX(NION)*VSC(NION)                 !VFREE->Z-N
!      write(mw6,*)nion,r0,zn1,-DX(NION)*VSC(NION)
!
      NT=1
      DO I=NION+1,MAXRS
        VSC(I)=-ZN1/DX(I)
!
! TEST NEUTRALIZATION EFFECT (FOR VFREE ZN1=Z-N, I.E. MAP TO Z-N+1)
!
        IF(MK.GE.0)VSC(I)=VSC(I)-(DX(I)-R0)**NT/DX(I)**(NT+1)
!       VSC(I)=VSC(I)-(DONE-EXP(DONE-DX(I)/R0))/DX(I)
!       write(mw6,*)i,dx(i),vsc(i)
      ENDDO
!       write(mw6,*)maxrs,-dx(maxrs)*vsc(maxrs)
!
      IF(VSC(1).EQ.DZERO)VSC(1)=D1M50        !FLAG
!
!-----------------------------------------------------------------------
!
  400 RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE VMPOT
!
!                             ******************
!
      SUBROUTINE VNUKE(DZ,MSTEP,DHNS0,MAXRS,DX,IFLG1,IFLG2)
!
!-----------------------------------------------------------------------
!
!  SR.VNUKE CALCULATES THE POTENTIAL DUE TO A FINITE NUCLEUS
!  FOR USE BY KAPPA-AVEGAGED RADIAL FUNCTIONS - THUS IT ALSO
!  CALCULATES THE FIRST AND SECOND DERIVATIVES AS WELL:
!  VIZ. DNUK0,DNUK1,DNUK2
!  THE EXPANSION COEFFICIENTS FOR THE FINITE NUCLEUS ARE ALSO SET
!
!  USER HAS SET:
!  INUKE=-1  - POINT NUCLEUS
!       = 0  - UNIFORM CHARGE DISTRIBUTION
!       = 1  - U6 DISTRIBUTION OF BOGDANOVICH & RANCOVA
!              LITHUANIAN J. PHYS. V42, 257 (2002).
!       = 2  - FERMI DISTRIBUTION (***NOT YET IMPLEMENTED***, GT 0 = U6)
!
!  IT IS CALLED BY:
!    SR.RADCX0
!    SR.RADIAL
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_MINIM,  ONLY: MPNCH,KUTCAS,BPRINT
!
      USE COMMON_NRBPOT, ONLY: ZS0,ZS,JZNM
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBREL, ONLY: RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0
      USE COMMON_NRBREL, ONLY: DNUK0,DNUK1,DNUK2,DNUK,IXNUK
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!      PARAMETER (C1=2.2677E-5_WP)          !GRASP
!      PARAMETER (C2=DZERO)                 !GRASP
      PARAMETER (C1=2.04E-5_WP)
      PARAMETER (C2=1.40E-5_WP)
      PARAMETER (C3=1.293_WP)               !U6 TK0
      PARAMETER (C4=0.2_WP)                 !SKIN
!
      DIMENSION DX(*)
!
!-----------------------------------------------------------------------
!
  100 BPRNT0=BPRINT
      IF(BPRINT)BPRNT0=JPRINT.NE.-3
!
      IF(INUKE.LT.0)THEN                          !POINT, QUICK RETURN
        IF(BPRNT0.AND.BREL)WRITE(MW6,10010)INUKE    !SKIP IF NON-REL
        INUK=0
        JZNM=0
        ZS0(0)=DZ
        RNUK=-DONE
        IFLG1=0
        IFLG2=0
        GO TO 300
      ENDIF
!
! INITIALIZE
!
      IF(RNUK.LE.DZERO)THEN
        IF(ATM.LE.DZERO)ATM=D2PT5*DZ
        A=ATM**D1THRD
        RNUK=A*C1+C2
        IF(INUKE.GT.0)THEN
          IF(TK0.LE.DZERO)TK0=C3
          RNUK=RNUK*TK0
        ELSE
          TK0=DONE
        ENDIF
      ENDIF
!
      IF(SKIN.LT.DZERO)SKIN=C4*RNUK
      INUK0=MAX(ITWO,INUK0)
      IF(BPRNT0)THEN
        IF(INUKE.EQ.0)WRITE(MW6,10020)INUKE,RNUK,ATM,SKIN
        IF(INUKE.GT.0)WRITE(MW6,10030)INUKE,RNUK/ABS(TK0),ATM,TK0
      ENDIF
!
      T2=SKIN/2
      IFLG1=999999
      DO I=1,MAXRS
        IF(DX(I)-T2.LT.RNUK)IFLG1=I
        IF(DX(I).GT.RNUK)THEN
          INUK=I
!          write(mw0,*)inuk,dx(inuk-1),rnuk,dx(inuk)
          IF(I.GT.1)THEN
            IF(DX(I)-RNUK.GT.RNUK-DX(I-1))INUK=INUK-1
          ENDIF
          if(inuke.gt.0.and.inuk.lt.2)then
            if(dz.le.30)then
              inuke=-1
              write(mw6,10040)mstep+1
              write(mw0,10050)
              write(mw6,10050)
              go to 100
            else
              mstep=mstep+1   !watch for infinite loop if tfdapo doubles
              dhns0=dhns0/dtwo    !current allocation cannot handle this
              write(mw0,10060)mstep
              write(mw6,10060)mstep
              go to 300
            endif
          endif
          RNUK=DX(INUK)
          GO TO 200
        ENDIF
      ENDDO
!
  200 IF(INUK.LT.INUK0)THEN
        INUK=0
        INUKP=1
        JZNM=0
        ZS0(0)=DZ
        RNUK=-DONE
        IFLG1=999999
      ELSE
!
!        write(mw0,*)'inuk=',inuk
        T0=DZ/RNUK
        INUKP=INUK+1
        IF(INUK.GT.IXNUK)THEN
          DEALLOCATE(DNUK0,DNUK1,DNUK2,DNUK)
          IXNUK=INUK
          ALLOCATE(DNUK0(IXNUK),DNUK1(IXNUK),DNUK2(IXNUK),DNUK(IXNUK))
!          write(mw0,*)'inuk=',inuk
        ENDIF
!
        IF(INUKE.EQ.0)THEN            !UNIFORM
          DO I=1,INUK
            T=DX(I)/RNUK
            DNUK0(I)=DHALF*T0*(DTHREE-T*T)
            DNUK1(I)=-T0*T/RNUK
            DNUK2(I)=-T0/RNUK**2
!            write(mw6,*)i,dx(i),dnuk(i),dnuk1(i),dnuk2(i)
          ENDDO
          T1=DONE
          T3=DTHREE
        ELSE                          !U6
          IFLG1=999999
          T00=(T0*63)/32
          T8=8*RNUK**2
          DO I=1,INUK
            T=DX(I)/RNUK
            TT=T*T
            TTT=TT*TT
            DNUK0(I)=T00-T0*(42-(18-7*TT)*TTT)*TT/32
            DNUK1(I)=-T0*(21-(27-14*TT)*TTT)*DX(I)/T8
            DNUK2(I)=-T0*(21-(135-98*TT)*TTT)/T8
!            write(mw6,*)i,dx(i),dx(i)*dnuk(i),dnuk(i),dnuk1(i),dnuk2(i)
          ENDDO
          T1=21
          T1=T1/8
          T3=DTHREE*T1/DTWO
        ENDIF
!
! SET EXPANSION COEFFS (EVEN NORMALLY ZERO FOR FINITE)
!
        ZS0(0)=DZERO
        ZS0(1)=DHALF*T3*T0
        ZS0(2)=DZERO
        ZS0(3)=-DHALF*T1*T0/RNUK**2
        JZNM=3
!
      ENDIF
!
!      write(mw6,*)'inukp=',inukp
      IFLG2=0
      DO I=INUKP,MAXRS
        IF(DX(I)-T2.LT.RNUK)IFLG2=I
      ENDDO
!
!-----------------------------------------------------------------------
!
  300 RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(/5X,'INUKE=',I2,': POINT NUCLEUS IN USE')
10020 FORMAT(/5X,'INUKE=',I2,': UNIFORM NUCLEAR CHARGE DISTRIBUTION ',  &
     &       'WITH   R=',1PD10.3,'   AND   A= ',0PF5.1,                 &
     &       ' ,  BUT WITH SKIN=',1PD10.3)
10030 FORMAT(/5X,'INUKE=',I2,': U6 NUCLEAR CHARGE DISTRIBUTION WITH',   &
     &       '   R=',1PE10.3,'   AND   A= ',0PF5.1,' ,  AND K0= ',      &
     &       0PF9.5)
!  977 FORMAT(/'*** SR.VNUKE: MESH AT ORIGIN TOO COARSE FOR FINITE ',   &
!    &'NUCLEUS, RECALCULATING WITH INITIAL STEP HALVED, I.E. MSTEP=',I2)
10040 FORMAT(/'*** SR.VNUKE: MESH AT ORIGIN TOO COARSE FOR FINITE ',    &
     &       'NUCLEUS'/14X,'IF NEEDED, RE-RUN WITH INITIAL STEP HALVED,'&
     &       ,' I.E. SET MSTEP=',I2)
10050 FORMAT(14X,'RE-SETTING TO A POINT NUCLEUS (INUKE=-1)...')
10060 FORMAT(/'*** SR.VNUKE: MESH AT ORIGIN TOO COARSE FOR FINITE ',    &
     &       'NUCLEUS, RE-RUN WITH INITIAL STEP HALVED, I.E. SET MSTEP='&
     &       ,I2)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE VNUKE
!
!                             *******************
!
      SUBROUTINE VNRKX(DP1,DP2,DQ1,DQ2,DE1,DE2,DPA,DP,DX,dnorm,DD)
!
!-----------------------------------------------------------------------
!
!  SR.VNRKX CALCULATES THE DEIE V & N "RK" FINE-STRUCTURE INTEGRAL
!
!  IT IS CALLED BY:
!    SR.FSINTX
!
!  IT CALLS:
!    SR.DIFF
!    SR.WEDDLE
!    SR.YLAMK
!    SR.YLAMKR
!
!-----------------------------------------------------------------------
!
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
!
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION DP1(*),DP2(*),DQ1(*),DQ2(*),DPA(*),DP(*),DX(*)
!
!-----------------------------------------------------------------------
!
      BREL2=ABS(IREL).EQ.2
!
      DO I=1,MAXRS
        DPA(I)=DP1(I)*DP(I)*DP2(I)
      ENDDO
!
      IF(BREL)THEN
!        DEL=DE1-DE2                                   ! A.U.
        T=DALF4*DTWO
        DZ=NZION
        IF(BREL2)THEN
          DO I=1,MAXRS
            DD1=DONE+T*(DE1+DZ/DX(I))
            DD2=DONE+T*(DE2+DZ/DX(I))
!            DD1=DONE+T*(DE1+DPOT(I))
!            DD2=DONE+T*(DE2+DPOT(I))
            DSQ=DD1*DD2
            DSQ=SQRT(DSQ)
            DPA(I)=DPA(I)/DSQ
          ENDDO
        ELSE
          DO I=1,MAXRS
            DD1=DONE+DALF4*(DQ1(I)/DP1(I)+DTWO*DZ/DX(I))
            if(dd1.le.dzero)dd1=done+t*(de1+dz/dx(i))
            DD2=DONE+DALF4*(DQ2(I)/DP2(I)+DTWO*DZ/DX(I))
            if(dd2.le.dzero)dd2=done+t*(de2+dz/dx(i))
            DSQ=DD1*DD2
            DSQ=SQRT(DSQ)
            DPA(I)=DPA(I)*dnorm/DSQ
          ENDDO
        ENDIF
      ENDIF
!
      CALL WEDDLE(DZERO,DPA,DD,MNH,DHNS,MJH,MAXRS)
!
      DD=DD*DALF4
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE VNRKX
!
!                             *******************
!
      SUBROUTINE VNYKX(DP1,DP2,DQ1,DQ2,BINT,MI,ML,DE1,DE2,DPA,DP,DX     &
     &                ,dnorm)
!
!-----------------------------------------------------------------------
!
!  SR.VNYKX CALCULATES THE DEIE V & N "YK" FINE-STRUCTURE INTEGRAL
!
!  IT IS CALLED BY:
!    SR.FSINTX
!
!  IT CALLS:
!    SR.DIFF
!    SR.YLAMKR
!    SR.YLAMK
!
!-----------------------------------------------------------------------
!
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
!
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION DP1(*),DP2(*),DQ1(*),DQ2(*),DPA(*),DP(*),DX(*)
!
!-----------------------------------------------------------------------
!
      BREL2=ABS(IREL).EQ.2
!
      IF(BINT)MJ0=3                      !N
      IF(.NOT.BINT)MJ0=-3                !V
!
      IF(BINT)THEN
        DO I=1,MAXRS
          DPA(I)=DP2(I)*DP1(I)
        ENDDO
      ELSE
        DO I=1,MAXRS
          DPA(I)=DP2(I)/DX(I)
        ENDDO
!
        CALL DIFF(DPA,DP,MNH,DHNS,MJH)
!
        DO I=1,MAXRS
          DPA(I)=DP1(I)*DP(I)*DX(I)
        ENDDO
      ENDIF
!
      IF(BREL)THEN
        DEL=DE1-DE2                                   ! A.U.
        T=DALF4*DTWO
        DZ=NZION
        IF(BREL2)THEN
          DO I=1,MAXRS
            DD1=DONE+T*(DE1+DZ/DX(I))
            DD2=DONE+T*(DE2+DZ/DX(I))
!            DD1=DONE+T*(DE1+DPOT(I))
!            DD2=DONE+T*(DE2+DPOT(I))
            DSQ=DD1*DD2
            DSQ=SQRT(DSQ)
            DPA(I)=DPA(I)/DSQ
          ENDDO
        ELSE
          DO I=1,MAXRS
            DD1=DONE+DALF4*(DQ1(I)/DP1(I)+DTWO*DZ/DX(I))
            if(dd1.le.dzero)dd1=done+t*(de1+dz/dx(i))
            DD2=DONE+DALF4*(DQ2(I)/DP2(I)+DTWO*DZ/DX(I))
            if(dd2.le.dzero)dd2=done+t*(de2+dz/dx(i))
            DSQ=DD1*DD2
            DSQ=SQRT(DSQ)
            DPA(I)=DPA(I)*dnorm/DSQ
          ENDDO
        ENDIF
        CALL YLAMKR(MI,ML,DEL,DPA,DP,DD1,DD2,MNH,DHNS,MJH,MJ0)
      ELSE
        CALL YLAMK(MI,ML,DPA,DP,DD1,DD2,MNH,DHNS,MJH,MJ0)
      ENDIF
!
      IF(.NOT.BINT)THEN
        DO I=1,MAXRS
          DP(I)=DP(I)*DX(I)
        ENDDO
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE VNYKX
!
!                             *******************
!
      SUBROUTINE VPNL(Z,MIONX,MKK,WK,AJUST0,MAXRS,MJH,MNH,DHNS,POT,DTOL &
     &               ,MEND)
!
!-----------------------------------------------------------------------
!
!  SR.VPNL EVALUATES THE ELECTRON POTENTIAL GENERATED BY A FIXED
!  BOUND-STATE CONFIGURATION. E.G. FOR USE WITH GENERATION OF A
!  SELF-CONSISTENT RADIAL SOLUTION. USES NL SUB-SHELL RESOLUTION.
!  N.B. MIONX CAN IN PRINCIPLE BE N- (SR.RADIAL) OR N+1 (SR.RADCON).
!
!  IT IS CALLED BY:
!    SR.RADIAL
!    SR.STOPOT
!
!  IT CALLS:
!    FN.VCC
!    SR.YLAMK
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: MHF,MRAD,MSTEP,IXTRA,xmax
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_MQVC,   ONLY: MODD,KCUT,NEL,KMAX
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
!
      USE COMMON_NRBAL1, ONLY: MSTAT,MXORB,NPRINT,MA,MB,KSUBCF
      USE COMMON_NRBCAV, ONLY: ECAVX,ECAV,AJUSTX,ICAV
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBDW,  ONLY: IDW,btop
      USE COMMON_NRBORB, ONLY: IEQ,IGRCF,ICFGP,IRLX
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBSTO, ONLY: ALF,TEL,MSHELL,MCFSTO,MC,MCFMX,MEXPOT    &
     &                        ,NOCC,IOCC,NLSTOE,BFIX,BSTO,MXSHLL,NGAPSTO&
     &                        ,MEXPOT0,ISTATIC,faca,facsp,fac_csi,faclam&
     &                        ,ifacy,potx
      USE COMMON_NRBVAL, ONLY: FACT,IVAL,NNEW,NNOLD,BJUMP,BJUMP2,BRAD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (DKEY=5999)
      PARAMETER (DFSC2=DFSC/DTWO)                 !ALPHA/2
!      PARAMETER (DCON4=(DSIX/XPI**2)**D1THRD)     !(24/4*pi**2)**1/3
      PARAMETER (TOLW=D1M3)    !TOLERANCE FOR MATCHING OCCUPATION NOS WK
      parameter (tolp0=d0pt05)     !defines end of wavefunction
      parameter (sigma=d0pt2)      !for exchange gaussian damping factor
!
      DIMENSION MNH(*),DHNS(*),POT(*)
!
      ALLOCATABLE :: MEL(:)
!
      ALLOCATABLE :: DA(:),DP(:),dp2(:)
!
      DCON4=(DSIX/XPI**2)**D1THRD                     !(24/4*pi**2)**1/3
!
!-----------------------------------------------------------------------
!
! THE NAMES HERE ARE NOT NECESSARILY SIGNIFICANT THEY ARE COMMON LEGACY.
!
! LOCAL
      ALLOCATE(DA(MAXRS),DP(MAXRS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'VPNL: ALLOCATION FAILS FOR DA,DP'
        NF=0
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
      bcorr=.false.             !add-in correlation potential c.f. Cowan
      if(bcorr)then
        allocate(dp2(maxrs))
        dp2=dzero
      endif
!
      BREL2=ABS(IREL).EQ.2
!
      MK=ABS(MKK)
      MS=MK
      IF(MK.GT.0)THEN
        IF(QN(MK).LT.0)MS=-MS
        IVALMK=IVAL(MK)
      ELSE
        IVALMK=0
      ENDIF
!
      ISWCH0=0
      DO I=1,MXORB
        IF(QN(I).LT.0.OR.IVAL(I).NE.0.OR.SCREEN(I).GE.D7999)ISWCH0=1
      ENDDO
      IF(MK.GT.MXORB)ISWCH0=1                       !CONT, CASE IDW.NE.0
!
      ISWCH=0
      IF(MK.GT.0)THEN
        IF(QN(MK).LT.0.OR.IVAL(MK).NE.0.OR.SCREEN(MK).GE.D7999)ISWCH=1
      ENDIF
!
      IF(AJUSTX.GT.DZERO)THEN
        AJUST=AJUSTX
      ELSE
        AJUST=AJUST0                          !(EXCHANGE) SCALING FACTOR
      ENDIF
      IF(AJUST.EQ.DZERO)AJUST=DONE
      IF(nocc.LE.0)AJUST=D0PT8*AJUST           !A LA COWAN (but not fac)
!
      MCFMXX=MCFMX
      IF(MCFMXX.GT.I1000)MCFMXX=0         !AVERAGE OVER MOD(MCFMX,I1000)
!
      IF(NOCC.LT.0)TOLX=10000
      IF(NOCC.GT.0)TOLX=10000
      if(nocc.eq.0)then
        if(mionx.ge.0)stop 'nocc=0 - inform nrb'       !shouldn't happen
      endif
!
      NOCCM=MOD(NOCC,I1000)
!
! USER INPUT OCCUPATION NOS
!
      IF(NOCCM.NE.0)THEN
        NCO=0
        IF(MA*MB.GT.0.AND.(MIONX.LT.0.OR.MK.EQ.0))THEN     !FOR CORE POT
          DO I=MA,MB
            NCO=NCO+NINT(TEL(I),SP)
          ENDDO
        ENDIF
        MSHLL=ABS(NOCCM)
        TZ=ISWCH0-ISWCH
        GO TO 200
      ENDIF
!
! DETERMINE OCCUPATION NUMBERS FROM FLAGGED CONFIG(S)
!
      ALLOCATE(MEL(MXORB))
!
      DO J=1,MXORB
        TEL(J)=DZERO
        MEL(J)=0
      ENDDO
!
      MSHLL=0
      WK=0
      NZ=0
!
      IF(MK.NE.0.AND.MIONX.GT.0)THEN
!
! CHECK FOR COMMON CORE
        IF(IRLX.LT.0)THEN              !NO COMMON CORE, CASE IEQ(0).GT.0
          MA0=0
          MB0=0
        ELSE                                                !COMMON CORE
          MA0=MA
          MB0=MB
        ENDIF
        BCORE=IEQ(MK).GE.MA0.AND.IEQ(MK).LE.MB0            !IEQ UNNECESS
!
        KAV=0
!
        IF(MCFMXX.GT.0)THEN
!          IF(MK.GT.MCFMXX)THEN                       !HISTORIC...
!            KS=MCFSTO(MCFMXX)
!          ELSE
          KS=MCFSTO(MK)
!          ENDIF
          IF(IEQ(0).GE.0.AND.KS.NE.0.OR.IEQ(0).LT.0.AND.BCORE)THEN
!
! DETERMINE OCCUPATION NUMBERS FOR CONFIG. SPECIFIED FOR THIS ORBITAL
! (N.B. MCFSTO(MK) NOT SPECIFIED FOR VALENCE, CASE IEQ(0).LT.0)
!
            KF=KS
            IF(KS.LE.0)THEN
              IF(BCORE)THEN                        !AVERAGE OVER ALL CFS
                KS=1
                KF=KMAX
              ELSE
                WRITE(MW6,10020)KS,MK
                WRITE(MW0,*)'SR.VPNL: CONFIGURATION NOT SET FOR ORBITAL'
                GO TO 400
              ENDIF
            ENDIF
            IF(KS.GT.KMAX)THEN
              DO J=1,MXORB
                NN=NEL(J,KMAX)
                IF(NN.NE.0)THEN
                  TEL(J)=ABS(NN)
                  MSHLL=J
                ENDIF
              ENDDO
              TZ=ISWCH0-ISWCH
              GO TO 200
            ENDIF
            GO TO 50
!          ELSE
! FULLY RELAXED SO USES SINGLE CF OCC NOS
          ENDIF
        ENDIF
!
! USE CONFIGURATION AVERAGE
!
        KS=1
        KF=KMAX
        IF(IEQ(0).eq.0)THEN
          IF(KCUT.GT.0)KF=MIN(KCUT,KMAX)
          IF(MCFMX.GT.I1000)KF=MIN(MOD(MCFMX,I1000),KMAX) !SO NOT KCUT
          IF(mcfmxx.lt.0)kf=min(-mcfmxx,kmax)
        ENDIF
!
   50   bdw=idw.ne.0.and.qn(mk).lt.0
!           allow target average but an override for cont e.g. Laguerres
        if(bdw.and.mcfsto(mk).ne.0)then
          ks=mcfsto(mk)
          kf=ks
        endif
!
!***********************************************************************
! tbd: copy any bskip implementation at this point from stopot
!***********************************************************************
!
        DO K=KS,KF
!
          IF(.NOT.BCORE.and.mcfmxx.ge.0)THEN
!
! AVERAGE OVER ONLY THOSE CONFIGS THAT CONTAIN MK.
!
            MF=QCG(NF,K)
!
            DO I=1,NF
              IF(QCG(I,K).EQ.MK)THEN
                IF(IEQ(0).LT.0.AND.MCFSTO(MK).EQ.0)MCFSTO(MK)=K
                GO TO 60
              ENDIF
            ENDDO
!
            IF(IEQ(0).GT.0.AND.IEQ(MK).LE.MB)THEN       !CASE KCOR1.LT.0
              IGROUP=IGRCF(MK)
              IF(IGROUP.EQ.ICFGP(K))GO TO 60            !ORB IN CFG
              GO TO 100
            ENDIF
!
            IF(MCFMXX.LE.0.OR.MCFSTO(MK).EQ.0)then
              if(bdw)go to 60
              GO TO 100
            ENDIF
!
! IF USER READ OF MCFSTO FOR SUBSET OF ORBITALS ONLY, TRY AND ENSURE
! NO IMBALANCE IN TARGET CONTINUUM
!OLD        IF(IVAL(MK).GT.0.OR.SCREEN(MK).GT.DKEY)GO TO 81
            IF(SCREEN(MK).GT.DKEY.AND.                                  &
     &         (QN(MF).LT.0.OR.IVAL(MF).NE.0.OR.SCREEN(MF).GT.DKEY).OR. &
     &         bdw)GO TO 60
!
            IF(IEQ(0).GT.0.AND.IEQ(MK).LE.MB)GO TO 60
            IF(IEQ(0).LT.0)GO TO 100
!
            MS=0
            IF(MHF.GE.-100.OR.MK.NE.MCFMXX)THEN     !SHOULD BE CAUGHT...
              WRITE(MW6,10030)MK,K
              WRITE(MW0,*)                                              &
     &                  '*****ERROR IN SR.VPNL: ORBITAL NOT FOUND IN CF'
              GO TO 400
            ENDIF
!
          ENDIF
!OLD   81     CONTINUE
!
! USE MCFMX.LT.0 TO AVERAGE OVER -MCFMX
!
   60     CONTINUE
!
!***********************************************************************
! tbd: copy any bskip implementation at this point from stopot
!***********************************************************************
!
! EQUAL WEIGHTING, COULD TRY ALTERNATIVE......
!
          KAV=KAV+1
!
          N0=100
!          if(bdw)nz=nz+1                                 !stopot...
!
          DO I=1,MXORB
!            I=QCG(L,K)
            I1=NEL(I,K)
            IF(I1.LE.0)GO TO 80                              !ALL CORE
            MJ=MOD(QN(I),Q70)
            NZ=NZ+I1
            IF(IVAL(I).GT.0.AND.(QN(I).GE.ABS(QN(MK)).OR.QN(MK).LT.0))  &
     &         GO TO 80
!            if(DADJUS(i).lt.dzero.and.qn(mk).lt.0)go to 80     !for dw
            IF(SCREEN(I).GT.DKEY)GO TO 80
            IF(QN(I).LT.0)GO TO 80
            IF((MJ-N0).GT.NGAPSTO.AND.ABS(MS).LT.I)GO TO 80  !C.F.STOPOT
            NZ=NZ-I1
            N0=MJ
            IF(I.GT.MSHLL)MSHLL=I
            MEL(I)=MEL(I)+I1
   80     ENDDO
!
          IF(MS.GT.MXORB.OR.MS.LT.0.OR.IVAL(MK).GT.0)NZ=NZ-1
!
  100   ENDDO
!
        IF(KAV.EQ.0)THEN
          IF(MCFMXX.EQ.0.AND.KF.LT.KMAX)THEN        !CORRELATION ORBITAL
            KF=KMAX                                     !NOT IN KCUT, SO
            GO TO 50
          ELSE
            WRITE(MW6,10040)MK,KF
            WRITE(MW0,*)                                                &
     &                 '*****ERROR IN SR.VPNL: ORBITAL NOT FOUND IN CFS'
            GO TO 400
          ENDIF
        ENDIF
!
        IF(MB.GT.0)THEN
          DO I=MA,MB
            IF(I.GT.MSHLL)MSHLL=I
            MEL(I)=MEL(I)+2*(QL(I)+1)*KAV
          ENDDO
        ENDIF
!
        T1=KAV
        TZ=NZ
        TZ=TZ/T1
        NZ=NINT(TZ,SP)
!        IF(ABS(TZ-NZ).GT.TOLW)THEN
!          WRITE(MW6,1001)TZ
!          WRITE(MW0,1001)TZ
!          GO TO 999
!        ENDIF
!           write(mw6,*)mk,ajust,zn
!
        DO J=1,MSHLL
          T2=MEL(J)
          TEL(J)=T2/T1
!           if(t2.ne.dzero)write(mw6,*)j,tel(j)
        ENDDO
!
      ELSE
!
! CHOOSE FIRST SUITABLE BOUND (MKK.GE.0) OR CONTINUUM (MKK.LT.0) CONFIG.
!
        NCO=0
        IF(MA*MB.GT.0)THEN
          DO I=MA,MB
            TEL(I)=2*(QL(I)+1)
            NCO=NCO+NINT(TEL(I),SP)
            IF(I.GT.MSHLL)MSHLL=I
          ENDDO
        ENDIF
!
        IF(MIONX.GE.0.AND.MKK.NE.0)THEN
          DO M=1,KMAX
            I=QCG(NF,M)
            IF(MKK.GT.0.AND.QN(I).GE.0)THEN
              DO L=1,NF
                IF(QCG(L,M).EQ.MK)GO TO 120
              ENDDO
            ENDIF
            IF(MKK.LT.0)THEN                             !NOT USED
              IF(IVAL(I).GT.0.AND.QN(I).GE.ABS(QN(MK)))GO TO 120
              IF(SCREEN(I).GT.DKEY)GO TO 120
              IF(QN(I).LT.0)GO TO 120
            ENDIF
          ENDDO
          GO TO 200
!
  120     DO N=1,NF
            I=QCG(N,M)
            IF(MKK.LT.0)THEN                             !NOT USED
              NZ=NZ+1
              IF(IVAL(I).GT.0.AND.QN(I).GE.ABS(QN(MK)))GO TO 140
              IF(SCREEN(I).GT.DKEY)GO TO 140
              IF(QN(I).LT.0)GO TO 140
              NZ=NZ-1
            ENDIF
            TEL(I)=TEL(I)+DONE
            IF(I.GT.MSHLL)MSHLL=I
  140     ENDDO
          IF(MKK.LT.0)THEN                             !NOT USED
            IF(MS.GT.MXORB.OR.MS.LT.0.OR.IVAL(MK).GT.0)NZ=NZ-1
          ENDIF
        ENDIF
!
        TZ=NZ
!
      ENDIF
!
! RE-ENTRY POINT FOR USER SUPPLIED OCCUPATION NOS
!
  200 CONTINUE
!
! SET EFFECTIVE OCCUPATION FOR THIS ORBITAL SUB-SHELL
!
      IF(MS.LT.0.OR.IVALMK.GT.0)THEN
        MS=0                                 !RYD/CONT OCCUPN NOT IN TEL
      ELSE
        MS=1
      ENDIF
      IF(MK.GT.0)WK=TEL(MK)+1-MS             !FOR FAC (WRONG: MS-1)
!
!      write(mw0,*)'k=',mk,' w=',wk
!
! SET (EXPECTED) ASYMPTOTIC CHARGE
!
      IF(MIONX.GE.0)THEN
        ZN=MIONX-1-TZ
      ELSE
        ZN=NCO-TZ
      ENDIF
      ZN=Z-ZN
      ZN1=ZN
      IF(NINT(ZN1,SP).EQ.IZERO)ZN1=DONE
!
! INITIALIZE POT(I) WITH NUCLEAR POTENTIAL (ANY FINITE IS ADDED LATER)
!
      T=Z
!
      BSTATIC=ABS(MEXPOT).GE.ISTATIC
!
      if(nocc.gt.0)then                   !fac unique averaged potential
        BTEST=ABS(MEXPOT).EQ.4.AND.BSTATIC        !NO WEIGHTING NEEDED
      else
        BTEST=.TRUE.                              !AS NOT FAC
      endif
!
      bporig=BTEST.or.mk.le.0
!
      if(bporig)then
        DO I=1,MAXRS
          POT(I)=T/DX(I)
        ENDDO
      else
        T=WK*T
        IF(BREL2)THEN
          DO I=1,MAXRS
            TT=DPNL(I,MK)*DPNL(I,MK)+DQNL(I,MK)*DQNL(I,MK)
            POT(I)=T*TT/DX(I)
          ENDDO
        ELSE
          DO I=1,MAXRS
            POT(I)=T*DPNL(I,MK)*DPNL(I,MK)/DX(I)  !WEIGHT BY PROB.DENS.
          ENDDO
        ENDIF
      endif
!
      IF(MIONX.LT.0.AND.NCO.EQ.0)GO TO 300        !RETURN
!
!
! *** FORM CONFIGURATION AVERAGE POTENTIAL: ***
!
! DIRECT MULTIPOLE
! (STATIC ONLY FOR NON-RYD/CONT FURNESS & MCCARTHY EXCHANGE)
! PLUS
! IF MEXPOT.EQ.0 NON-LOCAL EXCHANGE MULTIPOLE,
! IF MEXPOT.GT.0 LOCAL EXCHANGE (STATIC).
!(IF MEXPOT.LT.0 NO EXCHANGE CONTRIB.)
!
      i1=0
!
      DO J=1,MSHLL
!
        BEQNL=J.EQ.MK.AND.MS.GT.0
!
        MJX=0
        ME1=-1
        ME2=-2
        C=TEL(J)
        imex4=0
        IF(BEQNL)THEN
          if(mkk.gt.0.)then
            C=C-DONE
            if(abs(mexpot).eq.4)imex4=1        !retains self-interaction
          endif
          IF(.NOT.BSTATIC)MJX=MIN(INT(QL(J),SP),ISIX)
        ELSEIF(MK*MS.NE.0)THEN
          ME1=ABS(QL(J)-QL(MK))/2
          MEI=(QL(J)+QL(MK))/2
          IF(BSTATIC)THEN
            ME2=0
          ELSE
            ME2=MEI
            ME2=MIN(ME2,6_SP)
          ENDIF
          MEI=MEI+2
        ENDIF
!
!        write(mw0,*)'j=',j,' w=',c
!
        IF(ABS(C+imex4).GT.TOLW)THEN
!
! DIRECT
          IF(BREL2)THEN
            DO I=1,MAXRS
              DP(I)=DPNL(I,J)*DPNL(I,J)+DQNL(I,J)*DQNL(I,J)
            ENDDO
          ELSE
            DO I=1,MAXRS
              DP(I)=DPNL(I,J)*DPNL(I,J)
            ENDDO
          ENDIF
!
          if(bcorr)then
            c0=abs(c)
            do i=1,maxrs
              dp2(i)=dp2(i)+c0*dp(i)
            enddo
          endif
!
          MDI=QL(J)+2
          F0=REAL((MDI-1),WP)/REAL((2*MDI-3),WP)
          F=DONE
!
          DO MJ=0,MJX,2
!
            CALL YLAMK(MJ,MDI,DP,DA,DD1,DD2,MNH,DHNS,MJH,IZERO)
!                                                            !NO RETARDN
            IF(MJ.GT.0)THEN
              DC1=VCC(INT(QL(J),SP),2*MJ,INT(QL(J),SP),IZERO,IZERO,     &
     &            IZERO)
              F=-F0*DC1*DC1/(MDI-1)
            ENDIF
!            write(mw6,*)ql(j),2*mj,ql(j),'  f=',f
!            write(mw0,*)'f=',f
!
            T=(C+imex4)*F
            imex4=0                                         !static only
!
            if(bporig)then
              DO I=1,MAXRS
                POT(I)=POT(I)-T*DA(I)
              ENDDO
            else
              T=WK*T
              IF(BREL2)THEN
                DO I=1,MAXRS
                  TT=DPNL(I,MK)*DPNL(I,MK)+DQNL(I,MK)*DQNL(I,MK)
                  POT(I)=POT(I)-T*DA(I)*TT
                ENDDO
              ELSE
                DO I=1,MAXRS
                  POT(I)=POT(I)-T*DA(I)*DPNL(I,MK)*DPNL(I,MK)
                                                             !WGHT BY PD
                ENDDO
              ENDIF
            endif
!
          ENDDO
!
! EXCHANGE
          IF(ME1.LE.ME2.AND.MEXPOT.EQ.0)THEN
!
            if(bporig)then !i1.eq.0.and.
              mjk=min(j,mk)
              in=icol(mjk,mjk,izero)
              de=dey(mjk)-duy(in)
              de=de+de
              fnu=sqrt(-zn1*zn1/de)
              l=ql(mjk)/2
              el=l
              a1=max(fnu*fnu-el*(el+done),dzero)
              a1=sqrt(a1)
              ri=fnu*(fnu+a1)
              ri=dthree*ri/zn1
              tolp=tolp0/zn1
!              write(mw6,*)ri/dthree,de,zn1,fnu
!
              do i=maxrs,1,-1
                if(abs(DPNL(I,mjk)).gt.tolp)then
                  i1=i
!                  write(mw6,*)mjk,dx(i),ri/dthree,rinf2(mjk)
                  go to 210
                endif
              enddo
            endif
  210       continue
!
!
            IF(BREL2)THEN
              DO I=1,MAXRS
                DP(I)=DPNL(I,J)*DPNL(I,MK)+DQNL(I,J)*DQNL(I,MK)
              ENDDO
            ELSE
              DO I=1,MAXRS
                DP(I)=DPNL(I,J)*DPNL(I,MK)
              ENDDO
            ENDIF
!
            DO MJ=ME1,ME2,2
!
              CALL YLAMK(MJ,MEI,DP,DA,DD1,DD2,MNH,DHNS,MJH,IZERO)
                                                             !NO RETARDN
!            write(mw0,*)dd1
!
              DC1=VCC(INT(QL(J),SP),2*MJ,INT(QL(MK),SP),IZERO,IZERO,    &
     &            IZERO)
              G=-DC1*DC1/(2*QL(MK)+2)
!
!            write(mw0,*)'g=',g
!            write(mw6,*)ql(j),2*mj,ql(mk),'  g=',g
!
              G=G*AJUST                            !TRY SCALING EXCHANGE
              CG=C*G
!
              if(bporig)then
                IF(BREL2)THEN
                  DO I=1,i1                                       !MAXRS
                    T=DPNL(I,J)*DPNL(I,MK)+DQNL(I,J)*DQNL(I,MK)
                    T=T/(DPNL(I,MK)*DPNL(I,MK)+DQNL(I,MK)*DQNL(I,MK))
                    if(dx(i).gt.ri)t=t*exp(-((dx(i)/ri-done)/sigma)**2)
                    IF(ABS(T).lt.TOLX.or.dx(i).lt.ri)then
                      POT(I)=POT(I)-CG*DA(I)*T
!                  else
!          write(mw6,99)j,mk,i,dx(i),t,DPNL(I,J),DPNL(I,MK),pot(i)*dx(i)
! 99    format(3i5,1p,5d10.3)
                    endif
                  ENDDO
                ELSE
                  DO I=1,i1                                       !MAXRS
!                  if(dpnl(i,mk).eq.dzero)then
!                    write(mw6,*)i,mk
!                    stop 'p=0'
!                  else
                    if(brel)then
                      dqnj=dpnl(i,j)
                      dqnk=dpnl(i,mk)
                      h=dx(i)
                      if(i.gt.1)then
                        dqnj=dqnj-dpnl(i-1,j)
                        dqnk=dqnk-dpnl(i-1,mk)
                        h=h-dx(i-1)
                      endif
                      dqnj=dfsc2*(dqnj/h-dpnl(i,j)/dx(i))
                      dqnk=dfsc2*(dqnk/h-dpnl(i,mk)/dx(i))
                      t=dpnl(i,mk)*dpnl(i,mk)+dqnk*dqnk
!                      if(t.eq.dzero)then
!                        stop 'pq=0'
!                      endif
                      t=(dpnl(i,j)*dpnl(i,mk)+dqnj*dqnk)/t
                    else
                      T=DPNL(I,MK)
                      IF(T.EQ.DZERO)T=DPNL(I,J)/TOLX
                      T=DPNL(I,J)/T
                    endif
                    if(dx(i).gt.ri)t=t*exp(-((dx(i)/ri-done)/sigma)**2)
                    IF(ABS(T).lt.TOLX.or.dx(i).lt.ri)then
                      POT(I)=POT(I)-CG*DA(I)*T
!                  else
!          write(mw6,99)j,mk,i,dx(i),t,DPNL(I,J),DPNL(I,MK),pot(i)*dx(i)
! 99    format(3i5,1p,5d10.3)
                    endif
                  ENDDO
                ENDIF
              else
                i1t=MAXRS
                tolp=tolp0/zn1
                mjk=min(j,mk)
                do i=-maxrs,1,-1                     !+maxrs for no p.d.
                  if(abs(DPNL(I,mjk)).gt.tolp)then
                    i1t=i
!                  write(mw6,*)mjk,dx(i),ri/dthree,rinf2(mjk)
                    go to 212
                  endif
                enddo
  212           T=WK*CG
                IF(BREL2)THEN
                  DO I=1,i1t                                      !MAXRS
                    TJK=DPNL(I,J)*DPNL(I,MK)+DQNL(I,J)*DQNL(I,MK)  !P.D.
!                  tjk=tjk/(dpnl(i,mk)*dpnl(i,mk)+dqnl(i,mk)*dqnl(i,mk))
                    POT(I)=POT(I)-T*DA(I)*TJK
                  ENDDO
                ELSE
                  DO I=1,i1t                                      !MAXRS
                    TJK=DPNL(I,J)*DPNL(I,MK)       !WEIGHT BY PROB.DENS.
!                    tjk=tjk/(dpnl(i,mk)*dpnl(i,mk))             !do not
                    POT(I)=POT(I)-T*DA(I)*TJK
                  ENDDO
                ENDIF
              endif
            ENDDO
!
          ENDIF
!
        ENDIF
!
        if(bcorr.and.c0.gt.tolw)then
          do i=1,maxrs
            rs=dthree*dx(i)*dx(i)/dp2(i)
            rs=rs**d1thrd
            es=1.142D0*rs                                  !Cowan (7.64)
            es=dfour*sqrt(rs+dnine)+d3qrt*es               !Cowan (7.71)
            es=+done/es                                    !as pot~z/r
            es=es/dtwo                                     !a.u.
            if(bporig)then
              pot(i)=pot(i)+es
            else
              tt=dpnl(i,mk)*dpnl(i,mk)
              if(brel2)tt=tt+dqnl(i,mk)*dqnl(i,mk)
              pot(i)=pot(i)+es*tt*wk
            endif
!              write(mw6,1999)i,dx(i),pot(i),es
! 1999   format(i5,1p3e14.6)
!              call flush(mw6)
          enddo
        endif
!
      ENDDO
!
! LOCAL EXCHANGE APPROXIMATIONS
!
! THE VARIOUS FORMS (CONTROLLED BY MEXPOT) ARE AS FOR STO,
! EXCEPT THAT COWAN (MEXPOT=3) IS NOT YET SUPPORTED HERE.
!
!?                                             .OR.MIONX.LT.0
      IF(MEXPOT.GT.0.OR.MEXPOT.EQ.0.AND.MS.EQ.0)THEN
!
        MEXPOT1=MEXPOT
!T        IF(MEXPOT.EQ.0)MEXPOT1=MEXPOT0         !TEST ALT TO F&M
!
        BFMLX=mod(MEXPOT1,ifive).EQ.0          !FURNESS & MCCARTHY
!
        DO I=1,MAXRS
          DP(I)=DZERO
        ENDDO
!
        if(bporig)then
          ms0=ms
        else
          ms0=0
        endif
!
        DO J=1,MSHLL
          C=TEL(J)
          IF(BFMLX.AND.J.EQ.MK.AND.MS0.GT.0)C=C-DONE
          IF(ABS(C).GT.TOLW)THEN
            IF(BREL2)THEN
              DO I=1,MAXRS
                TT=DPNL(I,J)*DPNL(I,J)+DQNL(I,J)*DQNL(I,J)
                DP(I)=DP(I)+C*TT
              ENDDO
            ELSE
              DO I=1,MAXRS
                DP(I)=DP(I)+C*DPNL(I,J)*DPNL(I,J)
              ENDDO
            ENDIF
          ENDIF
        ENDDO
!
        DO I=1,MAXRS
          DP(I)=DP(I)/DX(I)**2                              !OMITS 1/4PI
        ENDDO
!
        TT=DONE
        T2=AJUST/DTWO                                !     /2 AS POT~Z/R
        if(.not.bporig)T2=WK*T2                      !FOR PROB.DEN. WGHT
        IF(BFMLX)THEN                                !FURNESS & MCCARTHY
          E=DZERO
!          IN=ICOL(MK,MK,IZERO)
!          E=-DEY(MK)+DUY(IN)
          IF(T2.GT.TOLW)THEN
            DO I=1,MAXRS
              if(.not.bporig)then
                TT=DPNL(I,MK)*DPNL(I,MK)            !WEIGHT BY PROB.DENS
                IF(BREL2)TT=TT+DQNL(I,MK)*DQNL(I,MK)
              endif
              T1=(E+POT(I))**2+DP(I)
              IF(T1.GT.DZERO)POT(I)=POT(I)+(SQRT(T1)-(E+POT(I)))*T2*TT
            ENDDO
          ENDIF
        ELSE
          if(mk.le.0.and.mexpot1.le.2)mexpot1=4          !no self-screen
          IF(MEXPOT1.EQ.1)THEN
            XK=D2THRD                                 !L&R ALPHA=4/9 RYD
          ELSEIF(MEXPOT1.EQ.2)THEN
            XK=DONE                                   !L&R ALPHA=2/3 RYD
!          ELSEIF(MEXPOT1.EQ.3)THEN                 !NOT IMPLEMENTED YET
!            XK=D2THRD                                !COWAN K_X=2/3 RYD
          ELSEIF(MEXPOT1.EQ.4)THEN
!            XK=D3HALF                          !ORIGINAL HARTREE-SLATER
            XK=DONE                        !COWAN/FAC H-S: ALPHA=2/3 RYD
!
! FAC AHX IS IN A.U. AND ABSORBS ALL CONSTANTS:
!                          V-FAC_X=AHX*(SUM_I W_I*PROB.DEN._I/R**2)**1/3
! SO ALPHA=2/3 RYD CORRESPONDS TO AHX=0.4235 A.U.
!
!            write(mw0,*)mk,wk,faca,xk*t2*dcon4/wk   !a.u.
            XK=2*FACA/DCON4                      !SO THAT CC=WK*AHX A.U.
          ENDIF
!
          CC=T2*XK*DCON4                                  !ABSORBS 1/4PI
!
          TK=DZERO
          DO I=1,MAXRS
            if(.not.bporig.or.mexpot1.le.2)then          !NEED PROB DENS
              TT=DPNL(I,MK)*DPNL(I,MK)
              IF(BREL2)TT=TT+DQNL(I,MK)*DQNL(I,MK)
            endif
            TS=DP(I)
            IF(MEXPOT1.LE.2)THEN                   !FOR LINDGREN & ROSEN
              TK=TT/DX(I)**2                                 !OMIT 1/4PI
              IF(NINT(WK).EQ.1)TS=TS+TK
              TK=(DTWO*TK)**D1THRD
              if(bporig)TT=DONE
            ENDIF
!            write(60+mk,*)i,dx(i),ts !CC*TT*(TS**D1THRD-TK)
!            call flush(60+mk)
            TX=CC*(TS**D1THRD-TK)*TT
            if(ifacy.eq.2020)then                 !hold exchange
              potx(i)=tx
            else
              POT(I)=POT(I)+TX                    !so pot is direct only
            endif
          ENDDO
        ENDIF
!
      ENDIF
!
      if(.not.bporig)go to 300
!
! DETERMINE POINT OF ASYMPTOTIC COULOMB SCREENING (USER MAY HAVE SET
! FRACTIONAL OCCUPATION NOS...)
!
      T=POT(MAXRS)*DX(MAXRS)
      IF(ABS(T/ZN1).GT.DTOL)THEN
        ZN=T
        ZN1=ZN
        IF(NINT(ZN1,SP).EQ.IZERO)ZN1=DONE
        ITEST=MAXRS-10
      ELSE
        ITEST=MAXRS
      ENDIF
!
      DO I=1,MAXRS
        T=POT(I)-ZN/DX(I)
        T=T*DX(I)/ZN1
        IF(ABS(T).GT.DTOL)MEND=I
      ENDDO
!
      IF(MEND.LT.ITEST)GO TO 300
      MEND=MAXRS
!      if(abs(t).lt.2*dtol)go to 900
!      write(mw6,*)t,dtol
!
      T=POT(ITEST)*DX(ITEST)
!
      WRITE(MW6,10010)MK,DX(ITEST),ZN,T
!
!      WRITE(MW6,*)MEND,MAXRS
!      do i=1,maxrs
!        write(mw6,1999)i,dx(i),pot(i),dx(i)*pot(i)
! 1999   format(i5,1p3e14.6)
!      enddo
!
!-----------------------------------------------------------------------
!
  300 IF(ALLOCATED(MEL))DEALLOCATE(MEL)
!
      if(bcorr)deallocate(dp2)
!
! LOCAL
      DEALLOCATE(DA,DP,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'VPNL: DE-ALLOCATION FAILS FOR DA,DP'
        IF(NF.GT.0)NF=0
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
  400 NF=-1
      GO TO 300
!
!-----------------------------------------------------------------------
!
10010 FORMAT(' *** SR.VPNL: NOT ENOUGH MESH POINTS FOR ORBITAL?',I5,    &
     &       ' CHECK IF ASYMPTOTIC POTENTIAL ACCURATE ENOUGH:',1P,      &
     &       3E11.3)
! 1001 FORMAT(' *** SR.VPNL: WARNING, ASYMPTOTIC CHARGE= Z-N+',F6.2)
10020 FORMAT('*** ERROR IN SR.VPNL: NON-VALID CONFIGURATION',I3,        &
     &       ' SPECIFIED FOR ORBITAL ',I3)
10030 FORMAT(' *** ERROR IN SR.VPNL: ORBITAL',I4,' NOT FOUND IN',       &
     &       ' CONFIGURATION',I4)
10040 FORMAT(' *** ERROR IN SR.VPNL: ORBITAL',I4,' NOT FOUND IN',       &
     &       ' THE FIRST',I4,' CONFIGURATIONS')
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE VPNL
!
!                             *******************
!
      SUBROUTINE VXC(DENS,TPLASMA,U)
!
!-----------------------------------------------------------------------
!
!  SR.VXC EVALUATES FREE ELECTRON PLASMA POTENTIAL, AT GIVEN TEMPERATURE
!  AND DENSITY.
!
!  IT IS CALLED BY:
!    SR.VFREE
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (C1=4.7853_WP)
      PARAMETER (C2=0.6109_WP)
      PARAMETER (C3=2.83431_WP)
      PARAMETER (C4=0.21512_WP)
      PARAMETER (C5=5.27586_WP)
      PARAMETER (C6=3.94309_WP)
      PARAMETER (C7=7.91379_WP)
      PARAMETER (C8=0.638168_WP)
!
!-----------------------------------------------------------------------
!
      PI=ACOS(-DONE)
!
      IF(DENS.LE.D1M8)THEN
        U=DZERO
      ELSE
        R=(DTHREE/(DFOUR*PI*DENS))**(DONE/DTHREE)
        T=(TPLASMA/C1)*DENS**(-DTWO/DTHREE)
!
!     EXCHANGE PART
!
        UX0=-C2/R
        UX=UX0*(DONE+C3*T**2-C4*T**3+C5*T**4)
        UX=UX/(DONE+C6*T**2+C7*T**4)*TANH(DONE/T)
!
!     CORRELATION PART
!     ASYMPTOTIC FORM FOR HIGH-T ELECTRON GAS
!
        UCHA=-C8/SQRT(T*R)
!
        U=UX+UCHA
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE VXC
!
!                             *******************
!
      SUBROUTINE WEDDLE(A0,A,W,NH,HN,JH,NDIM)
!
!-----------------------------------------------------------------------
!
!  SR.WEDDLE INTEGRATES ARRAY A, USING WEDDLE'S RULE -- J.A.BELLING, UCL
!
!  IT IS CALLED BY:
!    SR.CARATE
!    SR.CAVE
!    SR.DIAGON
!    SR.FSINT
!    SR.FSINTI
!    SR.MVDINT
!    SR.NLAM
!    SR.QEDINT
!    SR.RADBP1
!    SR.RADBP2
!    SR.RADCON
!    SR.RADIAL
!    SR.RADWAV
!    SR.RADWIN
!    SR.RK4PI
!    SR.RKINT
!    SR.RKX
!    SR.SLATR
!    SR.SLATRI
!    FN.TLAM
!    FN.ULAM
!    FN.VLAM
!    SR.VLAM0
!    SR.VNRKX
!    FN.XTWO
!    SR.YLAMKX
!    SR.ZETA
!    SR......
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION A(NDIM),NH(JH),HN(JH)
!
!-----------------------------------------------------------------------
!
      N=1
      A1=A0
      JH0=0
      W=DZERO
!
      DO J=1,JH
        J1=NH(J)
        IF(N+J1-1.GT.NDIM)THEN
          J1=NDIM-N+1
          IF(J1.LT.6)GO TO 100         !& RETURN: FOR MAXPS, CAN NEGLECT
          JH0=J
        ENDIF
        H=HN(J)
!
        J16=MOD(J1,ISIX)
        J2=J16+1
!
!        GO TO (7,1,2,3,4,5),J2
!
        IF(J16.EQ.1)THEN                                          !1
          W=W+(19087*A1+65112*A(N)-46461*A(N+1)+37504*A(N+2)            &
     &      -20211*A(N+3)+6312*A(N+4)-863*A(N+5))/60480*H
        ELSEIF(J16.EQ.2)THEN                                      !2
          W=W+(1139*A1+5640*A(N)+33*A(N+1)+1328*A(N+2)-807*A(N+3)       &
     &      +264*A(N+4)-37*A(N+5))/3780*H
        ELSEIF(J16.EQ.3)THEN                                      !3
          W=W+(685*A1+3240*A(N)+1161*A(N+1)+2176*A(N+2)-729*A(N+3)      &
     &      +216*A(N+4)-29*A(N+5))/2240*H
        ELSEIF(J16.EQ.4)THEN                                      !4
          W=W+2*(143*A1+696*A(N)+192*A(N+1)+752*A(N+2)+87*A(N+3)        &
     &      +24*A(N+4)-4*A(N+5))/945*H
        ELSEIF(J16.EQ.5)THEN                                      !5
          W=W+5*(743*A1+3480*A(N)+1275*A(N+1)+3200*A(N+2)+2325*A(N+3)   &
     &      +1128*A(N+4)-55*A(N+5))/12096*H
        ENDIF
!
        IF(J16.NE.0)THEN
          M=N+J2-2
          A1=A(M)
        ENDIF
!
        N=N+J2-1                                                  !7
        J2=J1/6
!
        DO J1=1,J2
          W=W+(41*(A1+A(N+5))+216*(A(N)+A(N+4))+27*(A(N+1)+A(N+3))      &
     &      +272*A(N+2))*H/140
          N=N+5
          A1=A(N)
          N=N+1
        ENDDO
!
        IF(JH0.EQ.J)GO TO 100
!
      ENDDO
!
!-----------------------------------------------------------------------
!
  100 RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE WEDDLE
!
!                             *******************
!
      FUNCTION WHITEX(R,TL,DL,E,ZN,BNORM,DIFF)
!
!-----------------------------------------------------------------------
!
!  FN.WHITEX CALCULATES THE VALUE OF THE WHITTAKER FUNCTION AT POINT R:
!  USING AN ASYMPTOTIC EXPANSION SEE E.G. BATES & DAMSGAARD (1949)
!
!  WHITEX=NORM*EXP(-U)*(U+U)**NU*{1+A(I)/R**I+...I=1,IMAX}
!  WHERE U=R*SQRT(-E) & NU=ZN/SQRT(-E) AND
!  NORM=SQRT(ZN/(GAMMA(NU+L+1)GAMMA(NU-L)))/NU
!
! INPUT:
!
!  TL=ANGULAR MOMENTUM (FOR GAMMA NORMALIZATION)
!  DL=COEFF OF 1/R**2 (=L(L+1) CASE NON-REL.)
!  E=ENERGY/RY (E.LT.0)
!  ZN=ASYMPTOTIC CHARGE
!
! OUTPUT:
!
!  WHITEX=THE REQUIRED VALUE OF THE WHITTAKER FUNCTION AT R.
!
!  BNORM=.TRUE.  IF THE GAMMA FUNCTION NORMALIZATION WAS APPLIED,
!                WE USE LOG(GAMMA) FOR LARGE N+L VIZ. LANCZOS FN.GAMLN
!                FOR NON F2008 COMPILERS.
!
!  BNORM=.FALSE. IF IT CANNOT BE, THEN NORM=1. THIS SHOULD ONLY OCCUR
!                NOW IF THE EFFECTIVE QUANTUM NUMBER ACCIDENTALLY
!                IS AN EXACT INTEGER .LE. L. N.B. WE USE FN.GAMA7 HERE
!                SINCE LANCZOS FN.GAMA CAN ONLY HANDLE MILDLY NEGATIVE
!                ARGUMENTS, AND A POOR ESTIMATE OF E...
!
! I/O
!  DIFF=LOG OF ANY EXTRA RENORMALIZATION FACTOR NECESSARY TO KEEP
!       NORM*EXP(-U)*(U+U)**P REPRESENTATBLE, WHERE U=R*SQRT(-E)
!       AND P=ZN/SQRT(-E). THIS IS INDEPENDENT OF BNORM.
!
!  DIFF=0 ON INPUT (NORMALLY) WHILE ON OUTPUT IT IS THE VALUE BY WHICH
!         ANY PREVIOUS CALLS TO WHITEX (WITH OUTPUT DIFF=0) NEED TO BE
!         MULTIPLIED BY EXP(DIFF) TO GIVE THE SAME RENORMALIZATION. THUS
!      >0 ON OUTPUT INDICATES UNDERFLOW WOULD OCCUR OTHERWISE.
!         THIS IS ALWAYS POSSIBLE FOR SUFFICIENTLY LARGE R.
!      <0 ON OUTPUT INDICATES OVERFLOW WOULD OCCUR OTHERWISE.
!         THIS DOES NOT NORMALLY HAPPEN SINCE THE FUNCTION IS BOUNDED
!         AND ONLY HIGHLY UNPHYSICAL L.GT.P MAY RESULT IN
!         BNORM=.FALSE.
!
!  IT IS CALLED BY:
!    SR.MESH
!    SR.RADWAV
!
!  IT CALLS:
!    FN.GAMA7
!    FN.GAMLN
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,XP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!
      REAL(XP) A,AMAX,GNU,SUMM,PS1,PS2
!
! CANCELLATION ERROR TEST
      PARAMETER (DEPS=D1M10**(XP/4))
!
! LARGEST EXP ARGUMENT FOR WP=4,8,16
      PARAMETER (DEXP0=D88*(WP/4)**3*(1+nint(real(WP)/16)))
!
! LARGEST GAMMA ARGUMENT FOR WP=4,8,16
      PARAMETER (SUPFCT=33*((WP/4)**2+(WP-4)/4)*(1+9*nint(real(WP)/16)))
!
! SMALLEST GAMMA ARGUMENT (NOW TINY)
!      PARAMETER (ENFFCT=D1M6)
!
! MIN NUMBER OF TERMS SUMMED IN COULOMB SERIES
      PARAMETER (IMAX0=50)
!
      DATA BFIRST/.TRUE./
!
!-----------------------------------------------------------------------
!
!t      diff=dzero
!
      A=SQRT(-E)
      GNU=ZN/A
      ZNE=-ZN/E                          !=GNU/A
!
! DO NOT NORMALIZE WHITTAKER FUNCTION IF FOR ARGUMENTS
! H1 OR H2 GAMMA IS OUTSIDE MACHINE OR PHYSICAL RANGE.
!
      H2=GNU-TL
      HMIN=TINY(HMIN)                   !ENFFCT
      IF(H2.LT.HMIN)THEN
        T=REAL(NINT(H2,SP),WP)-H2
        IF(ABS(T).lt.HMIN.or.zne.lt.hmin)THEN      !NON-POSITIVE INTEGER
          BNORM=.FALSE.
          FN=DZERO
          GO TO 100
        ENDIF
      ENDIF
!
! FN=SQRT(ZN/(GAMMA(GNU+L+1)GAMMA(GNU-L)))/GNU
!
      BNORM=.TRUE.                      !NORMALIZATION CAN BE CALCULATED
!
      IF(B_F2008.AND.BFIRST)THEN
        WRITE(MW6,*)'****WHITEX: UNCOMMENT TO USE F2008 GAMMA'
        WRITE(MW0,*)'****WHITEX: UNCOMMENT TO USE F2008 GAMMA'
        BFIRST=.FALSE.
      ENDIF
!
      H1=GNU+TL+DONE
      IF(H1.GT.SUPFCT)THEN              !ARG TOO LARGE FOR GAMMA USE LOG
!
!        IF(B_F2008)THEN
!          D1=LOG_GAMMA(H1)
!          D2=LOG_GAMMA(H2)
!        ELSE               !USE GAMLN UNTIL REPLACED BY F2008 LOG_GAMMA
        D1=GAMLN(H1)
        D2=GAMLN(H2)
!        ENDIF
!
        D3=LOG(ZNE)
        FN=(D1+D2+D3)/DTWO
        FN=-FN
!
      ELSE
!
!        IF(B_F2008)THEN
!          D1=GAMMA(H1)
!          D1=SQRT(D1)
!          D2=GAMMA(H2)
!          D2=ABS(D2)
!          D2=SQRT(D2)
!        ELSE                   !USE GAMA7 UNTIL REPLACED BY F2008 GAMMA
        D1=GAMA7(H1)
        D1=SQRT(D1)
        D2=GAMA7(H2)
        D2=ABS(D2)
        D2=SQRT(D2)
!        ENDIF
!
        D3=SQRT(ZNE)
        FN=DONE/(D1*D2*D3)
        IF(FN.EQ.DZERO)THEN             !OR NOT
          FN=DONE
          BNORM=.FALSE.
          WRITE(MW6,*)'FN.WHITEX: SHOULD BE USING LOG(GAMMA) HERE...'
          WRITE(MW0,*)'FN.WHITEX: SHOULD BE USING LOG(GAMMA) HERE...'
        ENDIF
        FN=LOG(FN)
!
      ENDIF
!
! FN=FN*EXP(-A)*(A+A)**GNU
!
  100 A=A*R
      TAP=-A+GNU*LOG(A+A)
      T0=FN+TAP
      T=T0+DIFF
      IF(ABS(T).GT.DEXP0)THEN
!t        bnorm=.false.
        T=SIGN(DEXP0/DTWO,T)
        IF(DIFF.NE.DZERO)THEN
          WRITE(MW6,*)'FN.WHITEX: INPUT DIFF INSUFFICIENT: ',DIFF,T-T0
          WRITE(MW0,*)'FN.WHITEX: INPUT DIFF INSUFFICIENT'
        ENDIF
        DIFF=T-T0
      ENDIF
      FN=EXP(T)
!
      A=DONE/(A+A)
!
! EXPAND TO A MAXIMUM OF IMAX TERMS:
!
!      IMAX=IMAX0                                          !HISTORIC =30
      ITERM=NINT(GNU-TL)
      IMAX=IMAX0+ITERM                        !IMAX0+INTEGER TERMINATION
!      IMAX=INT(GNU+GNU+D3HALF+A,SP)                              !BDCF3
!
! CONTINUE THE EXPANSION AS LONG AS ADDITIONAL TERMS BECOME SMALLER
! STOP THE EXPANSION WHEN ADDITIONAL TERMS BECOME VANISHINGLY SMALL.
!
      PS2=DONE
      SUMM=PS2
      AMAX=SUMM                                      !CANCELLATION CHECK
!
      DO I=1,IMAX
        PS1=PS2
        PS2=PS2*(DL-(GNU-I)*(GNU-I+1))*A/I     !HISTORICALLY MIS-ALIGNED
!        write(mw6,*)i,abs(ps2)/abs(ps1),summ
        IF(I.GT.ITERM.AND.ABS(PS2).GT.ABS(PS1))GO TO 200
                                                        !ELSE FALSE EXIT
        SUMM=SUMM+PS2
        AMAX=MAX(AMAX,ABS(SUMM))
        IF(ABS(PS2)/ABS(SUMM).LT.D1M10)GO TO 200
      ENDDO
!
! PRINT A WARNING IF EXPANSION EXHAUSTED
!
      IF(BNORM)WRITE(MW6,10010)
!
  200 CONTINUE
!
!      write(mw6,*)i,abs(ps2)/abs(ps1),summ
!      write(mw6,*)'need imax0=',i-iterm
!
      TA=ABS(SUMM/AMAX)
      IF(BNORM.AND.TA.LT.DEPS)THEN
        IF(TA.LT.DEPS/D100)WRITE(MW6,10020)R,amax,summ
!        SUMM=DONE
!a      ELSE
!aC        WRITE(MW6,*)'r=',R
      ENDIF
!
      WHITEX=FN*SUMM
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT('FN.WHITEX: EXPANSION TOO RESTRICTED')
10020 FORMAT('FN.WHITEX: POSSIBLE CANCELLATION ERROR AT R=',F12.3,1p,   &
     &       2E9.2)
!
!-----------------------------------------------------------------------
!
      END FUNCTION WHITEX
!
!***********************************************************************
!
! WIGNER 3N-J LIBRARY
!
!***********************************************************************
!
      SUBROUTINE WIG3JRJ(W3J,A2,A3,B2,B3,JMIN,JMAX,IH,NDIMW)
!
!-----------------------------------------------------------------------
!
! N. R. BADNELL                                                 02/12/21
!
! CALCULATES WIGNER 3-J SYMBOL ( A1 A2 A3 )
!                              ( B1 B2 B3 )
! FOR ALL ALLOWED A1 GIVEN BY JMIN+IH/2,...,JMAX+IH/2, WHERE IH=0 OR 1,
! VIA FORWARD AND BACKWARD RECURSION. OUTPUT IN W3J(J): J=JMIN,...,JMAX.
! VALUES LESS THAN DEPS1 *WITHIN THE CLASSICAL REGION* ARE SET TO ZERO.
! SEE E.G. A. R. EDMONDS "ANGULAR MOMENTUM IN QUANTUM MECHANICS" (1957).
!
! COMBINES THE ALGORITHMS (BUT NOT CODING) OF
! SCHULTEN K. AND GORDON R. G., 1975, J.MATH.PHYS., 16, 1961 AND 1971
!   AND
! LUSCOMBE J. H. AND LUBAN M., 1998, PHYS.REV.E, 57, 7274
! - SEE
! BADNELL N. R., GUZMAN F., BRODIE S., WILLIAMS R. J. R., VAN HOOF
! P. A. M., CHATZIKOS M., & FERLAND G. J., 2021 MNRAS, 507, 2922
!
! INPUT:
!  A2,A3,B2,B3: THE FOUR ARGUMENTS OF THE 3-J SYMBOL AS DEFINED ABOVE
!               USING THEIR ACTUAL VALUE, I.E. *NOT* TWICE  (REAL*8).
!  NDIMW: THE UPPER DIMENSION OF THE ARRAY W3J(-1:NDIMW+1) (INTEGER)
!         REQUIRED IS AT LEAST JMAX.
!
! OUTPUT:
!  JMIN,JMAX,IH: THE RANGE OF ARGUMENT OF THE 3-J SYMBOL (INTEGER)
!  W3J(JMIN+IH/2,JMAX+IH/2): 3-J SYMBOL FOR ALL POSSIBLE A1. (REAL*8).
!
!  JMIN.LT.0 FLAGS AN ERROR:
!         -1 NON-INTEGER TRIANGLE SUM.
!         -2 TRIANGLE RULE FAILURE.
!         -3 DIMENSION ERROR, JMAX THEN CONTAINS THE REQUIRED NDIMW.
!
! UPDATE LOG:
! 02/12/21 - OVERALL PHASE NOT DETERMINED WHEN A2-A3-B1(=B2+B3).LT.0
! 19/02/21 - INITIAL RELEASE
!
! BELOW IS THE WIG6JR LOG, ON WHICH WIG3JRJ WAS BASED
! 23/12/15 - PHASE WAS NOT DETERMINED IF W6J(JMAX)=0
! 11/12/15 - REMOVED TEMP ARRAY.
! 20/11/15 - INITIAL RELEASE.
!
!  IT IS CALLED BY:
!    FN.VCC
!
!  IT CALLS:
!
!  IT CONTAINS:
!    FN.A
!    FN.B
!    FN.X
!    FN.Y
!    FN.Z
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A-H,O-P,R-Z)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      logical(bp) debug0,debug1,debug2             !sync with standalone
!
      PARAMETER (DEPS1=1.E-16_WP)                           !REAL*8 ZERO
      PARAMETER (DEPS2=1.E-5_WP)
!
      PARAMETER (NDIMM=5)                       !MAX NO. MATCHING POINTS
!
      DIMENSION W3J(-1:NDIMW+1),W1(NDIMM),W2(NDIMM)
!
      data debug0/.false./,debug1/.true./,debug2/.true./
      data iwritd/-1/     !=0 to screen; set < 0 for non-interactive use
!
!-----------------------------------------------------------------------
!
!      A(A1)=SQRT(
!     &           (A1*A1-(A2-A3)*(A2-A3))*((A2+A3+1)*(A2+A3+1)-A1*A1)*
!     &           (A1*A1-(B2+B3)*(B2+B3))
!     &           )
!
!      B(A1)=(A1+A1+1)*(
!     &           (B2+B3)*(A2*(A2+1)-A3*(A3+1))-
!     &           (B2-B3)*A1*(A1+1)
!     &                 )
!
!      X(A1)=A1*A(A1+1)
!      Z(A1)=(A1+1)*A(A1)
!      Y(A1)=B(A1)
!
!-----------------------------------------------------------------------
!
      if(iwritd.lt.0)debug1=.false.
!
! CHECK 3J-SELECTION RULES (JMIN FLAGS FAILURE TYPE)
!
      W3J=0                                              !INITIALIZE ALL
      IH=0
      JMAX=-1
      B1=-B2-B3
!
      IF(NINT(A2+ABS(B2)-DEPS2).NE.NINT(A2+ABS(B2)+DEPS2).OR.           &
     &   NINT(A3+ABS(B3)-DEPS2).NE.NINT(A3+ABS(B3)+DEPS2))THEN
        if(debug2)then
          write(mw6,*)'*** sr.wig3jrj: non-integer triangle sum...'
          write(mw0,*)'*** sr.wig3jrj: non-integer triangle sum...'
        endif
        JMIN=-1
        RETURN
      ENDIF
      IF(ABS(B2).GT.A2+DEPS2.OR.ABS(B3).GT.A3+DEPS2)THEN
        if(debug2)then
          write(mw6,*)'*** sr.wig3jrj: triangle rule failure...'
          write(mw0,*)'*** sr.wig3jrj: triangle rule failure...'
        endif
        JMIN=-2
        RETURN
      ENDIF
!
! QUANTUM LIMITS
!
      J23M=NINT(ABS(A2-A3)-DEPS2)
      L23M=NINT(ABS(B1)-DEPS2)
      JMIN=MAX(J23M,L23M)
      JMAX=NINT(A2+A3-DEPS2)
      IF(J23M.NE.NINT(ABS(A2-A3)+DEPS2))THEN
        TH=DHALF
      ELSE
        TH=0
      ENDIF
      IH=NINT(2*TH)
      if(debug1)then
        write(iwritd,"(/' quantum range:  ',2f9.1)")jmin+th,jmax+th
      endif
!
! DIMENSION CHECK (IN CASE USER HAS CALLED WITH HARD-WIRED DIMENSION)
!
      IF(JMAX.GT.NDIMW)THEN
        JMIN=-3
        if(debug2)then
          write(mw6,*)'*** sr.wig3jrj: increase ndimw to ',jmax
          write(mw0,*)'*** sr.wig3jrj: increase ndimw to ',jmax
        endif
        RETURN
      ENDIF
!
! QUICK RETURN
!
      IF(JMIN.EQ.JMAX)THEN                                !GET FROM NORM
        W3J(JMIN)=1
        JMID1=JMIN
        JMD1M=JMID1-1
        JMID2=JMID1
        JMD2P=JMID2+1
        GO TO 200
      ENDIF
!
! DETERMINE NUMBER OF NODES (WOULD COUNT TO DETERMINE APPROACH TO
! CLASSICALLY FORBIDDEN REGION IF WE DID NOT HAVE THIS LIMIT.)
!
!      T=MIN(A2-B2,A3+B3)
!      NODES=NINT(T)
!
! CLASSICAL LIMITS (TRIANGLE A=0)
!
      C2=A2+DHALF
      C2=C2*C2
      C3=A3+DHALF
      C3=C3*C3
      C23=C2+C3
      D2=B2*B2
      D3=B3*B3
      D23=B2*B3
      C=SQRT((C2-D2)*(C3-D3))
      C1MIN=C23-DTWO*(C-D23)
      C1MIN=SQRT(C1MIN)-DHALF
      C1MAX=C23+DTWO*(C+D23)
      C1MAX=SQRT(C1MAX)-DHALF
      if(debug1)write(iwritd,"(' classical range:',2f9.1)")c1min,c1max
!
! MATCHINGS
!
      JMID1=INT(C1MIN+DEPS2)        !INT fallback -> JMID1=0 when JMIN=0
      JMID1=MAX(JMID1,JMIN)
      JMID1=MIN(JMID1,JMAX-1)
      JMD1M=JMID1-1
      JMID2=NINT(C1MAX+DEPS2)
      JMID2=MIN(JMID2,JMAX)
      JMID2=MAX(JMID2,JMIN+1)
      JMD2P=JMID2+1
!
      if(debug2.and.jmid1.gt.jmid2)then                !shouldn't happen
        write(mw6,*)'*** sr.wig3jrj: jmid1,2=',jmid1,jmid2,jmin,jmax
        stop '*** sr.wig3jrj: jmid1 .gt. jmid2'
      endif
!
      JMID=(JMID1+JMID2)/2
!t      jmid=jmid2-1                  !approx schulten & gordon matching
      JMID=MAX(JMID,JMIN)
      JMID=MIN(JMID,JMAX)
      NMATCH=1
!                                    .GT.2 COVERED BY ABOVE
      IF(JMID.GT.JMIN.AND.JMID.LT.JMAX.AND.JMAX-JMIN+1.GT.2)NMATCH=3
!                                     BUT NEED IF NMATCH.GT.3
      NMID=NMATCH/2-1
      JMID0=JMID-NMID-2
      IF(NMATCH.GT.NDIMM)THEN                  !ONLY IF USER INCREASES 3
        JMIN=-4
        JMAX=NMATCH
        if(debug2)then
          write(mw6,*)'*** sr.wig3jrj: increase ndimm to ',nmatch
          write(mw0,*)'*** sr.wig3jrj: increase ndimm to ',nmatch
        endif
        RETURN
      ENDIF
!
! BEGIN MAIN RECURSIONS
!
! FORWARD
!
      IF(JMIN+IH.EQ.0)THEN                             !CASE X(0)=0=Y(0)
        if(jmid1.ne.jmin)stop '*** sr.wig3jrj: jmin=0, jmid1>0...'
        JMID1=1
        JMD1M=JMID1-1
!
        A1=2*SQRT(A2*(A2+1))                           !A1=X(J)/J AT J=0
        B00=-2*B2                                     !B00=Y(J)/J AT J=0
!
        W3J(JMIN)=1
        W3J(JMIN+1)=-W3J(JMIN)*B00/A1                !3-TERM all the way
        go to 100
!
!2        W3J(JMIN)=-A1/B00                             !2-TERM one step
!
! or could go backward all the way to zero, since c1min=0 here
!b        write(0,*)'going backwards'
!b        jmid=jmin
!b        nmatch=1
!b        nmid=-1
!b        jmid0=jmin-1
!b        w1(1)=1
!b        go to 200
      ELSEIF(JMID1.GT.JMIN)THEN
        T=TH+JMIN
        W3J(JMIN)=-X(T)/Y(T)
      ENDIF
!
! 2-TERM
!      W3J(JMIN-1)=0                                 !NOT USED CURRENTLY
      DO J=JMIN+1,JMD1M
        T=TH+J
        W3J(J)=-X(T)/(Y(T)+Z(T)*W3J(J-1))
      ENDDO
!
      W3J(JMID1)=1
      DO J=JMD1M,JMIN,-1
        W3J(J)=W3J(J+1)*W3J(J)
      ENDDO
!
! 3-TERM
  100 continue
      DO J=JMID1,JMID+NMID
        T=TH+J
        W3J(J+1)=-(Y(T)*W3J(J)+Z(T)*W3J(J-1))/X(T)
      ENDDO
!
      J=JMID0
      DO N=1,NMATCH
        J=J+1
        W1(N)=W3J(J)
      ENDDO
!
! BACKWARD
!
! 2-TERM
!b 200  continue
      W3J(JMAX+1)=0
      DO J=JMAX,JMD2P,-1
        T=TH+J
        W3J(J)=-Z(T)/(Y(T)+X(T)*W3J(J+1))
      ENDDO
!
      jsign=1
      W3J(JMID2)=1
      DO J=JMD2P,JMAX
        jsign=jsign*nint(sign(done,w3j(j)))
                                           !case w3j(jmax)=0 (underflow)
        W3J(J)=W3J(J-1)*W3J(J)
      ENDDO
!
! 3-TERM
      DO J=JMID2,JMID-NMID,-1
        T=TH+J
        W3J(J-1)=-(Y(T)*W3J(J)+X(T)*W3J(J+1))/Z(T)
      ENDDO
!
      J=JMID0
      DO N=1,NMATCH
        J=J+1
        W2(N)=W3J(J)
      ENDDO
!
! RELATIVE NORM
!
      T12=0
      T11=0
      DO N=1,NMATCH
        T12=T12+W1(N)*W2(N)
        T11=T11+W1(N)*W1(N)
      ENDDO
      WMATCH=T12/T11
      if(debug0)then
        write(iwritd,"(' jmatch=',i6,'  wmatch=',f7.1)")jmid,wmatch
      endif
      DO J=JMIN,JMID0
        W3J(J)=W3J(J)*WMATCH
      ENDDO
!
! PHASE
!
  200 ISIGN=NINT(A2-A3+B2+B3)
      ISIGN=MOD(ISIGN,ITWO)
      ISIGN=-2*ABS(ISIGN)+1
!
      T=ISIGN*W3J(JMAX)
      IF(T.GT.DZERO)THEN
        ISIGN=1
      ELSEIF(T.LT.DZERO)THEN
        ISIGN=-1
      ELSE
!p        if(debug2)write(*,*)'***sr.wig3jrj: unable to determine phase'
!p        jmin=-5
!p        return
        isign=isign*jsign
      ENDIF
!
! ABSOLUTE NORM
!
      IHP=IH+1
      SUM=0
      DO J=JMIN,JMAX
        SUM=SUM+(J+J+IHP)*W3J(J)*W3J(J)
      ENDDO
!
      SUM=DONE/SQRT(SUM)
      SUM=SUM*ISIGN
      if(debug0)write(iwritd,"(' wnorm=',1pe10.2)")sum
!
! some test code
!      so=sign(done,w3j(jmin))
!      nod=0
!      wmax=0
!      do j=jmin,jmax
!        if(so*w3j(j).lt.dzero)then
!          so=-so
!          nod=nod+1
!        endif
!        wmax=max(wmax,abs(w3j(j)))
!      enddo
!      if(nod.ne.nodes)write(*,*)'nodes expected/found=',nodes,nod
!      write(*,*)'wmax=',wmax                               !order unity
!
      DO J=JMIN,JMD1M
        W3J(J)=W3J(J)*SUM
      ENDDO
      DO J=JMID1,JMID2
        T=W3J(J)*SUM
        IF(ABS(T).LT.DEPS1)T=DZERO                        !*wmax ZEROIZE
        W3J(J)=T
      ENDDO
      DO J=JMD2P,JMAX
        W3J(J)=W3J(J)*SUM
      ENDDO
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION A(A1)
!
      A=SQRT((A1*A1-(A2-A3)*(A2-A3))*((A2+A3+1)*(A2+A3+1)-A1*A1)        &
     &  *(A1*A1-(B2+B3)*(B2+B3)))
!
      END FUNCTION A
!-----------------------------------------------------------------------
      FUNCTION B(A1)
!
      B=(A1+A1+1)*((B2+B3)*(A2*(A2+1)-A3*(A3+1))-(B2-B3)*A1*(A1+1))
!
      END FUNCTION B
!-----------------------------------------------------------------------
      FUNCTION X(A1)
!
      X=A1*A(A1+1)
!
      END FUNCTION X
!-----------------------------------------------------------------------
      FUNCTION Z(A1)
!
      Z=(A1+1)*A(A1)
!
      END FUNCTION Z
!-----------------------------------------------------------------------
      FUNCTION Y(A1)
!
      Y=B(A1)
!
      END FUNCTION Y
!-----------------------------------------------------------------------
!
      END SUBROUTINE WIG3JRJ
!
!***********************************************************************
!
!                             *******************
!
      SUBROUTINE WIG3JRM(W3J,A1,A2,A3,B1,JMIN,JMAX,IH,NDIMW)
!
!-----------------------------------------------------------------------
!
! N. R. BADNELL                                                 02/12/21
!
! CALCULATES WIGNER 3-J SYMBOL ( A1 A2 A3 )
!                              ( B1 B2 B3 )
! FOR ALL ALLOWED B2 GIVEN BY JMIN+IH/2,...,JMAX+IH/2, WHERE IH=0 OR 1,
! VIA FORWARD AND BACKWARD RECURSION. OUTPUT IN W3J(J): J=JMIN,...,JMAX.
! VALUES LESS THAN DEPS1 *WITHIN THE CLASSICAL REGION* ARE SET TO ZERO.
! SEE E.G. A. R. EDMONDS "ANGULAR MOMENTUM IN QUANTUM MECHANICS" (1957).
!
! COMBINES THE ALGORITHMS (BUT NOT CODING) OF
! SCHULTEN K. AND GORDON R. G., 1975, J.MATH.PHYS., 16, 1961 AND 1971
!   AND
! LUSCOMBE J. H. AND LUBAN M., 1998, PHYS.REV.E, 57, 7274
! - SEE
! BADNELL N. R., GUZMAN F., BRODIE S., WILLIAMS R. J. R., VAN HOOF
! P. A. M., CHATZIKOS M., & FERLAND G. J., 2021 MNRAS, 507, 2922
!
! INPUT:
!  A1,A2,A3,B1: THE FOUR ARGUMENTS OF THE 3-J SYMBOL AS DEFINED ABOVE
!               USING THEIR ACTUAL VALUE, I.E. *NOT* TWICE  (REAL*8).
!  NDIMW: THE DIMENSION OF THE ARRAY W3J(-1-NDIMW:NDIMW+1) (INTEGER).
!         REQUIRED IS AT LEAST MAX(JMAX,|JMIN|).
!
! OUTPUT:
!  JMIN,JMAX,IH: THE RANGE OF ARGUMENT OF THE 3-J SYMBOL (INTEGER)
!  W3J(JMIN+IH/2,JMAX+IH/2): 3-J SYMBOL FOR ALL POSSIBLE B2. (REAL*8).
!
!  JMIN.GT.JMAX FLAGS AN ERROR, THEN JMIN=
!         -1 NON-INTEGER TRIANGLE SUM.
!         -2 TRIANGLE RULE FAILURE.
!         -3 DIMENSION ERROR, -JMAX THEN CONTAINS THE REQUIRED NDIMW.
!
! UPDATE LOG:
! 02/12/21 - OVERALL PHASE NOT DETERMINED WHEN A2-A3-B1(=B2+B3).LT.0
! 19/02/21 - INITIAL RELEASE
!
! BELOW IS THE WIG6JR LOG, ON WHICH WIG3JRM WAS BASED
! 23/12/15 - PHASE WAS NOT DETERMINED IF W6J(JMAX)=0
! 11/12/15 - REMOVED TEMP ARRAY.
! 20/11/15 - INITIAL RELEASE.
!
!  IT IS CALLED BY:
!    FN.VCC
!
!  IT CALLS:
!
!  IT CONTAINS:
!    FN.C
!    FN.D
!    FN.X
!    FN.Y
!    FN.Z
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A-H,O-P,R-Z)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      logical(bp) debug0,debug1,debug2             !sync with standalone
!
      PARAMETER (DEPS1=1.E-16_WP)                           !REAL*8 ZERO
      PARAMETER (DEPS2=1.E-5_WP)
!
      PARAMETER (NDIMM=5)                       !MAX NO. MATCHING POINTS
!
      DIMENSION W3J(-1-NDIMW:NDIMW+1),W1(NDIMM),W2(NDIMM)
!
      data debug0/.false./,debug1/.true./,debug2/.true./
      data iwritd/-1/     !=0 to screen; set < 0 for non-interactive use
!
!-----------------------------------------------------------------------
!
!      C(B2)=SQRT(
!     &           (A2-B2+1)*(A2+B2)*(A3-B2-B1+1)*(A3+B2+B1)
!     &           )
!
!      D(B2)=A2*(A2+1)+A3*(A3+1)-A1*(A1+1)-(B2+B2)*(B2+B1)
!
!      X(B2)=C(B2+1)
!      Z(B2)=C(B2)
!      Y(B2)=D(B2)
!
!-----------------------------------------------------------------------
!
      if(iwritd.lt.0)debug1=.false.
!
! CHECK 3J-SELECTION RULES (JMIN FLAGS FAILURE TYPE)
!
      W3J=0                                              !INITIALIZE ALL
      IH=0
      JMAX=-4
!
      IF(NINT(A1+A2+A3-DEPS2).NE.NINT(A1+A2+A3+DEPS2).OR.               &
     &   NINT(A1+ABS(B1)-DEPS2).NE.NINT(A1+ABS(B1)+DEPS2))THEN
        if(debug2)then
          write(mw6,*)'*** sr.wig3jrm: non-integer triangle sum...'
          write(mw0,*)'*** sr.wig3jrm: non-integer triangle sum...'
        endif
        JMIN=-1
        RETURN
      ENDIF
      IF(ABS(B1).GT.A1+DEPS2.OR.A1.GT.A2+A3+DEPS2.OR.                   &
     &   A2.GT.A1+A3+DEPS2.OR.A3.GT.A1+A2+DEPS2)THEN
        if(debug2)then
          write(mw6,*)'*** sr.wig3jrm: triangle rule failure...'
          write(mw0,*)'*** sr.wig3jrm: triangle rule failure...'
        endif
        JMIN=-2
        RETURN
      ENDIF
!
! QUANTUM LIMITS
!
      J31M=NINT(-A3-B1-DEPS2)
      J31P=NINT(A3-B1-DEPS2)
      J2M=NINT(-A2-DEPS2)
      J2P=NINT(A2-DEPS2)
      JMIN=MAX(J2M,J31M)
      JMAX=MIN(J2P,J31P)
      IF(NINT(A2-DEPS2).NE.NINT(A2+DEPS2))THEN
        TH=DHALF
      ELSE
        TH=0
      ENDIF
      IH=NINT(2*TH)
      if(debug1)then
        write(iwritd,"(/' quantum range:  ',2f9.1)")jmin+th,jmax+th
      endif
!
! DIMENSION CHECK (IN CASE USER HAS CALLED WITH HARD-WIRED DIMENSION)
!
      IF(JMAX.GT.NDIMW)THEN
        JMIN=-3
        JMAX=JMAX+1
        if(debug2)then
          write(mw6,*)'*** sr.wig3jrm: increase ndimw to ',jmax
          write(mw0,*)'*** sr.wig3jrm: increase ndimw to ',jmax
        endif
        jmax=-jmax
        RETURN
      ENDIF
      IF(JMIN.LT.-NDIMW)THEN
        JMAX=-JMIN
        JMIN=-3
        if(debug2)then
          write(mw6,*)'*** sr.wig3jrm: increase ndimw to ',jmax
          write(mw0,*)'*** sr.wig3jrm: increase ndimw to ',jmax
        endif
        jmax=-jmax
        RETURN
      ENDIF
!
! QUICK RETURN
!
      IF(JMIN.EQ.JMAX)THEN                                !GET FROM NORM
        W3J(JMIN)=1
        JMID1=JMIN
        JMD1M=JMID1-1
        JMID2=JMID1
        JMD2P=JMID2+1
        GO TO 200
      ENDIF
!
! DETERMINE NUMBER OF NODES (WOULD COUNT TO DETERMINE APPROACH TO
! CLASSICALLY FORBIDDEN REGION IF WE DID NOT HAVE THIS LIMIT.)
!
!      NODES=NINT(A2+A3-A1)
!
! CLASSICAL LIMITS (TRIANGLE A=0)
!
      C1=A1+DHALF
      C1=C1*C1
      C2=A2+DHALF
      C2=C2*C2
      C3=A3+DHALF
      C3=C3*C3
      C123=C1+C2-C3
      D1=B1*B1
      E=(C1-D1)*(DFOUR*C1*C2-C123*C123)
      E=SQRT(E)
      E1=-B1*C123
      E2=C1+C1
      C1MIN=(E1-E)/E2
      C1MAX=(E1+E)/E2
      if(debug1)write(iwritd,"(' classical range:',2f9.1)")c1min,c1max
!
! MATCHINGS
!
      JMID1=INT(C1MIN+DEPS2)        !INT fallback -> JMID1=0 when JMIN=0
      JMID1=MAX(JMID1,JMIN)
      JMID1=MIN(JMID1,JMAX-1)
      JMD1M=JMID1-1
      JMID2=NINT(C1MAX+DEPS2)
      JMID2=MIN(JMID2,JMAX)
      JMID2=MAX(JMID2,JMIN+1)
      JMD2P=JMID2+1
!
      if(debug2.and.jmid1.gt.jmid2)then                !shouldn't happen
        write(mw6,*)'*** sr.wig3jrm: jmid1,2=',jmid1,jmid2,jmin,jmax
        stop '*** sr.wig3jrm: jmid1 .gt. jmid2'
      endif
!
      JMID=(JMID1+JMID2)/2
!t      jmid=jmid2-1                  !approx schulten & gordon matching
      JMID=MAX(JMID,JMIN)
      JMID=MIN(JMID,JMAX)
      NMATCH=1
!                                    .GT.2 COVERED BY ABOVE
      IF(JMID.GT.JMIN.AND.JMID.LT.JMAX.AND.JMAX-JMIN+1.GT.2)NMATCH=3
!                                     BUT NEED IF NMATCH.GT.3
      NMID=NMATCH/2-1
      JMID0=JMID-NMID-2
      IF(NMATCH.GT.NDIMM)THEN                  !ONLY IF USER INCREASES 3
        JMIN=-4
        JMAX=NMATCH
        if(debug2)then
          write(mw6,*)'*** sr.wig3jrm: increase ndimm to ',nmatch
          write(mw0,*)'*** sr.wig3jrm: increase ndimm to ',nmatch
        endif
        RETURN
      ENDIF
!
! BEGIN MAIN RECURSIONS
!
! FORWARD
!
      IF(ABS(JMIN)+IH.EQ.0)THEN
!
        Y0=Y(DZERO)
!
! can have Y(0)=0 but X(0).ne.0 (as W3J(1)=0) so use 3-term all the eway
!
        IF(ABS(Y0).LT.DEPS1)THEN
!
!          if(jmid1.ne.jmin)then               !for info
!            write(mw6,*)'*** sr.wig3jrm: jmin=0, jmid1,2=',jmid1,jmid2
!!            write(mw6,*)' a1,a2,a3,b1=',A1,A2,A3,B1
!          endif
!
          JMID1=1
          JMD1M=JMID1-1
!
          W3J(JMIN)=1
          W3J(JMIN+1)=-W3J(JMIN)*Y0/X(DZERO)       !CAN TEST FOR Y0.NE.0
          go to 100
!
! or could go backward all the way to zero, if c1min=0 here
!b          write(0,*)'going backwards'
!b          jmid=jmin
!b          nmatch=1
!b          nmid=-1
!b          jmid0=jmin-1
!b          w1(1)=1
!b          go to 200
!
!       ELSE 2-TERM IS FINE STILL & SAFER FOR A TURNING POINT .GT. JMIN
!
        ENDIF
!
      ENDIF
!
      IF(JMID1.GT.JMIN)THEN
        T=TH+JMIN
        W3J(JMIN)=-X(T)/Y(T)
      ENDIF
!
! 2-TERM
!      W3J(JMIN-1)=0                                 !NOT USED CURRENTLY
      DO J=JMIN+1,JMD1M
        T=TH+J
        W3J(J)=-X(T)/(Y(T)+Z(T)*W3J(J-1))
      ENDDO
!
      W3J(JMID1)=1
      DO J=JMD1M,JMIN,-1
        W3J(J)=W3J(J+1)*W3J(J)
      ENDDO
!
! 3-TERM
  100 continue
      DO J=JMID1,JMID+NMID
        T=TH+J
        W3J(J+1)=-(Y(T)*W3J(J)+Z(T)*W3J(J-1))/X(T)
      ENDDO
!
      J=JMID0
      DO N=1,NMATCH
        J=J+1
        W1(N)=W3J(J)
      ENDDO
!
! BACKWARD
!
! 2-TERM
!b 200  continue
      W3J(JMAX+1)=0
      DO J=JMAX,JMD2P,-1
        T=TH+J
        W3J(J)=-Z(T)/(Y(T)+X(T)*W3J(J+1))
      ENDDO
!
      jsign=1
      W3J(JMID2)=1
      DO J=JMD2P,JMAX
        jsign=jsign*nint(sign(done,w3j(j)))
                                           !case w3j(jmax)=0 (underflow)
        W3J(J)=W3J(J-1)*W3J(J)
      ENDDO
!
! 3-TERM
      DO J=JMID2,JMID-NMID,-1
        T=TH+J
        W3J(J-1)=-(Y(T)*W3J(J)+X(T)*W3J(J+1))/Z(T)
      ENDDO
!
      J=JMID0
      DO N=1,NMATCH
        J=J+1
        W2(N)=W3J(J)
      ENDDO
!
! RELATIVE NORM
!
      T12=0
      T11=0
      DO N=1,NMATCH
        T12=T12+W1(N)*W2(N)
        T11=T11+W1(N)*W1(N)
      ENDDO
      WMATCH=T12/T11
      if(debug0)then
        write(iwritd,"(' jmatch=',i6,'  wmatch=',f7.1)")jmid,wmatch
      endif
      DO J=JMIN,JMID0
        W3J(J)=W3J(J)*WMATCH
      ENDDO
!
! PHASE
!
  200 ISIGN=NINT(A2-A3-B1)
      ISIGN=MOD(ISIGN,ITWO)
      ISIGN=-2*ABS(ISIGN)+1
!
      T=ISIGN*W3J(JMAX)
      IF(T.GT.DZERO)THEN
        ISIGN=1
      ELSEIF(T.LT.DZERO)THEN
        ISIGN=-1
      ELSE
!p        if(debug2)write(*,*)'***sr.wig3jrm: unable to determine phase'
!p        jmin=-5
!p        return
        isign=isign*jsign
      ENDIF
!
! ABSOLUTE NORM
!
      SUM=0
      DO J=JMIN,JMAX
        SUM=SUM+W3J(J)*W3J(J)
      ENDDO
      SUM=SUM*(A1+A1+1)
!
      SUM=DONE/SQRT(SUM)
      SUM=SUM*ISIGN
      if(debug0)write(iwritd,"(' wnorm=',1pe10.2)")sum
!
! some test code
!      so=sign(done,w3j(jmin))
!      nod=0
!      wmax=0
!      do j=jmin,jmax
!        if(so*w3j(j).lt.dzero)then
!          so=-so
!          nod=nod+1
!        endif
!        wmax=max(wmax,abs(w3j(j)))
!      enddo
!      if(nod.ne.nodes)write(*,*)'nodes expected/found=',nodes,nod
!      write(*,*)'wmax=',wmax                               !order unity
!
      DO J=JMIN,JMD1M
        W3J(J)=W3J(J)*SUM
      ENDDO
      DO J=JMID1,JMID2
        T=W3J(J)*SUM
        IF(ABS(T).LT.DEPS1)T=DZERO                        !*wmax ZEROIZE
        W3J(J)=T
      ENDDO
      DO J=JMD2P,JMAX
        W3J(J)=W3J(J)*SUM
      ENDDO
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION C(B2)
!
      C=SQRT((A2-B2+1)*(A2+B2)*(A3-B2-B1+1)*(A3+B2+B1))
!
      END FUNCTION C
!-----------------------------------------------------------------------
      FUNCTION D(B2)
!
      D=A2*(A2+1)+A3*(A3+1)-A1*(A1+1)-(B2+B2)*(B2+B1)
!
      END FUNCTION D
!-----------------------------------------------------------------------
      FUNCTION X(B2)
!
      X=C(B2+1)
!
      END FUNCTION X
!-----------------------------------------------------------------------
      FUNCTION Z(B2)
!
      Z=C(B2)
!
      END FUNCTION Z
!-----------------------------------------------------------------------
      FUNCTION Y(B2)
!
      Y=D(B2)
!
      END FUNCTION Y
!-----------------------------------------------------------------------
!
      END SUBROUTINE WIG3JRM
!
!                             *******************
!
      SUBROUTINE WIG6JR(W6J,A2,A3,B1,B2,B3,JMIN,JMAX,IH,NDIMW)
!
!-----------------------------------------------------------------------
!
! N. R. BADNELL                                                 19/02/21
!
! CALCULATES WIGNER 6-J SYMBOL ( A1 A2 A3 )
!                              ( B1 B2 B3 )
! FOR ALL ALLOWED A1 GIVEN BY JMIN+IH/2,...,JMAX+IH/2, WHERE IH=0 OR 1,
! VIA FORWARD AND BACKWARD RECURSION. OUTPUT IN W6J(J): J=JMIN,...,JMAX.
! VALUES LESS THAN DEPS1 *WITHIN THE CLASSICAL REGION* ARE SET TO ZERO.
! SEE E.G. A. R. EDMONDS "ANGULAR MOMENTUM IN QUANTUM MECHANICS" (1957).
!
! COMBINES THE ALGORITHMS (BUT NOT CODING) OF
! SCHULTEN K. AND GORDON R. G., 1975, J.MATH.PHYS., 16, 1961 AND 1971
!   AND
! LUSCOMBE J. H. AND LUBAN M., 1998, PHYS.REV.E, 57, 7274
! - SEE
! BADNELL N. R., GUZMAN F., BRODIE S., WILLIAMS R. J. R., VAN HOOF
! P. A. M., CHATZIKOS M., & FERLAND G. J., 2021 MNRAS, 507, 2922
!
! INPUT:
!  A2,A3,B1,B2,B3: THE FIVE ARGUMENTS OF THE 6-J SYMBOL AS DEFINED ABOVE
!                  USING THEIR ACTUAL VALUE, I.E. *NOT* TWICE  (REAL*8).
!  NDIMW: THE UPPER DIMENSION OF THE ARRAY W6J(-1:NDIMW+1) (INTEGER)
!         REQUIRED IS AT LEAST JMAX.
!
! OUTPUT:
!  JMIN,JMAX,IH: THE RANGE OF ARGUMENT OF THE 6-J SYMBOL (INTEGER)
!  W6J(JMIN+IH/2,JMAX+IH/2): 6-J SYMBOL FOR ALL POSSIBLE A1. (REAL*8)
!
!  JMIN.LT.0 FLAGS AN ERROR:
!         -1 NON-INTEGER TRIANGLE SUM.
!         -2 TRIANGLE RULE FAILURE.
!         -3 DIMENSION ERROR, JMAX THEN CONTAINS THE REQUIRED NDIMW.
!
! UPDATE LOG:
! 23/12/15 - PHASE WAS NOT DETERMINED IF W6J(JMAX)=0
! 11/12/15 - REMOVED TEMP ARRAY.
! 20/11/15 - INITIAL RELEASE.
!
!  IT IS CALLED BY:
!    FN.SJS
!    SR.WIG9J
!
!  IT CALLS:
!
!  IT CONTAINS:
!    FN.E
!    FN.F
!    FN.X
!    FN.Y
!    FN.Z
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A-H,O-P,R-Z)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      logical(bp) debug0,debug1,debug2             !sync with standalone
!
      PARAMETER (DEPS1=1.E-16_WP)                           !REAL*8 ZERO
      PARAMETER (DEPS2=1.E-5_WP)
!
      PARAMETER (NDIMM=5)                       !MAX NO. MATCHING POINTS
!
      DIMENSION W6J(-1:NDIMW+1),W1(NDIMM),W2(NDIMM)
!
      data debug0/.false./,debug1/.true./,debug2/.true./
      data iwritd/-1/     !=0 to screen; set < 0 for non-interactive use
!
!-----------------------------------------------------------------------
!
!      E(A1)=SQRT(
!     &           (A1*A1-(A2-A3)*(A2-A3))*((A2+A3+1)*(A2+A3+1)-A1*A1)*
!     &           (A1*A1-(B2-B3)*(B2-B3))*((B2+B3+1)*(B2+B3+1)-A1*A1)
!     &           )
!
!      F(A1)=(A1+A1+1)*(
!     &           A1*(A1+1)*(-A1*(A1+1)+A2*(A2+1)+A3*(A3+1)-2*B1*(B1+1))
!     &          *B2*(B2+1)*(A1*(A1+1)+A2*(A2+1)-A3*(A3+1))+B3*(B3+1)*
!     &          (A1*(A1+1)-A2*(A2+1)+A3*(A3+1))
!     &                 )
!
!      X(A1)=A1*E(A1+1)
!      Z(A1)=(A1+1)*E(A1)
!      Y(A1)=F(A1)
!
!-----------------------------------------------------------------------
!
      if(iwritd.lt.0)debug1=.false.
!
! CHECK 6J-SELECTION RULES (JMIN FLAGS FAILURE TYPE)
!
      W6J=0                                              !INITIALIZE ALL
      IH=0
      JMAX=-1
!
      IF(NINT(A2+B1+B3-DEPS2).NE.NINT(A2+B1+B3+DEPS2).OR.               &
     &   NINT(A3+B1+B2-DEPS2).NE.NINT(A3+B1+B2+DEPS2))THEN
        if(debug2)then
          write(mw6,*)'*** sr.wig6jr: non-integer triangle sum...'
          write(mw0,*)'*** sr.wig6jr: non-integer triangle sum...'
        endif
        JMIN=-1
        RETURN
      ENDIF
      IF(B3.GT.A2+B1+DEPS2.OR.B3.LT.ABS(A2-B1)-DEPS2.OR.                &
     &   B2.GT.A3+B1+DEPS2.OR.B2.LT.ABS(A3-B1)-DEPS2)THEN
        if(debug2)then
          write(mw6,*)'*** sr.wig6jr: triangle rule failure...'
          write(mw0,*)'*** sr.wig6jr: triangle rule failure...'
        endif
        JMIN=-2
        RETURN
      ENDIF
!
! QUANTUM LIMITS
!
      J23M=NINT(ABS(A2-A3)-DEPS2)
      L23M=NINT(ABS(B2-B3)-DEPS2)
      JMIN=MAX(J23M,L23M)
      J23P=NINT(A2+A3-DEPS2)
      L23P=NINT(B2+B3-DEPS2)
      JMAX=MIN(J23P,L23P)
      IF(J23P.NE.NINT(A2+A3+DEPS2))THEN
        TH=DHALF
      ELSE
        TH=0
      ENDIF
      IH=NINT(2*TH)
      if(debug1)then
        write(iwritd,"(/' quantum range:  ',2f9.1)")jmin+th,jmax+th
      endif
!
! DIMENSION CHECK (IN CASE USER HAS CALLED WITH HARD-WIRED DIMENSION)
!
      IF(JMAX.GT.NDIMW)THEN
        JMIN=-3
        if(debug2)then
          write(mw6,*)'*** sr.wig6jr: increase ndimw to ',jmax
          write(mw0,*)'*** sr.wig6jr: increase ndimw to ',jmax
        endif
        RETURN
      ENDIF
!
! QUICK RETURN
!
      IF(JMIN.EQ.JMAX)THEN                                !GET FROM NORM
        W6J(JMIN)=1
        JMID1=JMIN
        JMD1M=JMID1-1
        JMID2=JMID1
        JMD2P=JMID2+1
        GO TO 200
      ENDIF
!
! DETERMINE NUMBER OF NODES (WOULD COUNT TO DETERMINE APPROACH TO
! CLASSICALLY FORBIDDEN REGION IF WE DID NOT HAVE THIS LIMIT.)
!
!      T=MIN(A2+B3,A3+B2)
!      NODES=NINT(T-B1)
!
! CLASSICAL LIMITS (TETRAHEDRON V=0)
!
      C2=A2+DHALF
      C2=C2*C2
      C3=A3+DHALF
      C3=C3*C3
      D1=B1+DHALF
      D1=D1*D1
      D2=B2+DHALF
      D2=D2*D2
      D3=B3+DHALF
      D3=D3*D3
      A=-D1
      B=D1*(D2+C3-D1)+C2*(D1+D2-C3)+D3*(D1-D2+C3)
      C=D3*C2*(C3+D2-D1)+D2*C3*(C2+D3-D1)-D3*C3*(C3+D3-D1)              &
     &  -D2*C2*(C2+D2-D1)
      B=B/(A+A)
      C=C/A
      D=SQRT(B*B-C)
      C1MIN=MAX(DZERO,-B-D)
      C1MIN=SQRT(C1MIN)-DHALF
      C1MAX=MAX(DZERO,-B+D)
      C1MAX=SQRT(C1MAX)-DHALF
      if(debug1)write(iwritd,"(' classical range:',2f9.1)")c1min,c1max
!
! MATCHINGS
!
      JMID1=INT(C1MIN+DEPS2)        !INT fallback -> JMID1=0 when JMIN=0
      JMID1=MAX(JMID1,JMIN)
      JMID1=MIN(JMID1,JMAX-1)
      JMD1M=JMID1-1
      JMID2=NINT(C1MAX+DEPS2)
      JMID2=MIN(JMID2,JMAX)
      JMID2=MAX(JMID2,JMIN+1)
      JMD2P=JMID2+1
!
      if(debug2.and.jmid1.gt.jmid2)then                !shouldn't happen
        write(mw6,*)'*** sr.wig6jr: jmid1,2=',jmid1,jmid2,jmin,jmax
        stop '*** sr.wig6jr: jmid1 .gt. jmid2'
      endif
!
      JMID=(JMID1+JMID2)/2
!t      jmid=jmid2-1                  !approx schulten & gordon matching
      JMID=MAX(JMID,JMIN)
      JMID=MIN(JMID,JMAX)
      NMATCH=1
!                                    .GT.2 COVERED BY ABOVE
      IF(JMID.GT.JMIN.AND.JMID.LT.JMAX.AND.JMAX-JMIN+1.GT.2)NMATCH=3
!                                     BUT NEED IF NMATCH.GT.3
      NMID=NMATCH/2-1
      JMID0=JMID-NMID-2
      IF(NMATCH.GT.NDIMM)THEN                  !ONLY IF USER INCREASES 3
        JMIN=-4
        JMAX=NMATCH
        if(debug2)then
          write(mw6,*)'*** sr.wig6jr: increase ndimm to ',nmatch
          write(mw0,*)'*** sr.wig6jr: increase ndimm to ',nmatch
        endif
        RETURN
      ENDIF
!
! BEGIN MAIN RECURSIONS
!
! FORWARD
      IF(JMIN+IH.EQ.0)THEN                             !CASE X(0)=0=Y(0)
        if(jmid1.ne.jmin)stop '*** sr.wig6jr: jmin=0, jmid1>0...'
        JMID1=1
        JMD1M=JMID1-1
!
        E1=4*SQRT(A2*(A2+1)*B2*(B2+1))                 !E1=X(J)/J AT J=0
        F00=2*(A2*(A2+1)+B2*(B2+1)-B1*(B1+1))         !F00=Y(J)/J AT J=0
!
        W6J(JMIN)=1
        W6J(JMIN+1)=-W6J(JMIN)*F00/E1                !3-TERM all the way
        go to 100
!
!2        W6J(JMIN)=-E1/F00                             !2-TERM one step
!
! or could go backward all the way to zero, since c1min=0 here
!b        write(0,*)'going backwards'
!b        jmid=jmin
!b        nmatch=1
!b        nmid=-1
!b        jmid0=jmin-1
!b        w1(1)=1
!b        go to 200
      ELSEIF(JMID1.GT.JMIN)THEN
        T=TH+JMIN
        W6J(JMIN)=-X(T)/Y(T)
      ENDIF
!
! 2-TERM
!      W6J(JMIN-1)=0                                 !NOT USED CURRENTLY
      DO J=JMIN+1,JMD1M
        T=TH+J
        W6J(J)=-X(T)/(Y(T)+Z(T)*W6J(J-1))
      ENDDO
!
      W6J(JMID1)=1
      DO J=JMD1M,JMIN,-1
        W6J(J)=W6J(J+1)*W6J(J)
      ENDDO
!
! 3-TERM
  100 continue
      DO J=JMID1,JMID+NMID
        T=TH+J
        W6J(J+1)=-(Y(T)*W6J(J)+Z(T)*W6J(J-1))/X(T)
      ENDDO
!
      J=JMID0
      DO N=1,NMATCH
        J=J+1
        W1(N)=W6J(J)
      ENDDO
!
! BACKWARD
!
! 2-TERM
!b 200  continue
      W6J(JMAX+1)=0
      DO J=JMAX,JMD2P,-1
        T=TH+J
        W6J(J)=-Z(T)/(Y(T)+X(T)*W6J(J+1))
      ENDDO
!
      jsign=1
      W6J(JMID2)=1
      DO J=JMD2P,JMAX
        jsign=jsign*nint(sign(done,w6j(j)))
                                           !case w6j(jmax)=0 (underflow)
        W6J(J)=W6J(J-1)*W6J(J)
      ENDDO
!
! 3-TERM
      DO J=JMID2,JMID-NMID,-1
        T=TH+J
        W6J(J-1)=-(Y(T)*W6J(J)+X(T)*W6J(J+1))/Z(T)
      ENDDO
!
      J=JMID0
      DO N=1,NMATCH
        J=J+1
        W2(N)=W6J(J)
      ENDDO
!
! RELATIVE NORM
!
      T12=0
      T11=0
      DO N=1,NMATCH
        T12=T12+W1(N)*W2(N)
        T11=T11+W1(N)*W1(N)
      ENDDO
      WMATCH=T12/T11
      if(debug0)then
        write(iwritd,"(' jmatch=',i6,'  wmatch=',f7.1)")jmid,wmatch
      endif
      DO J=JMIN,JMID0
        W6J(J)=W6J(J)*WMATCH
      ENDDO
!
! PHASE
!
  200 ISIGN=NINT(A2+A3+B2+B3)
      ISIGN=MOD(ISIGN,ITWO)
      ISIGN=-2*ISIGN+1
!
      T=ISIGN*W6J(JMAX)
      IF(T.GT.DZERO)THEN
        ISIGN=1
      ELSEIF(T.LT.DZERO)THEN
        ISIGN=-1
      ELSE
!p        if(debug2)write(*,*)'*** sr.wig6jr: unable to determine phase'
!p        jmin=-5
!p        return
        isign=isign*jsign
      ENDIF
!
! ABSOLUTE NORM
!
      IHP=IH+1
      SUM=0
      DO J=JMIN,JMAX
        SUM=SUM+(J+J+IHP)*W6J(J)*W6J(J)
      ENDDO
      SUM=SUM*(B1+B1+1)
!
      SUM=DONE/SQRT(SUM)
      SUM=SUM*ISIGN
      if(debug0)write(iwritd,"(' wnorm=',1pe10.2)")sum
!
! some test code
!      so=sign(done,w6j(jmin))
!      nod=0
!      wmax=0
!      do j=jmin,jmax
!        if(so*w6j(j).lt.dzero)then
!          so=-so
!          nod=nod+1
!        endif
!        wmax=max(wmax,abs(w6j(j)))
!      enddo
!      if(nod.ne.nodes)write(*,*)'nodes expected/found=',nodes,nod
!      write(*,*)'wmax=',wmax                               !order unity
!
      DO J=JMIN,JMD1M
        W6J(J)=W6J(J)*SUM
      ENDDO
      DO J=JMID1,JMID2
        T=W6J(J)*SUM
        IF(ABS(T).LT.DEPS1)T=DZERO                        !*wmax ZEROIZE
        W6J(J)=T
      ENDDO
      DO J=JMD2P,JMAX
        W6J(J)=W6J(J)*SUM
      ENDDO
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION E(A1)
!
      E=SQRT((A1*A1-(A2-A3)*(A2-A3))*((A2+A3+1)*(A2+A3+1)-A1*A1)        &
     &  *(A1*A1-(B2-B3)*(B2-B3))*((B2+B3+1)*(B2+B3+1)-A1*A1))
!     &           (A1-A2+A3)*(A1+A2-A3)*(A2+A3+1-A1)*(A2+A3+1+A1)*
!     &           (A1-B2+B3)*(A1+B2-B3)*(B2+B3+1-A1)*(B2+B3+1+A1)
!     &           )
!
      END FUNCTION E
!-----------------------------------------------------------------------
      FUNCTION F(A1)
!
      F=(A1+A1+1)                                                       &
     &  *(A1*(A1+1)*(-A1*(A1+1)+A2*(A2+1)+A3*(A3+1)-2*B1*(B1+1))        &
     &  +B2*(B2+1)*(A1*(A1+1)+A2*(A2+1)-A3*(A3+1))+B3*(B3+1)            &
     &  *(A1*(A1+1)-A2*(A2+1)+A3*(A3+1)))
!     &           A1*(A1+1)*(-A1*(A1+1)+A2*(A2+1)+A3*(A3+1)+
!     &           B2*(B2+1)+B3*(B3+1)-2*B1*(B1+1))+
!     &          (A2*(A2+1)-A3*(A3+1))*(B2*(B2+1)-B3*(B3+1))
!     &                 )
!
      END FUNCTION F
!-----------------------------------------------------------------------
      FUNCTION X(A1)
!
      X=A1*E(A1+1)
!
      END FUNCTION X
!-----------------------------------------------------------------------
      FUNCTION Z(A1)
!
      Z=(A1+1)*E(A1)
!
      END FUNCTION Z
!-----------------------------------------------------------------------
      FUNCTION Y(A1)
!
      Y=F(A1)
!
      END FUNCTION Y
!-----------------------------------------------------------------------
!
      END SUBROUTINE WIG6JR
!
!                             *******************
!
      SUBROUTINE WIG9J(W9J,A1,A2,A3,B1,B2,B3,C1,C2,C3,KMIN,KMAX,IH)
!
!-----------------------------------------------------------------------
!
! N. R. BADNELL                                                 19/02/21
!
! CALCULATES WIGNER 9-J SYMBOL ( A1 A2 A3 )
!                              ( B1 B2 B3 )
!                              ( C1 C2 C3 )
! IN TERMS OF A SUM OF A TRIPLE PRODUCT OF 6-J SYMBOLS USING SR.WIG6JR.
! SEE E.G. A. R. EDMONDS "ANGULAR MOMENTUM IN QUANTUM MECHANICS" (1957).
! USES WIGNER 6-J RECURRENCE OF
! BADNELL N. R., GUZMAN F., BRODIE S., WILLIAMS R. J. R., VAN HOOF
! P. A. M., CHATZIKOS M., & FERLAND G. J., 2021 MNRAS, 507, 2922
!
! INPUT:
!  A1,A2,A3,B1,B2,B3,C1,C2,C3: ALL NINE ARGUMENTS OF THE 9-J SYMBOL, AS
!  DEFINED ABOVE, USING THEIR ACTUAL VALUE, I.E. *NOT* TWICE  (REAL*8).
!
! OUTPUT:
!  W9J: THE REQUIRED 9-J SYMBOL (REAL*8)
!  KMIN,KMAX,IH: THE RANGE (KMIN+IH/2,KMAX+IH/2)OF THE K-SUM OVER THE
!       6-J SYMBOL TRIPLE PRODUCT (INTEGER)
!
!  KMIN.LT.0 FLAGS AN ERROR:
!         -1 NON-INTEGER TRIANGLE SUM.
!         -2 TRIANGLE RULE FAILURE.
!         -3 DIMENSION ERROR, KMAX THEN CONTAINS THE REQUIRED NDIMW.
!           (SHOULD NOT OCCUR WITH USE OF ALLOCATABLE.)
!
! UPDATE LOG:
! 23/12/15 - PHASE WAS NOT DETERMINED IF W6J(JMAX)=0
! 11/12/15 - REMOVED TEMP ARRAY.
! 20/11/15 - INITIAL RELEASE.
!
!  IT IS CALLED BY:
!
!   FOR USE IN E.G. LS TO JJ-COUPLING TRANSFORMATION
!
!  IT CALLS:
!
!   SR.WIG6JR
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A-H,O-P,R-Z)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      logical(bp) debug1                  !,debug2 !sync with standalone
!
      PARAMETER (DEPS1=1.E-16_WP)                           !REAL*8 ZERO
      PARAMETER (DEPS2=1.E-5_WP)
!
      ALLOCATABLE :: W6J(:,:)
!
      data debug1/.true./                       !,debug2/.true./
      data iwritd/-1/     !=0 to screen; set < 0 for non-interactive use
!
!-----------------------------------------------------------------------
!
      if(iwritd.lt.0)debug1=.false.
!
! INITIALIZE (LEAVE 9J-SELECTION RULES TO WIG6JR)
!
      W9J=0                                              !INITIALIZE ALL
      IH=0
!
! DETERMINE 6J SUMMATION RANGE K=KMIN,KMAX (QUICK EXIT IF ZERO SUM)
!
      A1C3=A1+C3
      B3A2=B3+A2
      C2B1=C2+B1
!
      T=MAX(ABS(C2-B1),ABS(B3-A2),ABS(A1-C3))
      KMIN=NINT(T-DEPS2)
      T=MIN(C2B1,B3A2,A1C3)
      KMAX=NINT(T-DEPS2)
      IF(KMIN.GT.KMAX)RETURN
!
      IF(KMAX.NE.NINT(T+DEPS2))IH=1                        !HALF-INTEGER
!
      th=dhalf*ih
      if(debug1)then
        write(iwritd,"(/' 6j sum range:   ',2f9.1)")kmin+th,kmax+th
      endif
!
!  KMAX IS THE COMMON RANGE, WE NEED THE MAX RANGE OF THE 3 SEPARATE W6J
! (NOT WORTH 3 SEPARATE ALLOCATES WITH BESPOKE NDIMW.)
!
      T1=MIN(A1C3,B3A2)
      T2=MIN(B3A2,C2B1)
      T3=MIN(C2B1,A1C3)
      T=MAX(T1,T2,T3)
      NDIMW=NINT(T-DEPS2)
!
      ALLOCATE(W6J(-1:NDIMW+1,3))
!
      CALL WIG6JR(W6J(-1,1),A1,C3,A3,B3,A2,JMIN,JMAX,IH1,NDIMW)
      IF(JMIN.LT.0)GO TO 200
!
      CALL WIG6JR(W6J(-1,2),B3,A2,B2,C2,B1,JMIN,JMAX,IH2,NDIMW)
      IF(JMIN.LT.0)GO TO 200
!
      CALL WIG6JR(W6J(-1,3),C2,B1,C1,A1,C3,JMIN,JMAX,IH3,NDIMW)
      IF(JMIN.LT.0)GO TO 200
!
! should be caught already
      if(ih.ne.ih1.or.ih1.ne.ih2.or.ih2.ne.ih3)then
        write(mw6,*)'*** sr.wig9j: 6j mixes integer and half integer...'&
     &              ,ih,ih1,ih2,ih3
        write(mw0,*)'*** sr.wig9j: 6j mixes integer and half integer...'&
     &              ,ih,ih1,ih2,ih3
        kmin=-4
        kmax=0
        go to 100
      endif
!
! PERFORM SUMMATION (RELATIVELY TIME CONSUMING)
!
      IHP=IH+1
      DO K=KMIN,KMAX
        W9J=W9J+(2*K+IHP)*W6J(K,1)*W6J(K,2)*W6J(K,3)
      ENDDO
      W9J=W9J*(1-2*IH)                         !CASE HALF INTEGER (IH=1)
!
      IF(ABS(W9J).LT.-DEPS1)W9J=DZERO                           !ZEROIZE
!
!-----------------------------------------------------------------------
!
  100 DEALLOCATE(W6J)
!
      RETURN
!
!-----------------------------------------------------------------------
!
  200 KMIN=JMIN
      KMAX=JMAX
      GO TO 100
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE WIG9J
!
!                             *******************
!
      SUBROUTINE WXC(DENS,TPLASMA,U)
!
!-----------------------------------------------------------------------
!
!  SR.WXC EVALUATES FREE ELECTRON PLASMA POTENTIAL, AT GIVEN TEMPERATURE
!  AND DENSITY.
!
!  IT IS CALLED BY:
!    SR.VREE
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (D3Q=DTHREE/DFOUR)
      PARAMETER (C1=4.7853_WP)
      PARAMETER (C2=0.6109_WP)
      PARAMETER (C3=3.04363_WP)
      PARAMETER (C4=0.09227_WP)
      PARAMETER (C5=1.7035_WP)
      PARAMETER (C6=8.31051_WP)
      PARAMETER (C7=5.1105_WP)
      PARAMETER (C8=0.425437_WP)
!
!-----------------------------------------------------------------------
!
      PI=ACOS(-DONE)
!
      IF(DENS.LE.D1M8)THEN
        U=DZERO
      ELSE
        R=(DTHREE/(DFOUR*PI*DENS))**(DONE/DTHREE)
! D4*PIE  NOT D4+PI !!!
        T=(TPLASMA/C1)*DENS**(-DTWO/DTHREE)
!
!     EXCHANGE PART
!
        UX0=-C2/R
        UX=UX0*(D3Q+C3*T**2-C4*T**3-C5*T**4)
        UX=UX/(DONE+C6*T**2+C7*T**4)*TANH(DONE/T)
!
!     CORRELATION PART
!     ASYMPTOTIC FORM FOR HIGH-T ELECTRON GAS
!
        UCHA=-C8/SQRT(T*R)
!
        U=UX+UCHA
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE WXC
!
!                             *******************
!
      FUNCTION XINT(DE,ENERG,NLAG0,RHO,M,ml,mu)
!
!-----------------------------------------------------------------------
!
!  FN.XINT INTEPOLATES RHO (REACTANCE) MATRIX
!
!  METHODS:
!   LAGRANGE POLYNOMIAL IS THE DEFAULT (IINT=1)
!   LAGRANGE TRIGONOMETRIC IS FOR TESING ONLY (IINT=2)
!   CUBIC SPLINE IS SLOWER (IINT=3)
!
!  IT IS CALLED BY:
!    SR.CADWX
!    SR.DWXBP_DAXPY
!    SR.DWXBP_DDOT
!    SR.DWXLS_DAXPY
!    SR.DWXLS_DDOT
!
!  IT CALLS:
!    FN.SINTER
!    SR.SPLYN
!    SR.SPVAL
!
!-----------------------------------------------------------------------
!
      use common_nrbuse, only: buguse,buse,busi,btmp
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (FRACKY=D1M4)
!
      DIMENSION ENERG(*),RHO(*)
      DIMENSION SP1(10),SP2(10),SP3(10),SP4(10),SP5(10)
!
      SAVE IP,NP1,NP2,NPH
!
      DATA IP0,NLAG/0,0/
!
!-----------------------------------------------------------------------
!
      iint=1                                         !set interp. method
!
      IF(DE.LE.FRACKY*ENERG(M))THEN                  !USE ELASTIC
        XINT=RHO(M)
        RETURN
      ELSE
        TE=ENERG(M)+DE
      ENDIF
!
      blog=mu.lt.0                                   !dipole transition
      mu=abs(mu)
!
!      belas=ml.lt.0                                 !alt. flag
      ml=abs(ml)                                    !currently not used
!
      belas=blog                                     !skip ei=ef for dip
!
      IF(NLAG.EQ.0)THEN
        np1=-999
        NPH=(NLAG0+1)/2
      ENDIF
!
      BBC=mu-ml.lt.NLAG0                             !MENG.LE.
      IF(BBC)THEN
        NP1=ml                                       !1
        NP2=mu                                       !MENG
        NLAG=NP2-NP1+1
        IP=NP2
      ENDIF
!
! FIND INTERPOLATION ENERGIES
!
      IF(.NOT.BBC)THEN
!
! FIRST SEE IF WE EXTRAPOLATING
!
        IF(TE.GT.ENERG(mu))THEN                      !EXTRAPOLATING
          NLAG=MIN(ITHREE,NLAG0)
          NP2=mu                                     !MENG
          NP1=NP2-NLAG+1
          IP=NP2
!          if(te.gt.1.1*energ(mu))
!     &       write(mw0,*)'*** Extrapolating upwards:',ml,mu,m
          iint=1                                     !for safety
          GO TO 200
        ELSEIF(TE.LT.ENERG(ml))THEN                  !EXTRAPOLATING
          NLAG=MIN(ITHREE,NLAG0)
          NP1=ml                                     !1
          NP2=NLAG+NP1-1
          IP=NP2
!          if(te.lt.d0pt9*energ(ml))
!     &       write(mw0,*)'*** Extrapolating downwards:',m,ml,mu
          iint=1                                     !for safety
          GO TO 200
        ENDIF
!
! ELSE CENTRE ON TE
!
        DO I=M+1,mu                                   !MENG
          IF(ENERG(I).GT.TE)THEN
            IP=I
            GO TO 50
          ENDIF
        ENDDO
        IP=mu                                         !MENG
!
   50   IF(NLAG0.EQ.1)THEN
          IF(IP.EQ.1)THEN
            XINT=RHO(IP)
          ELSE
            IF(ENERG(IP)-TE.LT.TE-ENERG(IP-1))THEN
              XINT=RHO(IP)
            ELSE
              XINT=RHO(IP-1)
            ENDIF
          ENDIF
          RETURN
        ENDIF
!
        IF(NLAG0.GT.2.AND.IP.NE.IP0)THEN
          NP2=IP+NPH-1
          NP1=IP-NPH
          IF(MOD(NLAG0,ITWO).NE.0)THEN                !REMOVE EVEN POINT
            i0=0
            if(ip.gt.ml+1.and.ip.lt.mu)i0=1              !2,meng
            IF(ABS(ENERG(IP+i0)-TE).LT.ABS(ENERG(IP-1-i0)-TE))THEN
              NP1=NP1+1
            ELSE
              NP2=NP2-1
            ENDIF
          ELSE
            IP0=IP
          ENDIF
          IF(NP1.LT.ml)THEN                             !1
            NP2=NP2-NP1+ml                              !1
            NP1=ml                                      !1
          ELSEIF(NP2.GT.mu)THEN                         !MENG
            NP1=NP1-NP2+mu                              !MENG
            NP2=mu                                      !MENG
          ENDIF
        ELSEIF(NLAG0.EQ.2)THEN
          NP2=IP
          NP1=IP-1
        ENDIF
! now covered by belas
!o        IF(ENERG(M)+ENERG(NP1).EQ.DZERO)THEN !EXCLUDE 0-0 FROM INELAST
!o          IF(NP2.LT.mu)NP2=NP2+1                        !MENG
!o          IF(NP1+1.LT.NP2)NP1=NP1+1
!o        ENDIF
!
      ENDIF
!
!   1  continue   !?
!
!      write(mw6,*)'fn.xint1: ',m,np1,np2
!
      if(belas.and.m.ge.np1)then                        !skip elastic
        d2=de/2                                         !plus any lt tt
        iu=mu-m
        do i1=1,iu
          if(energ(m+i1)-energ(m).gt.d2)go to 100
        enddo
        i1=iu
  100   im=m-np1+i1
        np2=min(np2+im,mu)
        np1=m+i1
!p        if(np2-np1+1.ne.nlag0)then
!p          write(mw6,*)'fn.xint: ',m,np1,np2,mu
!p        endif
      endif
!
!      if(belas)write(mw6,*)'fn.xin3: ',m,np1,np2
!
      NLAG=np2-np1+1                                    !NLAG0
!
!  NOW INTERPOLATE
!
  200 CONTINUE
!
      if(blog)then                            !set-up a log energy scale
!p       write(mw6,*)m,np1,np2
        deoff=0
        blog=.false.
!old        blog=te.gt.2*de.and.energ(np1).gt.dzero
!old        deoff=energ(m)
!l        blog=energ(np1).gt.dzero
!l        deoff=de/4                              !min offset of log(de)
!l        if(energ(np1).le.te)then
!l          deoff=deoff-(energ(np1)-energ(m))
!l        else
!l          deoff=deoff-(te-energ(m))
!l        endif
!up      deoff=max(dzero,deoff)                       !no downshift
!
!test nearest neighbour
!test        if(energ(ip)-energ(ip-1).gt.de)then
!test            IF(ABS(ENERG(IP)-TE).LT.ABS(ENERG(IP-1)-TE))THEN
!test              NP0=ip
!test            ELSE
!test              NP0=ip-1
!test            ENDIF
!test            xint=rho(np0)
!test            return
!test        endif
      endif
!
      if(nlag.eq.1)then
        xint=rho(np1)
        buse(np1)=.true.                              !flag used
        if(buguse)busi(np1,m)=.true.                  !flag used
      elseIF(NLAG.EQ.2)THEN                           !LAGRANGE POLY-ALL
!
        T10=ENERG(NP1)
        T20=ENERG(NP2)
        if(blog)then
          t=energ(m)-deoff
          te=te-t
          te=log(te)
          t10=t10-t
          t10=log(t10)
          t20=t20-t
          t20=log(t20)
        endif
        T=T20-T10
        T1=T20-TE
        T2=TE-T10
        XINT=(T2*RHO(NP2)+T1*RHO(NP1))/T
        buse(np1)=.true.                              !flag used
        buse(np2)=.true.                              !flag used
        if(buguse)busi(np1,m)=.true.                  !flag used
        if(buguse)busi(np2,m)=.true.                  !flag used
!
      ELSEIF(iint.eq.1)THEN                           !LAGRANGE POLY
!
        if(blog)then
          t=energ(m)-deoff
          te=te-t
          te=log(te)
        endif
        XINT=DZERO
        DO J=NP1,NP2
          buse(j)=.true.                              !flag used
          if(buguse)busi(j,m)=.true.                  !flag used
          TJ=ENERG(J)
          if(blog)then
            tj=tj-t
            tj=log(tj)
          endif
          DD=DONE
          DO N=NP1,NP2
            IF(J.NE.N)THEN
              TN=ENERG(N)
              if(blog)then
                tn=tn-t
                tn=log(tn)
              endif
              DD=DD*(TE-TN)
              DD=DD/(TJ-TN)
            ENDIF
          ENDDO
          XINT=XINT+DD*RHO(J)
        ENDDO
!
      ELSEIF(iint.eq.2)THEN                           !LAGRANGE TRIG
!
        NP0=NP2-NP1+1
        E1=ENERG(NP1)
        E2=ENERG(NP2)
        E21=E2-E1
        E21P=E21*2.05
!
        N=0
        DO NP=NP1,NP2
          N=N+1
          SP1(N)=(ENERG(NP)-E1)/E21P                  !MAP TO [0:<1]
        ENDDO
        T=(TE-E1)/E21P
!
        XINT=SINTER(NP0,SP1,RHO(NP1),T)
!
      ELSEIF(iint.eq.3)THEN                           !SPLINE
!
        do j=np1,np2
          buse(j)=.true.                              !flag used
          if(buguse)busi(j,m)=.true.                  !flag used
        enddo
!
        NP0=NP2-NP1+1
        CALL SPLYN(NP0,ENERG(NP1),RHO(NP1),ITHREE,DZERO,ITHREE,DZERO,   &
     &             SP1,SP2,SP3,SP4,SP5)
        JSP=0
        XINT=SPVAL(NP0,ENERG(NP1),SP1,SP2,SP3,SP4,TE,JSP)     !,RHO(NP1)
!
      ENDIF
!p      write(mw6,*)xint,(rho(i),i=np1,np2)
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION XINT
!
!                             *******************
!
      SUBROUTINE XTWOO(LAM,K1,K2,K3,K4,TXTWOO)
!
!-----------------------------------------------------------------------
!
!  SR.XTWOO EVALUATES THE X-TWO INTEGRAL OF 2-BODY DARWIN+
!  CONTACT-SPIN-SPIN INTERACTION, INCLUDING THE (2LBD+1) FACTOR.
!
!  IT IS CALLED BY:
!    SR.SLATR
!    SR.SLATRI
!    SR.SLATRX
!
!  IT CALLS:
!    SR.WEDDLE
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QL,QN,DEY
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
!
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      use common_nrbtmp, only: rnorm
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      ALLOCATABLE :: D1(:)
!
!-----------------------------------------------------------------------
!
      BREL2=ABS(IREL).EQ.2
      DD=DONE
!
      ALLOCATE(D1(MAXRS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.XTWOO: ALLOCATION FAILS FOR D1'
        TXTWOO=DZERO
        NF=0                                                !NOT TRACKED
        RETURN
      ENDIF
!
      DO I=1,MAXRS
        D1(I)=DPNL(I,K1)*DPNL(I,K2)*DPNL(I,K3)*DPNL(I,K4)/(DX(I)*DX(I))
      ENDDO
!
      IF(BREL)THEN               !SMALL R CORRECTION
        IK1=ICOL(K1,K1,IZERO)
        IK3=ICOL(K3,K3,IZERO)
        DE1=DEY(K1)-DUY(IK1)
        DE3=DEY(K3)-DUY(IK3)
        IK2=ICOL(K2,K2,IZERO)
        IK4=ICOL(K4,K4,IZERO)
        DE2=DEY(K2)-DUY(IK2)
        DE4=DEY(K4)-DUY(IK4)
        DZ=NZION
        IF(BREL2)THEN
          T=DALF4*DTWO
          DO I=1,MAXRS
            DD1=DONE+T*(DE1+DZ/DX(I))
            DD3=DONE+T*(DE3+DZ/DX(I))
            DSQ=DD1*DD3
            DSQ=SQRT(DSQ)
            D1(I)=D1(I)/DSQ
            DD2=DONE+T*(DE2+DZ/DX(I))
            DD4=DONE+T*(DE4+DZ/DX(I))
            DSQ=DD2*DD4
            DSQ=SQRT(DSQ)
            D1(I)=D1(I)/DSQ
          ENDDO
        ELSE
          dd=rnorm(k1)*rnorm(k3)*rnorm(k2)*rnorm(k4)
          DO I=1,MAXRS
            DD1=DONE+DALF4*(DQNL(I,K1)/DPNL(I,K1)+DTWO*DZ/DX(I))
            DD3=DONE+DALF4*(DQNL(I,K3)/DPNL(I,K3)+DTWO*DZ/DX(I))
            DSQ=DD1*DD3
            DSQ=SQRT(DSQ)
            D1(I)=D1(I)/DSQ
            DD2=DONE+DALF4*(DQNL(I,K2)/DPNL(I,K2)+DTWO*DZ/DX(I))
            DD4=DONE+DALF4*(DQNL(I,K4)/DPNL(I,K4)+DTWO*DZ/DX(I))
            DSQ=DD2*DD4
            DSQ=SQRT(DSQ)
            D1(I)=D1(I)*dd/DSQ
          ENDDO
        ENDIF
      ENDIF
!
      CALL WEDDLE(DZERO,D1,TT,MNH,DHNS,MJH,MAXRS)
!
      TP=2*LAM+1
      TXTWOO=DALF*TT*TP*DD
      if(.not.brel)txtwoo=txtwoo/DTWO              !add-in 2-body Darwin
!
      DEALLOCATE(D1,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.XTWOO: DE-ALLOCATION FAILS FOR D1'
        NF=0                                                !NOT TRACKED
        RETURN
      ENDIF
!
!      WRITE(MW6,100) K1, K2, K3, K4, XTWOO
!100   FORMAT(8X,2(I5,I4),F20.7,' =XTWO')
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE XTWOO
!                                                                  !ADAS
!                             *******************                  !ADAS
!                                                                  !ADAS
      subroutine xxcftr(icfsel,cstrgi,cstrgo)                      !ADAS
!                                                                  !ADAS
!------------------------------------------------------------------!ADAS
!                                                                  !ADAS
! dummy routine for normal (non-ADAS) useage.                      !ADAS
!                                                                  !ADAS
!  it is called by:                                                !ADAS
!    sr.carate                                                     !ADAS
!    sr.diagfs                                                     !ADAS
!    sr.diagon                                                     !ADAS
!                                                                  !ADAS
!------------------------------------------------------------------!ADAS
!                                                                  !ADAS
      USE PRECSN, ONLY: BP,QP,SP,EP,WP                             !ADAS
      USE PARAM                                                    !ADAS
      USE UTILITY                                                  !ADAS
      USE CONSTANTS                                                !ADAS
!                                                                  !ADAS
!------------------------------------------------------------------!ADAS
!                                                                  !ADAS
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)                            !ADAS
      IMPLICIT LOGICAL(BP) (B)                                     !ADAS
      IMPLICIT INTEGER(SP) (I-N)                                   !ADAS
      IMPLICIT INTEGER(QP) (Q)                                     !ADAS
!                                                                  !ADAS
!      INCLUDE './INCLUDE'                                         !ADAS
!                                                                  !ADAS
      character(len=*) cstrgi,cstrgo                               !ADAS
      character(len=1) cdum                                        !ADAS
!                                                                  !ADAS
! suppress compiler warnings (sigh...)                             !ADAS
!                                                                  !ADAS
      cdum=cstrgi(1:1)                                             !ADAS
      idum=icfsel                                                  !ADAS
!                                                                  !ADAS
      write(cstrgo(1:15),'(a15)')'dummy sr.xxcftr'                 !ADAS
!                                                                  !ADAS
!------------------------------------------------------------------!ADAS
!                                                                  !ADAS
      return                                                       !ADAS
!                                                                  !ADAS
!------------------------------------------------------------------!ADAS
!                                                                  !ADAS
      end subroutine xxcftr                                        !ADAS
!
!                             *******************
!
      SUBROUTINE YLAMK(L,M0,PA,PB,Y1,Y2,NH,HN,JH,MODE)
!
!-----------------------------------------------------------------------
!
!  SR.YLAMK EVALUATES RADIAL MULTIPOLE FUNCTIONS (OUTPUT ARRAY PB) FOR
!  RADIAL FUNCTION PRODUCT (INPUT ARRAY PA) OF LAMDA=L. ALSO OUTPUT
!  Y1 INTEGRAL [0:INF) A*X**L
!  Y2 INTEGRAL [0:INF) A/X**(L+1)
!
!  IT USES THE MODIFIED BODY OF J. A. BELLING'S SR.YLAM.
!
!  MODE.EQ.0: YLAMK COMPUTES  COULOMB INTEGRALS YLAMBDA (REL.TO RLAM)
!  MODE.LT.0:                MAGNETIC INTEGRALS RELATED TO VLAM
!  MODE.GT.0:                                              NLAM
!
!  IT IS CALLED BY:
!    SR.CAVE
!    SR.FSINT
!    SR.FSINTI
!    SR.NLAM
!    SR.RADBP2
!    SR.SLATR
!    SR.SLATRI
!    FN.TLAM
!    FN.ULAM
!    FN.VLAM
!    SR.VLAM0
!    SR.VNYKX
!    SR.YLAMKR ***
!    SR.YLAMKX
!
!  IT CALLS:
!    SR.YLAMKR ***
!
!-----------------------------------------------------------------------
!
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,VSC,XC1,XC2,NPITER
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION PA(*),PB(*),NH(JH),HN(JH),C(5),E(5),F(5)
!
!-----------------------------------------------------------------------
!
      M=MIN(M0,I5TEEN)
!
      K=1
      IF(MODE.NE.0)K=ABS(MODE)
      J=L+K
!
!      N=J
!      IF(MODE.NE.0)N=2
      IF(J.LE.0.OR.JH.LE.0)GO TO 300
!                .OR. M.LT.N
      N=8
      DO I=1,JH
        IF(HN(I).LT.DZERO)GO TO 300
        IF(NH(I).LT.N)GO TO 300
        N=5
      ENDDO
!
      IF(MDEN.EQ.11.AND.DENE.GT.DZERO)THEN
                                          !DEBYE-HUCKEL PLASMA SCREENING
        DEL=D1P99
        CALL YLAMKR(L,M0,DEL,PA,PB,Y1,Y2,NH,HN,JH,MODE)
        RETURN
      ENDIF
!
      H=HN(1)
      J1=M-1
      X=DZERO
      DO I=1,4
        X=X+H
        C(I)=PA(I)/X**J1
      ENDDO
!
      Z=H*24
      E(1)=(96*C(1)-72*C(2)+32*C(3)-6*C(4))/Z
      Z=H*Z
      E(2)=(-104*C(1)+114*C(2)-56*C(3)+11*C(4))/Z
      Z=H*Z
      E(3)=(36*C(1)-48*C(2)+28*C(3)-6*C(4))/Z
      Z=H*Z
      E(4)=(-4*(C(1)+C(3))+6*C(2)+C(4))/Z
      X=DZERO
!
      DO N=1,4
        X=X+H
        C(N)=DZERO
        DO I1=1,4
          I2=5-I1
          Z=L+M+I2
          C(N)=E(I2)/Z+C(N)*X
        ENDDO
        PB(N)=C(N)*X**(M-K+1)
        C(N)=PB(N)*X**J
      ENDDO
!
      E(4)=PA(4)*X**L
      N=4
      I1=8
!
      DO J1=1,JH
        H=HN(J1)
        H1=2*H/45
        E(1)=E(4)
        C(1)=C(4)
!
        DO I=2,5
          N=N+1
          X=X+H
          Z=X**L
          E(I)=Z*PA(N)
          F(I)=Z*X**K
        ENDDO
!
        C(2)=C(1)+H*(251*E(1)+646*E(2)-264*E(3)+106*E(4)-19*E(5))/720
        PB(N-3)=C(2)/F(2)
        C(3)=C(1)+H*(29*E(1)+124*E(2)+24*E(3)+4*E(4)-E(5))/90
        PB(N-2)=C(3)/F(3)
        C(4)=C(1)+H*(9*E(1)+34*E(2)+24*E(3)+14*E(4)-E(5))*3/80
        PB(N-1)=C(4)/F(4)
        I2=NH(J1)
!
        IF(I2.GE.I1)THEN
          N=N-1
          X=X-H
          DO I=I1,I2
            N=N+1
            X=X+H
            Z=X**L
            F(5)=Z*X**K
            E(5)=Z*PA(N)
            C(5)=C(1)+H1*(7*(E(1)+E(5))+32*(E(2)+E(4))+12*E(3))
            PB(N)=C(5)/F(5)
            DO I3=1,4
              C(I3)=C(I3+1)
              E(I3)=E(I3+1)
            ENDDO
          ENDDO
        ENDIF
        I1=4
      ENDDO
!
      Y1=C(5)
      IF(MODE.GT.0)GO TO 200         !SWITCHES-OFF "Y2" PART OF INTEGRAL
      C(5)=DZERO
! TEST C(5)=Y2                                !MUST ENSURE Y2 INPUT THEN
      I1=1
      X=X+H
!
      DO J1=1,JH
        I3=JH-J1+1
        H=HN(I3)
        H1=2*H/45
        E(1)=E(5)
        C(1)=C(5)
        I2=NH(I3)
        I3=N
        DO I=I1,5
          X=X-H
          F(I)=X**L
          E(I)=PA(N)/(F(I)*X**K)
          N=N-1
        ENDDO
        C(2)=C(1)+H*(251*E(1)+646*E(2)-264*E(3)+106*E(4)-19*E(5))/720
        C(3)=C(1)+H*(29*E(1)+124*E(2)+24*E(3)+4*E(4)-E(5))/90
        C(4)=C(1)+H*(9*E(1)+34*E(2)+24*E(3)+14*E(4)-E(5))*3/80
        C(5)=C(1)+H1*(7*(E(1)+E(5))+32*(E(2)+E(4))+12*E(3))
!
        DO I=I1,5
          IF(MODE.LE.-999)PB(I3)=DZERO
          PB(I3)=C(I)*F(I)+PB(I3)
          I3=I3-1
        ENDDO
!
        DO I=5,I2
          DO I3=1,4
            E(I3)=E(I3+1)
            C(I3)=C(I3+1)
          ENDDO
          E(5)=DZERO
          IF(N.NE.0)THEN
            X=X-H
            Z=X**L
            E(5)=PA(N)/(Z*X**K)
          ENDIF
          C(5)=C(1)+H1*(7*(E(1)+E(5))+32*(E(2)+E(4))+12*E(3))
          IF(N.EQ.0)GO TO 100
          IF(MODE.LE.-999)PB(N)=DZERO
          PB(N)=C(5)*Z+PB(N)
          N=N-1
        ENDDO
        I1=2
      ENDDO
!
  100 Y2=C(5)
!
!-----------------------------------------------------------------------
!
  200 RETURN
!
!-----------------------------------------------------------------------
!
! SHOULD NOT HAPPEN SINCE SUITABLE MESH PRE-SET BY RADIAL
!
  300 WRITE(MW6,10010)L,MODE,M,JH,(NH(I),HN(I),I=1,JH)
      WRITE(MW0,*)'INPUT ERROR IN YLAMK'
!      STOP 'INPUT ERROR IN YLAMK'
      GO TO 200
!
!-----------------------------------------------------------------------
!
10010 FORMAT(/20X,'INPUT ERROR IN YLAMK',20X,'L,MODE=',2I5,5X,'M=',I3,  &
     &       5X,'JH=',I3,5X,'NH,HN='/(10X,5(I5,E16.8)))
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE YLAMK
!
!                             *******************
!
      SUBROUTINE YLAMKR(L,M0,DEL0,PA,PB,Y1,Y2,NH,HN,JH,MOD0)
!
!-----------------------------------------------------------------------
!
!  SR.YLAMKR EVALUATES RADIAL MULTIPOLE FUNCTIONS WITH FULL RETARDATION
!  USING SPHERICAL BESSEL FUNCTIONS OF THE FIRST AND SECOND KIND, I.E.
!  ONLY THE REAL PART IS CONSIDERED.
!  IT USES THE MODIFIED BODY OF SR.YLAMK.
!  ONLY CALLED IF BREL=.TRUE., I.E. RELATIVISTIC WAVEFUNCTIONS IN USE.
!
!  INPUT:
!  MODE.EQ.0: YLAMK COMPUTES  COULOMB INTEGRALS YLAMBDA (REL.TO RLAM)
!      .LT.0:                MAGNETIC INTEGRALS RELATED TO VLAM
!      .GT.0:                                              NLAM
!  L  IS THE MULTIPOLE
!  M0 CHARACTERISES THE SMALL-R BEHAVIOUR OF ARRAY
!  PA  WHICH CONTAINS THE PRODUCT OF THE TWO ORBITALS ON:
!  NH,HN,JH DEFINED STANDARD RADIAL MESH
!
!  DEL IS THE TRANSVERSE PHOTON ENERGY (A.U.).
!  ***IF USER SETS IBREIT IN UNIT5 INPUT THEN
!  IBREIT.GT.0 (REAL PART OF) GENERALIZED BREIT INTERACTION.
!  IBREIT.EQ.0 USUAL YLAMK IS CALLED - ZERO ENERGY TRANSVERSE PHOTON.
!  (TEST: IBREIT.LT.0 APPLIES NON-ZERO ENERGY TO THE COULOMB, AS MOLLER)
!
!  IF MDEN.EQ.11 THEN DEL IS REPLACE BY CORRESPONDING DEBYE WAVELENGTH
!  TO GENERATE 2-BODY DEBYE-HUCKEL SCREENED COULOMB INTEGRALS.
!
!  OUTPUT:
!  YK IN ARRAY PB.
!  Y1,Y2 INTEGRALS ZERO TO INFINITY.
!
!  IT IS CALLED BY:
!    SR.FSINT
!    SR.FSINTI
!    SR.NLAM
!    SR.RADBP2
!    SR.SLATR
!    SR.SLATRI
!    FN.TLAM
!    FN.ULAM
!    FN.VLAM
!    SR.VLAM0
!    SR.VNYKX
!    SR.YLAMK ***
!    SR.YLAMKX
!
!  IT CALLS:
!    FN.SBESS
!    SR.YLAMK ***
!
!-----------------------------------------------------------------------
!
!
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,VSC,XC1,XC2,NPITER
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (WMIN0=D1M1)
!
      DIMENSION PA(*),PB(*),NH(JH),HN(JH),C(5),E(5),F(5)
!
!-----------------------------------------------------------------------
!
      PI=ACOS(-DONE)
!
      bbreit=ibreit.lt.0.or.ibreit.gt.0.and.mod0.ne.0.or.mden.eq.11
      mode=mod(mod0,I1000)
!
      M=MIN(M0,I5TEEN)
!
      K=1
      IF(MODE.NE.0)K=ABS(MODE)
      J=L+K
!
!      N=J
!      IF(MODE.NE.0)N=2
      IF(J.LE.0.OR.JH.LE.0)GO TO 400
!               .OR. M.LT.N
      N=8
      MAXRS=0
      DO I=1,JH
        IF(HN(I).LT.DZERO)GO TO 400
        IF(NH(I).LT.N)GO TO 400
        N=5
        MAXRS=MAXRS+NH(I)
      ENDDO
!
      IF(MDEN.EQ.11)THEN                  !DEBYE-HUCKEL PLASMA SCREENING
        IF(DENE.GT.DZERO)THEN
          W=DONE/DEBYE
          WMIN=-WMIN0
          JSWTCH1=-1
          JSWTCH2=-3
          TM=-DTWO/PI     !COMPENSATE FOR USING ABRAMOWITZ & STEGUN NORM
        ELSE
          W=DZERO
          WMIN=DONE
        ENDIF
!      ELSEIF(MDEN.EQ.22)THEN             !ION-SPHERE PLASMA SCREENING
      ELSE
        DEL=ABS(DEL0)
        W=DFSC*DEL
        WMIN=WMIN0
        JSWTCH1=1
        JSWTCH2=2
        TM=DONE
      ENDIF
!
      IF(W.LT.WMIN.or..not.bbreit)THEN                       !UNRETARDED
        CALL YLAMK(L,M0,PA,PB,Y1,Y2,NH,HN,JH,MODE)
        RETURN
      ENDIF
!
      H=HN(1)
      J1=M-1
      X=DZERO
      DO I=1,4
        X=X+H
        C(I)=PA(I)/X**J1
      ENDDO
!
      Z=H*24
      E(1)=(96*C(1)-72*C(2)+32*C(3)-6*C(4))/Z
      Z=H*Z
      E(2)=(-104*C(1)+114*C(2)-56*C(3)+11*C(4))/Z
      Z=H*Z
      E(3)=(36*C(1)-48*C(2)+28*C(3)-6*C(4))/Z
      Z=H*Z
      E(4)=(-4*(C(1)+C(3))+6*C(2)+C(4))/Z
!
      TW=-(2*L+1)*W**K
      DO I=1,K-1
        TW=TW/(2*(L+I)-1)
      ENDDO
!
      TW=TW*TM
!
      X=DZERO
      DO N=1,4
        X=X+H
        C(N)=DZERO
        DO I1=1,4
          I2=5-I1
          Z=L+M+I2
          C(N)=E(I2)/Z+C(N)*X
        ENDDO
        PB(N)=C(N)*X**(M-K+1)
        C(N)=PB(N)*X**J
      ENDDO
!
      J=J-1
      Z=X*W
      E(4)=SBESS(L,Z,JSWTCH1)*PA(4)
      N=4
      I1=8
!
      DO J1=1,JH
        H=HN(J1)
        H1=2*H/45
        E(1)=E(4)
        C(1)=C(4)
!
        DO I=2,5
          N=N+1
          X=X+H
          Z=X*W
          E(I)=SBESS(L,Z,JSWTCH1)*PA(N)
          F(I)=SBESS(J,Z,JSWTCH2)
        ENDDO
!
        C(2)=C(1)+H*(251*E(1)+646*E(2)-264*E(3)+106*E(4)-19*E(5))/720
        PB(N-3)=C(2)*F(2)
        C(3)=C(1)+H*(29*E(1)+124*E(2)+24*E(3)+4*E(4)-E(5))/90
        PB(N-2)=C(3)*F(3)
        C(4)=C(1)+H*(9*E(1)+34*E(2)+24*E(3)+14*E(4)-E(5))*3/80
        PB(N-1)=C(4)*F(4)
        I2=NH(J1)
!
        IF(I2.GE.I1)THEN
          N=N-1
          X=X-H
          DO I=I1,I2
            N=N+1
            X=X+H
            Z=X*W
            E(5)=SBESS(L,Z,JSWTCH1)*PA(N)
            F(5)=SBESS(J,Z,JSWTCH2)
            C(5)=C(1)+H1*(7*(E(1)+E(5))+32*(E(2)+E(4))+12*E(3))
            PB(N)=C(5)*F(5)
            DO I3=1,4
              C(I3)=C(I3+1)
              E(I3)=E(I3+1)
            ENDDO
          ENDDO
        ENDIF
        I1=4
      ENDDO
!
      Y1=C(5)
      IF(MODE.GT.0)GO TO 200
!
      C(5)=DZERO
! TEST C(5)=Y2                                !MUST ENSURE Y2 INPUT THEN
      I1=1
      X=X+H
!
      DO J1=1,JH
        I3=JH-J1+1
        H=HN(I3)
        H1=2*H/45
        E(1)=E(5)
        C(1)=C(5)
        I2=NH(I3)
        I3=N
        DO I=I1,5
          X=X-H
          Z=X*W
          E(I)=SBESS(J,Z,JSWTCH2)*PA(N)
          F(I)=SBESS(L,Z,JSWTCH1)
          N=N-1
        ENDDO
        C(2)=C(1)+H*(251*E(1)+646*E(2)-264*E(3)+106*E(4)-19*E(5))/720
        C(3)=C(1)+H*(29*E(1)+124*E(2)+24*E(3)+4*E(4)-E(5))/90
        C(4)=C(1)+H*(9*E(1)+34*E(2)+24*E(3)+14*E(4)-E(5))*3/80
        C(5)=C(1)+H1*(7*(E(1)+E(5))+32*(E(2)+E(4))+12*E(3))
!
        DO I=I1,5
          IF(MODE.LE.-999)PB(I3)=DZERO
          PB(I3)=C(I)*F(I)+PB(I3)
          I3=I3-1
        ENDDO
!
        DO I=5,I2
          DO I3=1,4
            E(I3)=E(I3+1)
            C(I3)=C(I3+1)
          ENDDO
          E(5)=DZERO
          IF(N.NE.0)THEN
            X=X-H
            Z=X*W
            E(5)=SBESS(J,Z,JSWTCH2)*PA(N)
            F(5)=SBESS(L,Z,JSWTCH1)
          ENDIF
          C(5)=C(1)+H1*(7*(E(1)+E(5))+32*(E(2)+E(4))+12*E(3))
          IF(N.EQ.0)GO TO 100
          IF(MODE.LE.-999)PB(N)=DZERO
          PB(N)=C(5)*F(5)+PB(N)
          N=N-1
        ENDDO
        I1=2
      ENDDO
!
  100 Y2=C(5)
!
      Y2=Y2*TW
  200 Y1=Y1*TW
      DO I=1,MAXRS
        PB(I)=TW*PB(I)
      ENDDO
!
!-----------------------------------------------------------------------
!
  300 RETURN
!
!-----------------------------------------------------------------------
!
! SHOULD NOT HAPPEN SINCE SUITABLE MESH PRE-SET BY RADIAL
!
  400 WRITE(MW6,10010)L,MODE,M,JH,(NH(I),HN(I),I=1,JH)
      WRITE(MW0,*)'INPUT ERROR IN YLAMKR'
!
      GO TO 300
!
!-----------------------------------------------------------------------
!
10010 FORMAT(/20X,'INPUT ERROR IN YLAMKR',20X,'L,MODE=',2I5,5X,'M=',I3, &
     &       5X,'JH=',I3,5X,'NH,HN='/(10X,5(I5,E16.8)))
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE YLAMKR
!
!                             *******************
!
      SUBROUTINE YLAMKX(DP1,DP2,DQ1,DQ2,N1,N2,JJ,M1,M2,TM,TN,DEL0,DPA,DP&
     &                 ,DX,DPOLA,REM,ovlp)
!
!-----------------------------------------------------------------------
!
!  SR.YLAMKX CALCULATES THE DEIE YK INTEGRAL,
!    INCLUDING ANY LONG-RANGE CONTRIBUTION
!
!  IT IS CALLED BY:
!    SR.SLATRX
!
!  IT CALLS:
!    SR.YLAMKR
!    SR.YLAMK
!    SR.ASS2X
!    SR.ASSX
!    SR.WEDDLE
!
!  IT CONTAINS:
!    FN.DPOL1
!    FN.DPOL2
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
!
      USE COMMON_NRB,    ONLY: ACE,MAUTO,MODE,MORT,MGRP,JRAD,KORT
      USE COMMON_NRBDW5, ONLY: DYY,MENG,NLAG
      USE COMMON_NRBPOT, ONLY: DPOT,TOL,MEND
      USE COMMON_NRBPOT, ONLY: ALFD,RCUT,ALAV,RCAV,IPOLFN
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION DP1(*),DP2(*),DQ1(*),DQ2(*),DPA(*),DP(*),DX(*)
!
!-----------------------------------------------------------------------
!      DPOL1(X)=SQRT(DONE-EXP(-(X/RCAV)**6))/X**2
!      DPOL2(X)=X/((X*X+RCAV*RCAV)*SQRT(X*X+RCAV*RCAV))
!-----------------------------------------------------------------------
!
      BREL2=ABS(IREL).EQ.2
      IPOLF2=IPOLFN/10
      DZA=-(NZION-MION)                             !CHARGE .LT.0 IN ASS
!
      REM=DZERO
!
      IF(BREL2)THEN
        DO I=1,MAXRS
          DPA(I)=DP1(I)*DP2(I)+DQ1(I)*DQ2(I)
        ENDDO
      ELSE
        DO I=1,MAXRS
          DPA(I)=DP1(I)*DP2(I)
        ENDDO
      ENDIF
!
      if(jj.eq.0)then      !determine one-body contribution, dir or exch
        if(qn(n2).lt.0.or.kort.lt.0.or.kort.eq.0.and.mort.ne.-3)then
          do i=1,maxrs
            dp(i)=dpa(i)*dpot(i)
          enddo
          call weddle(dzero,dp,rem0,MNH,dhns,mjh,maxrs)
          rem0=-rem0/(dpot(maxrs)*dx(maxrs))          !a.u. per electron
          if(qn(n2).lt.0)rem=rem0                                !direct
        else
          rem0=dzero
        endif
      endif
!
      ML=(QL(N1)+QL(N2))/2+2
      MI=ABS(JJ)/2
!
      IF(BREL)THEN
        DEL=DEL0/DTWO                                           ! A.U.!!
        CALL YLAMKR(MI,ML,DEL,DPA,DP,DD1,DD2,MNH,DHNS,MJH,IZERO)
      ELSE
        CALL YLAMK(MI,ML,DPA,DP,DD1,DD2,MNH,DHNS,MJH,IZERO)
      ENDIF
!
      IF(IPOLF2.GT.0.AND.MI.EQ.1)THEN         !DIELECTRIC POLARIZATION
        IF(IPOLF2.EQ.1)THEN
          DO I=1,MAXRS
            DPA(I)=DPOL1(DX(I))*DPA(I)
          ENDDO
        ELSEIF(IPOLF2.EQ.2)THEN
          DO I=1,MAXRS
            DPA(I)=DPOL2(DX(I))*DPA(I)
          ENDDO
        ELSE
          STOP 'SR.YLAMKX: HERE BE MONSTERS'
        ENDIF
        CALL WEDDLE(DZERO,DPA,DPOLA,MNH,DHNS,MJH,MAXRS)
      ENDIF
!
      IF(JJ.LT.0)RETURN                                  !EXCHANGE
!
      IF(JJ.EQ.0)THEN
        if(rem.eq.dzero)then                       !exchange
          ovlp=dd1
          rem=rem0
        else                                       !direct
          ovlp=dzero
        endif
        RETURN
      ENDIF
!
!  EVALUATE LONG-RANGE INTEGRAL (SO DIRECT)
!
      E1=DYY(M1)                                              !RYD
      E2=DYY(M2)                                              !RYD
      ML1=QL(N1)/2
      ML2=QL(N2)/2
!
      IF(E1*E2.EQ.DZERO.AND.ML1+ML2.GT.60)THEN
        REM=DZERO
        RETURN
      ENDIF
!
      DS=ML1*(ML1+1)
      DC=ML2*(ML2+1)
!
      DX1=DX(MAXRS)
      DTH=DX(MAXRS)-DX(MAXRS-1)
!
      DD1=DP1(MAXRS-1)
      DD2=DP1(MAXRS)
      DD3=DP2(MAXRS-1)
      DD4=DP2(MAXRS)
!
      MN=-MI-1
!
      CALL ASS2X(DX1,DTH,DX2,DD1,DD2,DD3,DD4,E1,E2,DS,DC,DZERO,DZERO,   &
     &           DZERO,DZERO,DZA,MN,REM2)
!
      CALL ASSX(DX2,MN,TM,TN,E1,E2,DZA,ML1,ML2,DS,DC,DZERO,DZERO,DZERO, &
     &          DZERO,REM)
!
!      SUM=REM2+REM
!      WRITE(MW6,1111)E1,E2,DX1,REM2,DX2,REM,SUM
!1111  FORMAT(2F9.3,2(F7.1,F12.6),F13.6)
!
      REM=REM2+REM
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION DPOL1(X)
!
      REAL(WP) X,DPOL1
!
      DPOL1=SQRT(DONE-EXP(-(X/RCAV)**6))/X**2
!
      END FUNCTION DPOL1
!-----------------------------------------------------------------------
      FUNCTION DPOL2(X)
!
      REAL(WP) X,DPOL2
!
      DPOL2=X/((X*X+RCAV*RCAV)*SQRT(X*X+RCAV*RCAV))
!
      END FUNCTION DPOL2
!-----------------------------------------------------------------------
!
      END SUBROUTINE YLAMKX
!
!                             *******************
!
      SUBROUTINE ZEFR(J,R,ZE)
!
!-----------------------------------------------------------------------
!
!   This subroutine calculates an effective charge ZE such
!   that in a coulomb field of charge ZE the mean radius
!   <R> of orbital J is equal to the input value R .
!      Find ZE such that   <R>-R=0
!   The Newton method is used with accuracy D1M6 and maximum
!   number of iterations ITR .
!
!   Fix for L-spinors           -        nrb 09/01/08
!
!
!  Based on PHN's GRASP0 routine and freely adapted by NRB.
!
!  IT IS CALLED BY:
!    SR.QEDINT
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (ITR=30)
!
      DIMENSION TA(3),TB(3)
!
!-----------------------------------------------------------------------
!
      NN=QN(J)
      L=QL(J)/2
      K=-L-1
  100 CONTINUE
      MK=ABS(K)
      NNS=NN*NN
!
!  Initial estimate using non-relativistic formula.
!
      TA(3)=REAL(NNS+NNS+NNS-L*(L+1),WP)/(R+R)
      FK=REAL(K,WP)
      FKS=FK*FK
      FNR=REAL(NN-MK,WP)
!
!  Begin iterations on the relativistic formula.
!
      I=1
  200 CONTINUE
      TA(1)=TA(3)-D1M5
      TA(2)=TA(3)+D1M5
      DO II=1,3
        WA=TA(II)*DFSC
        WA=WA*WA
        if(fks.lt.wa)go to 500                 !catch L-spinors
        WB=SQRT(FKS-WA)+FNR
        WA=WB*WB+WA
        if(wa.lt.0)go to 500                   !catch L-spinors
        SWA=SQRT(WA)
        WA=WB*(WA+WA+WA-FKS)-SWA*FK
        WB=TA(II)*SWA
        TB(II)=WA/(WB+WB)-R
      ENDDO
      WB=TA(3)
      WA=D1M5*TB(3)/(TB(2)-TB(1))
      TA(3)=TA(3)-(WA+WA)
      IF(ABS(TA(3)-WB).le.D1M6)go to 300       !40,40,20
!   20 CONTINUE
!      write(mw6,*)i,a(3)
      I=I+1
      IF(I.le.ITR)go to 200                   !10,10,30
!   30 CONTINUE
      WRITE(MW6,10010)QN(J),QL(J)/2
!
  300 CONTINUE
      ZE=TA(3)
!
      IF(L.EQ.0)GO TO 400
!
      IF(K.LT.0)THEN
        ZE3=ZE
        K=L
        GO TO 100
      ELSE
        ZE1=ZE
        ZE=(ZE1+DTWO*ZE3)/DTHREE
      ENDIF
!
!-----------------------------------------------------------------------
!
  400 RETURN
!
!-----------------------------------------------------------------------
!
  500 ZE=-DONE
      GO TO 400
!
!-----------------------------------------------------------------------
!
10010 FORMAT(' WARNING in ZEFR : iteration limit exceeded for ',I2,I2)
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE ZEFR
!
!                             *******************
!
      FUNCTION ZEFX(I,NI,LI,Z0,S,NSHELL,N,TUMEL,WKT,ALFA,R,MEXPOT,FACA)
!
!-----------------------------------------------------------------------
!
!  FN.ZEFX EVALUATES THE SLATER-TYPE ORBITAL POTENTIAL AT A SINGLE PT.
!  USING OCCUPPATION NUMBERS DEFINED IN SR.STOPOT, WHICH CALLS IT
!  TO FILL-IN THE RADIAL ARRAY
!
!  A. BURGESS - HARTREE
!  N. R. BADNELL - EXCHANGE
!
!  Z0=NUCLEAR CHARGE (IN ELECTRON POTENTIAL UNITS, I.E. <0!)
!  NSHELL=NUMBER OF ELECTRON SHELLS
!  N(J),J=1, NSHELL, IS THE PRINCIPAL QUANTUM NUMBER OF SHELL J
!  TUMEL(J) IS THE NUMBER OF ELECTRONS IN SHELL J
!  R IS THE RADIAL DISTANCE COORDINATE IN UNITS OF A0 AND
!  ALFA(J) IS A RADIAL SCALING FACTOR FOR SHELL J.
!  IF I IS SET NEGATIVE, ZEFX IS SET TO THE JUCYS FIT TO THE
!  THOMAS-FERMI EFFECTIVE POTENTIAL.
!  IF I IS SET POSITIVE OR ZERO, SLATER-TYPE ORBITALS ARE USED, AND
!  ZEFX IS THE SHORT RANGE EFFECTIVE POTENTIAL, AS SEEN BY A (SPECTATOR)
!  ELECTRON IN SHELL I, DUE TO THE NUCLEUS PLUS ALL THE OTHER ELECTRON
!  IN SHELLS J=1,NSHELL.
!  N.B. I MAY BE SET GREATER THAN NSHELL (OR ZERO), IN WHICH
!  CASE THERE IS SCREENING BY ALL THE ELECTRONS IN SHELLS J=1,NSHELL
!  SINCE THE SPECTATOR ELECTRON IS NOT ONE OF THEM.
!
!  IT IS CALLED BY:
!    SR.STOPOT
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
!      USE COMMON_NRBCAV, ONLY: ECAVX,ECAV,AJUSTX,ICAV
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      PARAMETER (AJUSTX=DONE)
      PARAMETER (DCON1=140)
      PARAMETER (DCON2=0.2075_WP)                     !JUCYS
      PARAMETER (DCON3=1.19_WP)                       !JUCYS
!      PARAMETER (DCON4=(DSIX/XPI**2)**D1THRD)        !(24/4*pi**2)**1/3
!
      DIMENSION N(NSHELL),TUMEL(NSHELL),ALFA(NSHELL)
!
      DCON4=(DSIX/XPI**2)**D1THRD                     !(24/4*pi**2)**1/3
!
!-----------------------------------------------------------------------
!
      T=DZERO
      VX=DZERO
!
      IF(NSHELL.LE.0)GO TO 100            !NO SHELLS, BAIL OUT!
!
      IF(I.LT.0)THEN                      !JUCYS FIT TO THOMAS-FERMI
!
        T2=(-Z0)**(DONE/DTHREE)
        DO J=1,NSHELL
          T1=TUMEL(J)
          RHO=ALFA(J)*R*T2
          T3=DCON2*RHO
          T4=DZERO
          IF(abs(T3).LT.DCON1)T4=EXP(-T3)
          T=T+T1*T4/(DONE+DCON3*RHO)
        ENDDO
!
        GO TO 100
!
      ENDIF
! STO
      SZ=ABS(S)
      Z=-Z0
!
      TI=DZERO
      TE=DZERO
!
      BMEX=MEXPOT.GT.0.AND.MEXPOT.LT.5   !ADD-IN LOCAL EXCHANGE CONTRBN
!
      IF(BMEX)THEN
        IF(MEXPOT.EQ.1)THEN
          XK=D2THRD*AJUSTX                     !L&R ALPHA=4/9 RYD
        ELSEIF(MEXPOT.EQ.2)THEN
          XK=DONE*AJUSTX                       !L&R ALPHA=2/3 RYD
        ELSEIF(MEXPOT.EQ.3)THEN
          XK=D2THRD*AJUSTX                     !COWAN K_X=2/3 RYD
        ELSEIF(MEXPOT.EQ.4)THEN
!            XK=D3HALF                   !ORIGINAL HARTREE-SLATER
          XK=DONE                       !COWAN/FAC H-S: ALPHA=2/3 RYD
!
! FAC AHX IS IN A.U. AND ABSORBS ALL CONSTANTS:
!                          V-FAC_X=AHX*(SUM_I W_I*PROB.DEN._I/R**2)**1/3
! SO
!            faca=0.588  !he
!            faca=0.533  !be
!            write(mw0,*)mk,wk,2*faca/dcon4,xk*t2*dcon4
          XK=2*FACA/DCON4               !SO THAT VX=WK*AHX A.U.
        ENDIF
      ENDIF
!
      WKT=0
      DO J=1,NSHELL
        IF(TUMEL(J).NE.DZERO)THEN
          X=ALFA(J)
          X=X*R
          T1=TUMEL(J)-DONE
          Z=Z-T1*SZ/DTWO
          EN=N(J)
          SQRTE=Z/EN
          RHO=DTWO*SQRTE*X
          IMAX=N(J)+N(J)-1
          T2=EN+EN
          T3=DONE
          T4=DONE/T2
          DO I1=1,IMAX
            T5=I1
            T2=T2-DONE
            T4=T4*RHO/T5
            T3=T3+T4*T2
          ENDDO
          IF(I.NE.J)T1=TUMEL(J)
          T6=DZERO
          IF(abs(RHO).LT.DCON1)T6=EXP(-RHO)
          T=T+T1*T3*T6
          WKT=WKT+T1
!
          IF(BMEX)THEN                  !EXCHANGE
            TJ=T4*T6*RHO*RHO/R**3
            TE=TUMEL(J)*TJ+TE
            IF(I.EQ.J)TI=TJ             !NOT USED BY MEXPOT=4
          ENDIF
!
          T1=TUMEL(J)+DONE
          Z=Z-T1*SZ/DTWO
        ENDIF
      ENDDO
!
!      write(150+i+li,*)r,-z0-t
!
      IF(BMEX)THEN                      !LOCAL EXCHANGE
        IF(MEXPOT.LT.3)THEN             !LINDGREN AND ROSEN  XK=2/3 OR 1
          IF(I.GT.0.AND.NI.LT.0)TE=TE+TI
          TI=TI+TI
          VX=XK*DCON4*(TE**D1THRD-TI**D1THRD)
        ELSEIF(MEXPOT.EQ.3)THEN         !COWAN K_X=2/3
          TJ=TE-TI-TI
          IF(I.GT.0.AND.NI.LT.0)TJ=TJ+TI
          FR=DONE
          EN=ABS(NI)
          EL=LI
          IF(TE.GT.D1M70)VX=XK*DCON4*TE**D1THRD*TJ/TE
          VX=VX*FR*(TJ/(TJ+DTWO*ACOS(-DONE)/(EN-EL)))
        ELSE                            !HARTREE SLATER
          VX=XK*DCON4*TE**D1THRD
        ENDIF
        VX=VX/DTWO                      !RYD TO A.U.
!        write(70+ni,*)r,vx
      ENDIF
!
  100 ZEFX=-T/R-VX
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION ZEFX
!
!                             *******************
!
      FUNCTION ZEFXL(X,ZL,DX,I,E,DZ,ELLP)
!
!-----------------------------------------------------------------------
!
!  N.R.BADNELL D.A.M.T.P. CAMBRIDGE
!  FN.ZEFXL EVALUATES THE INPUT POTENTIAL AT NON-GRID POINT X USING
!  N-PT LAGRANGE INTERPOLATION, WHERE X LIES BETWEEN DX(I) AND DX(I+1).
!  IR REQUIRES I .GT. N/2 , I ALWAYS .GT. 8 WITH THE AS GRID.
!
!  IT IS CALLED BY:
!    SR.FCF6
!
!  IT CALLS:
!    FN.PMVDAR
!
!-----------------------------------------------------------------------
!
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,VSC,XC1,XC2,NPITER
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      DIMENSION ZL(*),DX(*)
!
!-----------------------------------------------------------------------
!
      N=4
      IM=N/2
      IM=I-IM
      V=DZERO
!
      DO J1=1,N
        DD=DONE
        J=IM+J1
!
        DO K1=1,N
          IF(J1.NE.K1)THEN
            K=IM+K1
            DD=DD*(X-DX(K))
            DD=DD/(DX(J)-DX(K))
          ENDIF
        ENDDO
!
        V=V+DD*(ZL(J)+DTWO*VSC(J))
        IF(BREL)V=V+DD*PMVDAR(J,DX(J),E,DZ,ELLP)
!
      ENDDO
!
      ZEFXL=V
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END FUNCTION ZEFXL
!
!                             *******************
!
      SUBROUTINE ZERO
!
!-----------------------------------------------------------------------
!
!  SR.ZERO PRINTS DETAILS OF THE PRIMARY DIMENSIONS FOR AUTOSTRUCTURE.
!
!  IT IS CALLED BY:
!    PR.MAIN
!
!  IT CALLS:
!
!-----------------------------------------------------------------------
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP,XP,RP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      CHARACTER(LEN=5) KNM0
!
      DIMENSION KDIM(MXDIM),KNM0(MXDIM)
!
!
! NOTES ON PRIMARY DIMENSIONS FOR AUTOSTRUCTURE.
! SEE THE MODULE PARAM FOR THE ACTUAL INITIAL VALUES TO BE USED.
!
!
! MXAAI=MAXIMUM NUMBER OF BOUND-CONTINUUM INTERACTIONS IN A GROUP
!         (SAME SL) IN SR.DIAGON. EQUALS NO. OF BOUND TERMS*NO. OF
!         CONTINUUM TERMS=NO. OF AUTOIONIZATION RATES IF ALL
!         BOUND TERMS ARE ENERGETICALLY ACCESSIBLE.
!         SET MXAAI .LT. (MAXDI/2)**2 SINCE ONLY REACHES LIMIT IN SMALL
!         CASES. ARRAY DIMENSION IS MXENG*MXAAI.
!
! MXAAK=MAXIMUM NUMBER OF BOUND-CONTINUUM INTERACTIONS IN A GROUP
!         (SAME J) IN SR.DIAGFS. EQUALS NO. OF BOUND TERMS*NO. OF
!         CONTINUUM TERMS=NO. OF AUTOIONIZATION RATES IF ALL
!         BOUND TERMS ARE ENERGETICALLY ACCESSIBLE.
!         SET MXAAK .LT. (MAXDK/2)**2 SINCE ONLY REACHES LIMIT IN SMALL
!         CASES. ARRAY DIMENSION IS MXENG*MXAAK.
!
! MAXAD=MAXIMUM NUMBER OF DISTINCT MATRIX ELEMENTS ( T ! H ! TP ),
!         (N*(N+1))/2 FOR A N*N H-MATRIX SL (I.E. FOR ONE SL GROUP).
!         UP TO MAXTM ADDITIONAL LOCATIONS ARE NEEDED WHEN COMPUTING
!         RADIATIVE DATA (IF NOT THEN ONLY ONE MORE LOCATION).
!
! MXADJ=MAXIMUM NUMBER OF DISTINCT MATRIX ELEMENTS (LV ! H ! LVP).
!         (N*(N+1))/2 FOR A N*N H-MATRIX J (I.E. FOR ONE J GROUP).
!
! MXAJS=MXADJ FOR TWO-BODY FINE-STRUCTURE, =1 IF NONE.
!
! MAXB1=MAXIMUM NUMBER OF INTEGRATION POINTS FOR RADIAL FUNCTIONS,
!         EFFECTIVE VALUE MAXRS REDUCES ACCORDING TO DEL IN SR.RADIAL
!         MAXB1 FURTHER RELATES TO THE NUMBER OF POINTS OF A USER-
!         SUPPLIED RADIAL FUNCTION P/Q -- POINTS IN EXCESS OF MAXB1
!         (2*MAXB1 IN THE CASE OF PRECISION='DOUBLE') ARE IGNORED.
!         ARRAY DIMENSION MAXB1*MAXGR.
!
! MAXB2=MAXIMUM NUMBER OF INTEGRATION POINTS INVOLVING Q(NL).
!         SET .EQ. MAXB1. USED FOR USER SUPPLIED FUNCTIONS, SMALL
!         COMPONENT OF SEMI-RELATIVISTIC ORBITALS AND NL-DEPENDENT
!         POTENTIALS.
!         ARRAY DIMENSION MAXB1*MAXGR.
!
! MXBIF=MAXIMUM NUMBER OF BORN INTERACTIONS FOR ANY STATE (LS & IC).
!       I.E. IF THERE ARE N-STATES WHICH ALL BORN INTERACT THEN THERE
!       ARE (N*(N+1))/2 DISTINCT INTERACTIONS.
!
! MXBLM=MAXIMUM BORN LAMBDA MULTIPOLE RETAINED (MIN 2). IN GENERAL,
!       NEED TWICE MAX ORBITAL L.
!
! MXCAS=MAXIMUM NUMBER OF CASCADE COEFFICIENTS. SET .EQ. 1 FOR NONE.
!
! MAXCF=MAXIMUM NUMBER OF CONFIGURATIONS.
!
! MXCHG=MAXIMUM NUMBER OF N-ELECTRON TARGET SLP GROUPS WHICH
!       CONTRIBUTE TO AN (N+1)-ELECETRON SLP SYMMETRY.
!
! MAXCL=MAXIMUM NUMBER OF CORE ELECTRONS.
!
! MAXCT=MAXIMUM NUMBER OF (ALGEBRAIC) TERMS - INLUDING BUFFERING.
!
! MAXDC=MAXIMUM NUMBER OF VECTOR COUPLING COEFFICIENTS.
!
! MAXDF=MAXIMUM NUMBER OF TERMS SL IN A CONFIGURATION   (ALGEB1).
!         ARRAY DIMENSION MAXDF**2.
!
! MXDFS=SIZE OF FACTORIAL ARRAY.
!
! MAXDI=MAX. NUMBER OF TERMS IN A GROUP (WITH SAME SL)  (DIAGON).
!         ARRAY DIMENSION MAXDI**2.
!
! MAXDK=MAX. NUMBER OF LEVELS IN A GROUP (WITH SAME J)  (DIAGFS).
!         ARRAY DIMENSION MAXDK**2.
!
! MXEL0=MAXIMUM NUMBER OF VALENCE ELECTRONS.
!
! MXENG=MAXIMUM NUMBER OF INTERPOLATION ENERGIES FOR EACH
!         CONTINUUM ORBITAL. AFFECTS TWO DIMENSIONAL ARRAYS BELOW.
!
! MXEST=SPECIFIES THE SIZE OF TWO DIMENSIONAL QUANTUM NUMBER ARRAYS
!         REPRESENTING SLATER STATES. PROVIDE AT LEAST (NUMBER MAXEL
!         OF VALENCE ELECTRONS)*(NUMBER MAXST OF SLATER STATES+1)
!         LOCATIONS. NOTE: ALTHOUGH MXEST CANNOT EXCEED MXEL0*MXST0,
!         ONE RARELY USES THE MAXIMUM DIMENSIONED MXEL0 & MXST0 AT
!         THE SAME TIME SO DIMENSIONING AS SUCH IS INEFFICIENT.
!
! MXFSL=MAXIMUM NUMBER OF NON-ZERO BOUND-CONTINUUM SLATER INTEGRALS.
!         ARRAY DIMENSION IS MXENG*MXFSL.
!
! MXFSS=MAXIMUM NUMBER OF NON-ZERO BOUND-CONTINUUM FINE-STRUCTURE
!         INTEGRALS. ARRAY DIMENSION IS MXENG*MXFSS.
!
! MXFOO=MAXIMUM NUMBER OF NON-ZERO BOUND-CONTINUUM NON-FINE-STRUCTURE
!         INTEGRALS. ARRAY DIMENSION IS MXENG*MXFOO.
!
! MAXGR=MAXIMUM NUMBER OF DISTINCT ORBITAL VALUES (N,L)  --
!         ADAPT SR.ALGEB1 (LIT, DO39 ETC) IF MAXGR.GT.60 REQUIRED.
!         ARRAY DIMENSION IS MAXGR*MAXB1.
!
! MXGRB=NO. OF NON-CORE (N,L) ORBITALS USED FOR BORN INTEGRALS.
!
! MAXJG=MAXIMUM NUMBER OF DISTINCT LEVEL VALUES J (AND PARITY).
!
! MAXJU=MAXIMUM NUMBER OF CONFIGURATION MIXING COEFFICIENTS IN
!         INTERMEDIATE COUPLING. REQUIRES AT LEAST
!         THE TOTAL NUMBER OF ELEMENTS IN THE REDUCED H-MATRIX.
!         APPROX=2*MXADJ TO CALCULATE RADIATIVE RATES.
!         IF NONE REQUIRED THEN ONLY MAXDK**2 IS NEEDED.
!
! MAXLL=BIGGEST ORBITAL L+1 INCLUDED IN INTERNAL TABLES OF ANGULAR
!         MOMENTUM FUNCTIONS-WHICH SAVE COMPUTING TIME FOR SUCH
!         ORBITALS, THOUGH AT THE EXPENSE OF 2*(MAXLL+1)**5 WORDS.
!         A VALUE OF 8 OR SO WILL IN GENERAL NOT INCREASE THE
!         EFFECTIVE SIZE OF AUTOSTRUCTURE.
!         MAXLL AFFECTS THE BRANCHES ALGEB2 AND ALGEB3.
!         =0 CALCULATES ALL ON-THE-FLY (NONE STORED).
!         N.B. CHANGE IN HISTORIC DEFAULT SO THAT -1 CAN INTERNALLY
!         RE-SET TO HISTORIC "DEFAULT".
!
! MAXLV=MAXIMUM NUMBER OF LEVELS LV.
!
! MAXMI=MAXIMUM NUMBER OF MAGNETIC INTEGRALS, N AND V.
!
! MXNOR=LOCATIONS (-1) AVAILABLE TO STORE NON-VANISHING ELECTRIC
!         DIPOLE TRANSITION PROBABILITIES (.GE.1.E-2/SEC) IN INTER-
!         MEDIATE COUPLING, USED FOR OPTIONAL CASCADE COEFFICIENTS.
!         =1 FOR NONE.
!
! MXPOT=NUMBER OF DISTINCT L-DEPENDENT POTENTIALS STORED
!         READY FOR USE IN EVALUATION OF CONTINUUM FUNCTIONS IN
!         SR.RADCON. ARRAY DIMENSION MXPOT*MAXB1.
!
! MAXRK=MAXIMUM NUMBER OF COEFFICIENTS TO SLATER INTEGRALS R.
!         EACH REDUCED ALGEBRAIC MATRIX ELEMENT FOR DIPOLE OR
!         QUADRUPOLE RADIATION REQUIRES ONE ADDITIONAL LOCATION.
!         TERM RESOLVED.
!
! MXRKO=MAXIMUM NUMBER OF COEFFICIENTS TO ORBIT-ORBIT INTEGRALS.
!       =1 FOR NO NON-FINE-STRCUTURE OR =MAXRK FOR NFS.
!
! MXRKS=MAXIMUM NUMBER OF COEFFICIENTS TO SLATER INTEGRALS R.
!       SIMILAR TO MAXRK BUT SLATER STATE RESOLVED, AND PER SYMMETRY.
!
! MAXRL=MAXIMUM NUMBER OF SLATER INTEGRALS R (ALL SL SYMMETRIES).
!
! MXRLO=MAXIMUM NUMBER OF ORBIT-ORBIT INTEGRALS.
!       =1 FOR NO NON-FINE-STRCUTURE OR =MAXRL FOR NFS.
!
! MXRLS=MAXIMUM NUMBER OF SLATER INTEGRALS R.
!       SIMILAR TO MAXRL BUT SLATER STATE RESOLVED, AND PER SYMMETRY.
!
! MXROS=MAXIMUM NUMBER OF COEFFICIENTS TO ORBIT-ORBIT INTEGRALS.
!       SIMILAR TO MAXRO BUT SLATER STATE RESOLVED, AND PER SYMMETRY.
!
! MXRSS=MAXIMUM NUMBER OF ALGEBRAIC COEFFICIENTS E AND D (TO N, V).
!
! MAXSL=MAXIMUM NUMBER OF DISTINCT TERM VALUES SL (AND PARITY).
!
! MXSOC=MAXIMUM NUMBER OF ALGEBRAIC COEFFICIENTS C (TO ZETA).
!
! MXSOI=MAXIMUM NUMBER OF DISTINCT SPIN-ORBIT INTEGRALS ZETA.
!
! MXST0=MAXIMUM NUMBER OF SLATER STATES, ALLOWING FOR ONE
!         ADDITIONAL BUFFER LOCATION. TO MAXIMISE EFFICIENT USE OF
!         MXEST SET MXST0=MXEST/2 IF POSSIBLE.
!
! MXSTX=MAXIMUM NUMBER OF N-ELECTRON TARGET SLATER STATE INTERACTIONS.
!       (OF ORDER (MXST0/2)**2)
!
! MXSYJ=MAXIMUM NUMBER OF (N+1)-ELECTRON SLP SYMMETRIES WHICH
!       CONTRIBUTE TO A JP SYMMETRY
!
! MXS1C=MAXIMUM NUMBER OF COEFFICIENTS TO 1-BODY SPIN-ORBIT INTEGRALS
!       SIMILAR TO MXSOC BUT SLATER STATE RESOLVED, AND PER SYMMETRY.
!
! MXS1I=MAXIMUM NUMBER OF 1-BODY SPIN-ORBIT INTEGRALS
!       SIMILAR TO MXSOI BUT SLATER STATE RESOLVED, AND PER SYMMETRY.
!
! MXS2C=MAXIMUM NUMBER OF COEFFICIENTS TO 2-BODY FINE-STRUCTURE INTGRLS
!       SIMILAR TO MXRSS BUT SLATER STATE RESOLVED, AND PER SYMMETRY.
!
! MXS2I=MAXIMUM NUMBER OF 2-BODY FINE-STRUCTURE INTEGRALS
!       SIMILAR TO MAXMI BUT SLATER STATE RESOLVED, AND PER SYMMETRY.
!
! MAXTM=MAXIMUM NUMBER OF (HAMILTONIAN) TERMS T.
!
! MAXTR=THE SIZE OF A BUFFER ARRAY TO HOLD TERM COUPLING COEFFI-
!         CIENTS, FOR BOTH PARITIES OF ANY VALUE J: .LE.2*MAXDK**2.
!
! MAXUC=MAXIMUM NUMBER OF CONFIGURATION MIXING COEFFICIENTS IN
!         SL COUPLING. REQUIRES AT LEAST
!         THE TOTAL NUMBER OF ELEMENTS IN THE REDUCED H-MATRIX.
!         APPROX=2*MAXAD TO CALCULATE RADIATIVE RATES.
!         IF NONE REQUIRED THEN ONLY MAXDI**2 IS NEEDED.
!
! MXVAR=MAXIMUM NUMBER OF VARIATIONAL PARAMETERS. SET .EQ. MAXGR
!         FOR V(NL) OR 1+MAX(L) FOR V(L), ORBITALS NL.
!
!
      DATA KNM0( 1),KNM0( 2),KNM0( 3)  /'MXAAI','MXAAK','MAXAD'/
      DATA KNM0( 4),KNM0( 5),KNM0( 6)  /'MXADJ','MXAJS','MAXB1'/
      DATA KNM0( 7),KNM0( 8),KNM0( 9)  /'MAXB2','MXBIF','MXBLM'/
      DATA KNM0(10),KNM0(11),KNM0(12)  /'MXCAS','MAXCF','MXCHG'/
      DATA KNM0(13),KNM0(14),KNM0(15)  /'MAXCL','MAXCT','MAXDC'/
      DATA KNM0(16),KNM0(17),KNM0(18)  /'MAXDF','MXDFS','MAXDI'/
      DATA KNM0(19),KNM0(20),KNM0(21)  /'MAXDK','MXEL0','MXENG'/
      DATA KNM0(22),KNM0(23),KNM0(24)  /'MXEST','MXFSL','MXFSS'/
      DATA KNM0(25),KNM0(26),KNM0(27)  /'MXFOO','MAXGR','MXGRB'/
      DATA KNM0(28),KNM0(29),KNM0(30)  /'MAXJG','MAXJU','MAXLL'/
      DATA KNM0(31),KNM0(32),KNM0(33)  /'MAXLV','MAXMI','MXNOR'/
      DATA KNM0(34),KNM0(35),KNM0(36)  /'MXPOT','MAXRK','MXRKO'/
      DATA KNM0(37),KNM0(38),KNM0(39)  /'MXRKS','MAXRL','MXRLO'/
      DATA KNM0(40),KNM0(41),KNM0(42)  /'MXRLS','MXROS','MXRSS'/
      DATA KNM0(43),KNM0(44),KNM0(45)  /'MAXSL','MXSOC','MXSOI'/
      DATA KNM0(46),KNM0(47),KNM0(48)  /'MXST0','MXSTX','MXSYJ'/
      DATA KNM0(49),KNM0(50),KNM0(51)  /'MXS1C','MXS1I','MXS2C'/
      DATA KNM0(52),KNM0(53),KNM0(54)  /'MXS2I','MAXTM','MAXTR'/
      DATA KNM0(55),KNM0(56)           /'MAXUC','MXVAR'/
      DATA KDIM( 1),KDIM( 2),KDIM( 3)    /MXAAI,MXAAK,MAXAD/
      DATA KDIM( 4),KDIM( 5),KDIM( 6)    /MXADJ,MXAJS,MAXB1/
      DATA KDIM( 7),KDIM( 8),KDIM( 9)    /MAXB2,MXBIF,MXBLM/
      DATA KDIM(10),KDIM(11),KDIM(12)    /MXCAS,MAXCF,MXCHG/
      DATA KDIM(13),KDIM(14),KDIM(15)    /MAXCL,MAXCT,MAXDC/
      DATA KDIM(16),KDIM(17),KDIM(18)    /MAXDF,MXDFS,MAXDI/
      DATA KDIM(19),KDIM(20),KDIM(21)    /MAXDK,MXEL0,MXENG/
      DATA KDIM(22),KDIM(23),KDIM(24)    /MXEST,MXFSL,MXFSS/
      DATA KDIM(25),KDIM(26),KDIM(27)    /MXFOO,MAXGR,MXGRB/
      DATA KDIM(28),KDIM(29),KDIM(30)    /MAXJG,MAXJU,MAXLL/
      DATA KDIM(31),KDIM(32),KDIM(33)    /MAXLV,MAXMI,MXNOR/
      DATA KDIM(34),KDIM(35),KDIM(36)    /MXPOT,MAXRK,MXRKO/
      DATA KDIM(37),KDIM(38),KDIM(39)    /MXRKS,MAXRL,MXRLO/
      DATA KDIM(40),KDIM(41),KDIM(42)    /MXRLS,MXROS,MXRSS/
      DATA KDIM(43),KDIM(44),KDIM(45)    /MAXSL,MXSOC,MXSOI/
      DATA KDIM(46),KDIM(47),KDIM(48)    /MXST0,MXSTX,MXSYJ/
      DATA KDIM(49),KDIM(50),KDIM(51)    /MXS1C,MXS1I,MXS2C/
      DATA KDIM(52),KDIM(53),KDIM(54)    /MXS2I,MAXTM,MAXTR/
      DATA KDIM(55),KDIM(56)             /MAXUC,MXVAR/
!
      IF(BFYRZT)THEN
!
        WRITE(MW6,10010)
        WRITE(MW6,10020)
        WRITE(MW6,10030)
!
! PRINT INFO ON PRECISION
!
        WRITE(MW6,10070)
        WRITE(MW6,10080)KIND(.TRUE._BP)
        WRITE(MW6,10090)KIND(1_QP),RANGE(1_QP)
        WRITE(MW6,10100)KIND(1_SP),RANGE(1_SP)
        WRITE(MW6,10110)KIND(1_EP),RANGE(1_EP)
        WRITE(MW6,10120)KIND(1.0_RP),RANGE(1.0_RP),PRECISION(1.0_RP)
        WRITE(MW6,10130)KIND(1.0_WP),RANGE(1.0_WP),PRECISION(1.0_WP)
        IF(XP.NE.WP)WRITE(MW6,10140)KIND(1.0_XP),RANGE(1.0_XP),         &
     &                              PRECISION(1.0_XP)
!
        IF(QP.GT.SP)THEN
          WRITE(MW6,*)' *** ERROR: SHORT INTEGER BYTE LENGTH IS',       &
     &                ' GREATER THAN THE DEFAULT ONE!'
          STOP ' *** INTEGER BYTE LENGTH MIS-MATCH!'
        ENDIF
!
        IF(EP.LT.SP)THEN
          WRITE(MW6,*)' *** ERROR: EXTENDED INTEGER BYTE LENGTH IS',    &
     &                ' SHORTER THAN THE DEFAULT ONE!'
          STOP ' *** INTEGER BYTE LENGTH MIS-MATCH!'
        ENDIF
!
        IF(RP.GT.WP)THEN
          WRITE(MW6,*)' *** ERROR: SHORT REAL BYTE LENGTH IS',          &
     &                ' GREATER THAN THE DEFAULT ONE!'
          STOP ' *** REAL BYTE LENGTH MIS-MATCH!'
        ENDIF
!
        IF(XP.LT.WP)THEN
          WRITE(MW6,*)' *** ERROR: EXTENDED REAL BYTE LENGTH IS',       &
     &                ' SHORTER THAN THE DEFAULT ONE!'
          STOP ' *** REAL BYTE LENGTH MIS-MATCH!'
        ENDIF
!
        IF(PRECISION(1.0_WP).LT.10)THEN
          WRITE(MW6,*)' *** STRONG WARNING: DEFAULT REAL PRECISION IS', &
     &                ' LIKELY TOO SHORT; AT BEST INACCURATE...'
          WRITE(MW0,*)' *** STRONG WARNING: DEFAULT REAL PRECISION IS', &
     &                ' LIKELY TOO SHORT; AT BEST INACCURATE...'
        ENDIF
!
! PRINT MAX DIMENSIONS
!
        WRITE(MW6,10040)(KNM0(I),KDIM(I),I=1,MXDIM)
        BFYRZT=.FALSE.
        DO I=1,MXDIM
          MXUSED(I)=0
          KNAM(I)=KNM0(I)
        ENDDO
!
        IF(KDIM(30).NE.-1)THEN
          WRITE(MW0,10150)
          WRITE(MW6,10150)
        ENDIF
!
      ELSE                                         !PRINT DIMENSION USED
!
!        MXUSED(30)=MXUSED(30)-1                            !ALIGN MAXLL
!
        WRITE(MW6,10050)(KNAM(I),MXUSED(I),I=1,MXDIM)
        WRITE(MW6,10060)
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
10010 FORMAT(///132('*')/132('*')///31X,                                &
     &       ' AAAAAAAA      UU      UU     TTTTTTTTTT      OOOOOOOO',  &
     &       /31X,                                                      &
     &       'AAAAAAAAAA     UU      UU     TTTTTTTTTT     OOOOOOOOOO', &
     &       /31X,                                                      &
     &       'AA      AA     UU      UU         TT         OO      OO', &
     &       /31X,                                                      &
     &       'AA      AA     UU      UU         TT         OO      OO', &
     &       /31X,                                                      &
     &       'AA      AA     UU      UU         TT         OO      OO', &
     &       /31X,                                                      &
     &       'AA      AA     UU      UU         TT         OO      OO', &
     &       /31X,                                                      &
     &       'AAAAAAAAAA     UU      UU         TT         OO      OO', &
     &       /31X,                                                      &
     &       'AAAAAAAAAA     UU      UU         TT         OO      OO', &
     &       /31X,                                                      &
     &       'AA      AA     UU      UU         TT         OO      OO', &
     &       /31X,                                                      &
     &       'AA      AA     UU      UU         TT         OO      OO', &
     &       /31X,                                                      &
     &       'AA      AA     UUUUUUUUUU         TT         OOOOOOOOOO', &
     &       /31X,                                                      &
     &       'AA      AA      UUUUUUUU          TT          OOOOOOOO')
10020 FORMAT(//1X,                                                      &
     &       ' SSSSSSSS      TTTTTTTTTT     RRRRRRRRR      UU      UU', &
     &   '      CCCCCCCC      TTTTTTTTTT     UU      UU     RRRRRRRRR  '&
     &   ,'    EEEEEEEEEE'/1X,                                          &
     &   'SSSSSSSSSS     TTTTTTTTTT     RRRRRRRRRR     UU      UU',     &
     &   '     CCCCCCCCCC     TTTTTTTTTT     UU      UU     RRRRRRRRRR '&
     &   ,'    EEEEEEEEEE'/1X,                                          &
     &   'SS                 TT         RR      RR     UU      UU',     &
     &   '     CC      CC         TT         UU      UU     RR      RR '&
     &   ,'    EE'/1X,                                                  &
     &   'SS                 TT         RR      RR     UU      UU',     &
     &   '     CC                 TT         UU      UU     RR      RR '&
     &   ,'    EE'/1X,                                                  &
     &   'SS                 TT         RR     RR      UU      UU',     &
     &   '     CC                 TT         UU      UU     RR     RR  '&
     &   ,'    EE'/1X,                                                  &
     &   'SSSSSSSSS          TT         RRRRRRRR       UU      UU',     &
     &   '     CC                 TT         UU      UU     RRRRRRRR   '&
     &   ,'    EEEEEEEEE')
10030 FORMAT(1X,                                                        &
     &       ' SSSSSSSSS         TT         RRRRRR         UU      UU', &
     &   '     CC                 TT         UU      UU     RRRRRR     '&
     &   ,'    EEEEEEEEE'/1X,                                           &
     &   '        SS         TT         RR   RR        UU      UU',     &
     &   '     CC                 TT         UU      UU     RR   RR    '&
     &   ,'    EE'/1X,                                                  &
     &   '        SS         TT         RR    RR       UU      UU',     &
     &   '     CC                 TT         UU      UU     RR    RR   '&
     &   ,'    EE'/1X,                                                  &
     &   '        SS         TT         RR     RR      UU      UU',     &
     &   '     CC     CC          TT         UU      UU     RR     RR  '&
     &   ,'    EE'/1X,                                                  &
     &   'SSSSSSSSSS         TT         RR      RR     UUUUUUUUUU',     &
     &   '     CCCCCCCCC          TT         UUUUUUUUUU     RR      RR '&
     &   ,'    EEEEEEEEEE'/1X,                                          &
     &   ' SSSSSSSS          TT         RR       RR     UUUUUUUU ',     &
     &   '      CCCCCCC           TT          UUUUUUUU      RR       RR'&
     &   ,'    EEEEEEEEEE'///132('*')/132('*')////)
10040 FORMAT(/////' THIS VERSION OF AUTOSTRUCTURE (30.19.8) IS COMPILED'&
     &       ,' WITH THE FOLLOWING ALLOCATABLE STORAGE PARAMETERS-'//   &
     &       /4(4X,'NAME',6X,'VALUE',10X)//4(3X,A5,I11,10X))
10050 FORMAT(///1X,131('-')///' SUMMARY OF STORAGE USED-'//             &
     &       /4(4X,'NAME',6X,'VALUE',10X)//4(3X,A5,I11,10X))
10060 FORMAT(//' *** THIS INCLUDES BUFFER REQUIREMENTS, THE NUMBER OF', &
     &       ' ACTUAL PHYSICAL QUANTITIES MAYBE LESS ***'//109('-'))
10070 FORMAT(/' WORD INFO-')
10080 FORMAT(/'            LOGICAL BYTE LENGTH=',I3)
10090 FORMAT(/'      SHORT INTEGER BYTE LENGTH=',I3,5X,'RANGE=',I5)
10100 FORMAT('    DEFAULT INTEGER BYTE LENGTH=',I3,5X,'RANGE=',I5)
10110 FORMAT('   EXTENDED INTEGER BYTE LENGTH=',I3,5X,'RANGE=',I5)
10120 FORMAT(/'      SHORT    REAL BYTE LENGTH=',I3,5X,'RANGE=',I5,5X,  &
     &       'PRECISION=',I2)
10130 FORMAT('    DEFAULT    REAL BYTE LENGTH=',I3,5X,'RANGE=',I5,5X,   &
     &       'PRECISION=',I2)
10140 FORMAT('   EXTENDED    REAL BYTE LENGTH=',I3,5X,'RANGE=',I5,5X,   &
     &       'PRECISION=',I2)
10150 FORMAT(/'N.B. MAXLL.GE.0 NOW SETS MAX(L)+1 OF VCC STORED TABLES')
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE ZERO
!
!                             *******************
!
      SUBROUTINE ZETA(K1,K3,TZETA)
!
!-----------------------------------------------------------------------
!
!  SR.ZETA EVALUATES THE ORDINARY NUCLEAR SPIN-ORBIT ZETA INTEGRAL,
!  BUT OMITS Z.
!
!  Q.NE.0 (BREL2) CASE IREL.GT.0 ONLY
!  BREL/2 USES SMALL R CORRECTION
!
!  IT IS CALLED BY:
!    SR.SOCC
!
!  IT CALLS:
!    SR.DIFF
!    SR.WEDDLE
!
!  IT CONTAINS:
!    FN.ICOL
!
!-----------------------------------------------------------------------
!
      USE COMMON_BASIC,  ONLY: NF
      USE COMMON_CMESH,  ONLY: DHNS,MNH,MJH,MAXRS
      USE COMMON_DBD2,   ONLY: QL,QN,DEY
      USE COMMON_GENINF, ONLY: DADJUS,SCREEN,MION,NZION,NPARAM          &
     &                        ,ITOL,INCLUD,JPRINT,JEND
      USE COMMON_RADF,   ONLY: DPNL,DUY,DX,DORIG
!
      USE COMMON_NRBDEN, ONLY: MDEN,MP0,DEBYE,GAMQ,ZNP0,DENI,DENE,TKAY  &
     &                        ,VSC,XC1,XC2,NPITER
      USE COMMON_NRBDQE, ONLY: DQNL
      USE COMMON_NRBPOT, ONLY: POTHAM,MPSEUD
      USE COMMON_NRBREL, ONLY: IREL,KAPPA,IGAGR,irtard,ibreit           &
     &                        ,BREL,BJUMPR,BMVD
      USE COMMON_NRBREL, ONLY: RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0
      USE COMMON_NRBREL, ONLY: DNUK0,DNUK1,DNUK2,DNUK
!
      use common_nrbtmp, only: rnorm
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
      ALLOCATABLE :: DPA(:),DP(:)
!
!-----------------------------------------------------------------------
!
! THE NAMES HERE ARE NOT NECESSARILY SIGNIFICANT THEY ARE COMMON LEGACY.
!
! LOCAL
      ALLOCATE(DPA(MAXRS),DP(MAXRS),STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.ZETA: ALLOCATION FAILS FOR DPA,DP'
        TZLAM=DZERO
        NF=0                                                !NOT TRACKED
        RETURN
      ENDIF
!
!-----------------------------------------------------------------------
!
      BREL2=ABS(IREL).EQ.2
!
      DZ=NZION
      DD=DONE
      INUKP=INUK+1
!
      IK1=ICOL(K1,K1,IZERO)
      IK3=ICOL(K3,K3,IZERO)
      DE1=DEY(K1)-DUY(IK1)   !BREL K1=K3 CURRENTLY
      DE3=DEY(K3)-DUY(IK3)   !BREL K1=K3 CURRENTLY
!
      IF(BREL2)THEN
        T=DALF4*DTWO
        DO I=INUKP,MAXRS
          DD1=DONE+T*(DE1+DZ/DX(I))
          DD3=DONE+T*(DE3+DZ/DX(I))
!          DD1=DONE+T*(DE1+POT(I,1))
!          DD3=DONE+T*(DE3+POT(I,1))
          DP(I)=DPNL(I,K1)*DPNL(I,K3) !+DQNL(I,K1)*DQNL(I,K3)
          DP(I)=DP(I)/(SQRT(DD1*DD3)*DX(I)*DX(I)*DX(I))
        ENDDO
      ELSE
!
        IF(IREL.LT.0)THEN
          IF(MPSEUD.LT.0)THEN
            DO I=1,MAXRS
              DP(I)=POTHAM(I)/DZ-DONE/DX(I)
            ENDDO
          ELSE
            IF(K1.EQ.K3)THEN
              DO I=1,MAXRS
                DP(I)=DQNL(I,K1)/(DTWO*DPNL(I,K1))
                DP(I)=(DP(I)-DE1)/DZ
              ENDDO
            ELSE
              DO I=1,MAXRS
                DP(I)=DQNL(I,K1)*DQNL(I,K3)/(DPNL(I,K1)*DPNL(I,K3))
                DP(I)=-SQRT(DP(I))/(DTWO*DZ)
              ENDDO
            ENDIF
          ENDIF
          CALL DIFF(DP,DPA,MNH,DHNS,MJH)           !POTENTIAL DERIVATIVE
        ENDIF
!
        DO I=INUKP,MAXRS
          DP(I)=DPNL(I,K1)*DPNL(I,K3)/(DX(I)*DX(I)*DX(I))
        ENDDO
!
        IF(IREL.LT.0)THEN
          DO I=INUKP,MAXRS
            DP(I)=DP(I)-DP(I)*DPA(I)*DX(I)*DX(I)
!            dpa(i)=dp(i)*dpa(i)*dx(i)*dx(i)
          ENDDO
        ENDIF
!
        IF(BREL)THEN
!         write(mw0,*)k1,k3
          T=DALF4*DTWO
          DO I=INUKP,MAXRS
!        write(mw6,*)i,dqnl(i,k1),dqnl(i,k3),dpnl(i,k1),dpnl(i,k3),dx(i)
            DD1=DONE+DALF4*(DQNL(I,K1)/DPNL(I,K1)+DTWO*DZ/DX(I))
            DD3=DONE+DALF4*(DQNL(I,K3)/DPNL(I,K3)+DTWO*DZ/DX(I))
!            dd1=done+t*(de1+dz/dx(i))
!            dd3=done+t*(de3+dz/dx(i))
            DP(I)=DP(I)/SQRT(DD1*DD3)
!            DP(I)=DP(I)*(1./DD1+1./DD3)*.5     !test k1.ne.k3
          ENDDO
          dd=dd*rnorm(k1)*rnorm(k3)
!          write(mw0,*)rnorm(k1),rnorm(k3)
        ENDIF
!
!        if(irel.lt.0)then
!          do i=1,maxrs
!            dp(i)=dp(i)-dpa(i)
!          enddo
!        endif
!
      ENDIF
!
      IF(RNUK.GT.DZERO)THEN
        DO I=1,INUK
          DP(I)=-DNUK1(I)/DZ
          IF(IREL.LT.0)DP(I)=DP(I)-DPA(I)
          DP(I)=DP(I)/DX(I)
          DP(I)=DP(I)*DPNL(I,K1)*DPNL(I,K3) !+DQNL(I,K1)*DQNL(I,K3))
        ENDDO
        IF(BREL)THEN
          DO I=1,INUK
            DD1=DONE+T*(DE1+DNUK0(I))
            DD3=DONE+T*(DE3+DNUK0(I))
            DP(I)=DP(I)/SQRT(DD1*DD3)
          ENDDO
        ENDIF
      ENDIF
!
      IF(DENE.GT.DZERO)THEN
        MDEN10=MOD(MDEN,ITEN)
        IF(MDEN10.EQ.1.AND.NPITER.GE.0)THEN      !DEBYE-HUCKEL SCREENING
          DO I=1,MAXRS
            T=-DX(I)/DEBYE
            DP(I)=DP(I)*EXP(T)
          ENDDO
!        ELSEIF(MDEN10.EQ.2)THEN                  !ION-SPHERE SCREENING
        ENDIF
      ENDIF
!
      CALL WEDDLE(DZERO,DP,DKU,MNH,DHNS,MJH,MAXRS)
!
      TZETA=DKU*DD*DALF4
!
!-----------------------------------------------------------------------
!
! LOCAL
      DEALLOCATE(DPA,DP,STAT=IERR)
!
      IF(IERR.NE.0)THEN
        WRITE(MW0,*)'SR.ZETA: DE-ALLOCATION FAILS FOR DPA,DP'
        NF=0
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------
      FUNCTION ICOL(ILI,ILF,IONE1)
!
      INTEGER(SP) ILI,ILF,IONE1,ICOL
!
      ICOL=((ILF-1)*(ILF-2*IONE1))/2+ILI
!
      END FUNCTION ICOL
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE ZETA
!
!                             *******************
!
      SUBROUTINE ZLAM(LAM,K1,K2,K3,K4,TZLAM)
!
!-----------------------------------------------------------------------
!
!  SR.ZLAM EVALUATES THE Z-LAMDA INTEGRAL OF ORBIT-ORBIT INTERACTION.
!
!  IT IS CALLED BY:
!    SR.SLATR
!    SR.SLATRI
!    SR.SLATRX
!
!  IT CALLS:
!    SR.TLAM
!    SR.ULAM
!    SR.VLAM
!
!-----------------------------------------------------------------------
!
      USE COMMON_DBD2,   ONLY: QCP,QCG,QL,QN,DEY
!
      USE PRECSN, ONLY: BP,QP,SP,EP,WP
      USE PARAM
      USE UTILITY
      USE CONSTANTS
!
!-----------------------------------------------------------------------
!
      IMPLICIT REAL(WP) (A,C-H,O-P,R-Z)
      IMPLICIT LOGICAL(BP) (B)
      IMPLICIT INTEGER(SP) (I-N)
      IMPLICIT INTEGER(QP) (Q)
!
!      INCLUDE './INCLUDE'
!
!-----------------------------------------------------------------------
!
      Z=DZERO
      IF(LAM.eq.0.or.k1.eq.k3.or.k2.eq.k4)GO TO 100 !apply anti-symmetry
!
      LP=LAM+1
      LM=LAM-1
      LLP=LAM*LP
      LM2=LAM-2
      L1=QL(K1)/2
      L1P=L1*(L1+1)
      L2=QL(K2)/2
      L2P=L2*(L2+1)
      L3=QL(K3)/2
      L3P=L3*(L3+1)
      L4=QL(K4)/2
      L4P=L4*(L4+1)
      T1=LLP
      L2=L1P-L3P-LLP
      T2=L2
      L3=L2P-L4P-LLP
      T3=L3
      L6=L2*L3
      LAM2=LM2*L6
      T6=L6
! JONES INCORRECT    T6=SQRT(T6)
!
      T=LAM+3
      T7=(LAM+1)*(2*LAM+3)
      T7=-T/T7
      T=LM2
      T8=LAM*(2*LAM-1)
      T8=T/T8
!
      CALL TLAM(LP,K1,K2,K3,K4,TP)
      CALL TLAM(LM,K1,K2,K3,K4,TM)
!
      UP1=DZERO
      IF(L2.NE.0)CALL ULAM(LP,K1,K2,K3,K4,UP1)
      UM1=DZERO
      IF(L2.NE.0)CALL ULAM(LM,K1,K2,K3,K4,UM1)
      UP2=DZERO
      IF(L3.NE.0)CALL ULAM(LP,K2,K1,K4,K3,UP2)
      UM2=DZERO
      IF(L3.NE.0)CALL ULAM(LM,K2,K1,K4,K3,UM2)
      V1=DZERO
      IF(L6.NE.0)CALL VLAM(LAM,K1,K2,K3,K4,V1)
      V2=DZERO
      IF(LAM2.NE.0)CALL VLAM(LM2,K1,K2,K3,K4,V2)
!
      Z=T1*(TP-TM)+T2*(UP1-UM1)+T3*(UP2-UM2)+T6*(T7*V1+T8*V2)
! JONES INCORRECT, -T1
!
  100 TZLAM=Z
!
!     WRITE(MW6,100) K1, K2, K3, K4, 2*LAM, ZLAM
!100  FORMAT(8X,2(I5,I4),I6,F14.7,' =ZLAM')
!
!-----------------------------------------------------------------------
!
      RETURN
!
!-----------------------------------------------------------------------
!
      END SUBROUTINE ZLAM
