C N. R. BADNELL             UoS v4.8                    29/06/21
C
C                     PROGRAM STGBF0DAMP
C             BASED-ON STGF v4.9 and STGFDAMP v4.8
C
C  PARTIAL/DAMPED CALCULATIONS FOR FREE ELECTRONS.
C
C  RECENT MODIFICATIONS
C        NEW NAMELIST I/O
C        PERTURBING POTENTIALS REWORKED
C        QUADRUPOLE TOP-UP
C        DIPOLE TOP-UP CAN USE CBE
C        RADIATIVE DECAYS IN B.P. MODE
C        INFINITE ENERGY OMEGA'S (DIPOLE)
C        OCTUPOLE ETC. TOP-UP
C        OCTUPOLE ETC. PERTURBING POTENTIALS
C        DETAILED SQDT, WITH TYPE-I DAMPING, FOR DR/RE
C        DETAILED MQDT, WITH TYPE-I AND II DAMPING, FOR DR/RE
C        CORE AUGER DAMPING
C        PARTIAL DAMPED PHOTO-ABSORPTION/IONIZATION/RECOMBINATION
C        NEUTRAL CASE ADDED
C        DARC HD.DAT (AND H.DAT VIA DARC INTERFACE)
C        PARTITIONED H.DAT
C
C
C
      PROGRAM MAIN
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (MZKIL=  0)
C
      PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2)
      PARAMETER (MXOM=MZMEG*1000000+MZKIL*1000)
      PARAMETER (MNPEXT=MZMNP+MZCHF)
      PARAMETER (MXF=5)         !(MZLMX+1)/2)
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
      PARAMETER (THREE=3.0)
      PARAMETER (FOUR=4.0)
      PARAMETER (EINF=1.0D6)
C
      LOGICAL QDT,WARN,WARNE,QJUMP,PQRD,BFORM
C
      CHARACTER NAME*3,NUM(0:9)*1,PERT*3,ELAS*3,NAMKLS*7,PRINT*6
C SUN
      REAL*4 TARRY(2)
C
      DIMENSION MSLP(MZSLP)
C
      COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC
      COMMON/CBODE/WBODE(MZPTS),TBODE(MZPTS,MZLMX+1)
      COMMON/CDEC/ARAD(MXTST),ARDEC(MZTAR),SLIN(MXTST),IRDEC,IEND
     X           ,IPAR(MZTAR),NEWAR
      COMMON/CDEGEN/ENATR(MZTAR),NASTD,NASTR,NLEV(MZTAR),NCNATR(MZTAR)
     X             ,IWD(MZTAR),IWT
      COMMON/CEN/ETOT,MXE,NWT,NZ
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CMESH/EMAX,EMIN,DEOPEN,DQN,QNMAX,EMESH(MZMSH),IMESH
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/CNTRLS/ISGPT,ITRMN,ITRMX
      COMMON/COMEGA/OMEGA(MXTST),IE,NOMWRT
      COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2
      COMMON/CQDT/R2ST(MZCHF),QDT,NQ
      COMMON/CTOP/LRGLAM,LITLAM(MXTST),NTOP(MXTST,2),NTCHAN(MZTAR,2),
     X INDM,TOPA(MXTST),TOPB(MXTST),NTOPA(MXTST,2),NTOPB(MXTST,2),
     X MTOPA(MXTST,2),MTOPB(MXTST,2),FTOPA(MXTST,MXF),FTOPB(MXTST,MXF),
     X KTOPA(MXTST),KTOPB(MXTST),LRGLMN
      COMMON/CWARN/WARN
      COMMON/DBUT/EBUTD(MZNRG,MZLP1),CBUTD(MZNRG,MZLP1),NBUTD(MZNRG)
     X           ,K2P(MZCHF)
      COMMON/MEMORY/OMEM(MXOM+1),MPOS(0:MZMSH),ITMAX,JTMAX
      COMMON/NRBCBE/RBE(MZCHF,MZCHF),LCBE
      COMMON/NRBDR/PDR(MZCHF),OMEGDR(MZMET,MZMSH),NDRMET
      COMMON/NRBHYB/FNUHYB,NCHCL,ICHCL(MZCHF),NCHHYB,ICHHYB(MZCHF)
      COMMON/NRBLMX/LMX
      COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT
      COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN
      COMMON/NRBSKP/ISKP(MZMSH),ISKP0,LINC,ELAS
      COMMON/NRBTOP/ITST(MXTST),JTST(MXTST),KTST(MZTAR,MZTAR)
     X             ,OMST(MXTST),ITOP
      COMMON/NRBPH1/ZCOEF(MNPEXT,MZCHF),OMEGPR(MZMET,MZMSH),EPHMIN,
     1              EPHMAX,IPHOTO,NODAMP
      COMMON/NRBPH6/EPI(MZMSH,MZEPI,MZMET),XPI(MZMSH,0:MZPHT,MZEPI
     X,MZMET),EBB(MZEPI,MZMET),XPITOT(MZMSH,MZEPI,MZMET),NPISYM,NPIEB
      COMMON/NRBZED/TZED,LPRTSW
      COMMON/AUGER/AAUGER(MZTAR),IAUGER
      COMMON/BDSYM/ISB(MZSLP),ILB(MZSLP),IPB(MZSLP),NFILEB,
     1             ISDL(MZSLP),ILDL(MZSLP),IPDL(MZSLP),NFILED,
     2             ISDR(MZSLP),ILDR(MZSLP),IPDR(MZSLP),
     3             NFBD,NFB(3),NFD(3),MXEB(3)
      COMMON/GAUGE/IGAUGE
      COMMON/TYPE/NTYP1,NTYP2I,NTYP2OF,NTYP2OR,NMIN
      COMMON/WIDSV/FWIDSV1(MZCHF),FWIDSV2(MZCHF),EWIDSV1(MZCHF),
     1             EWIDSV2(MZCHF),RWIDSV(MZCHF),NWIDSV(MZCHF)
      COMMON/PART/EIGENS(MZNRG,MZLP1),ENDS(MZNRG,MZLP1),SI(MZCHF),
     X            TRACE,NRANG1(MZLP1),NRANG2,IPRCENT
C
      common /nrbtmpac/ac1,ac2,iomit0
C                         ,IRAD
      NAMELIST/STGF/IPRINT     ,IPERT,AC,RONE,IMESH,IOPT1,IRDEC,LRGLAM
     1,IPRKM,PERT,MINLT,MAXLT,ISKP0,LINC,NASTD,LCBE,ELAS,NOMWRT,IBETA
     2,IBIGE,LMX,KFLAG,IQDT,NDRMET,QETEST,NEWAR,IPRTSW,IOMSW,NCUTOFF,IEQ
     3,IGAUGE,NTYP1,NTYP2I,NTYP2OF,NTYP2OR,NMIN,IAUGER,IWARN,FNUMIN
     4,ICCINT,INTPQ,ISGPT,ITRMN,ITRMX,FNUHYB,ITOP,PRINT,IMODE,IDIP,IRD0
     5,IJBIN,IPHOTO,EPHMIN,EPHMAX,NODAMP,UNITS,NPISYM,NPIEB
     x,ac1,ac2,iomit0
C
      NAMELIST/MESH1/MXE,E0,EINCR,QNMAX,ABVTHR,BELTHR
      NAMELIST/MESH2/DQN,QNMAX,EMIN,EMAX,DEOPEN
      NAMELIST/MESH3/MXE,ABVTHR,BELTHR
C
      DATA NUM /'0','1','2','3','4','5','6','7','8','9'/
C
C
      WARN=.TRUE.
      WARNE=.TRUE.
      QJUMP=.FALSE.
      IWARN=999
C
C  CALL BLOCK DATA AS SUBROUTINE TO AVOID LINKAGE PROBLEMS
C
      CALL BLOCK
C
C  INITIALISE INDM
C
      INDM=0
C
C  I/O UNITS
C  *********
C
C          1 FOR OMEGA SCRATCH FILE (USED FOR IRAD.LT.2).
C          2 FOR DIPOLE B-DATA FILES B00, B01, B02 ETC.
C          3 FOR DIPOLE D-DATA FILES D00, D01, D02 ETC.
C          4 FOR AUGER (CORE) RATES. FILE AUGER.
C          5 FOR PROGRAM CONTROL
C          6 FOR PRINTED OUTPUT
C          7 FOR VALUES OF OMEGA (USED FOR IRAD.LT.2). FILE OMEGA.
C          8 FOR DIPOLE F-DATA INDEPENDENT OF SLPI. FILE F00.
C          9 FOR DIPOLE F-DATA DEPENDENT ON SLPI. FILES F01 ETC.
C         10 FOR INPUT R-MATRIX DATA. FILE H.DAT.
C         11 RESERVED
C         14 FOR PARTIAL CROSS SECTIONS. FILE sigpw.dat
C         17 FOR TERM INFORMATION FOR INPUT TO stgicf. FILE term.dat.
C         18 FOR VALUES OF DR OMEGA (USED FOR NDRMET.GT.0). FILE OMEGDR.
C         19 FOR CHANNEL INFO FOR INPUT TO stgicf. FILE jbinls.
C         20 FOR K-MATRICES FOR DIFF XSCN. FILE KMAT.DAT.
C         21 FOR KHI-MATRIX (=1-T) OUTPUT, MQDT OR JJOM FORMAT. FILE JBIN.
C         22 FOR CASE DESCRIPTION AS REQUIRED BY JJOM. FILE JJDAT.
C         23 RESERVED
C         25 RESERVED
C         27 FOR PHOTORECOMBINATION. FILE OMEGDR.
C         28 FOR SUM OF PARTIAL PHOTOIONIZATION. FILE XPISUM.
C         29 FOR RESOLVED PARTIAL PHOTOIONIZATION. FILE XPIPAR.
C         30 FOR TOTAL PHOTOABSORPTION. FILE XPATOT.
C         31 FOR LINE STRENGTHS FOR INPUT TO stgicf. FILE strength.dat.
C         32 FOR UNPHYSICAL K/S-MATRIX FOR stgicfdamp. FILE zk/smtls.001,002...
C         33 RESERVED
C         34 RESERVED
C         36 FOR UNPHYSICAL K-MATRIX. FILE kmatlsn. (TOM)
C         37 FOR CHANNEL INFO. FILE chanlsn. (TOM)
C         38 FOR UNPHYSICAL D-MATRIX. FILE dmatls1. (TOM)
C         39 FOR UNPHYSICAL D-MATRIX. FILE DBIN.
C
C
C      OPEN(5,FILE='dstgbf0damp',STATUS='UNKNOWN')
      OPEN(6,FILE='routbf0damp',STATUS='UNKNOWN')
C
      INQUIRE(FILE='H.DAT',EXIST=BFORM)
      IF(BFORM)THEN
        IWORD=1
        OPEN(10,FILE='H.DAT',FORM='UNFORMATTED',STATUS='OLD')
      ELSE
        INQUIRE(FILE='DSTGH.DAT',EXIST=BFORM)
        IF(BFORM)THEN
          IWORD=2
          OPEN(10,FILE='DSTGH.DAT',FORM='UNFORMATTED',STATUS='OLD')
        ELSE
          WRITE(6,*)'***ERROR: NO SUITABLE H.DAT FILE FOUND!'
          STOP '***ERROR: NO SUITABLE H.DAT FILE FOUND!'
        ENDIF
      ENDIF
C
C
C  WRITE NEWS
C  **********
C
      WRITE(6,6000)
      WRITE(6,6003)
      WRITE(6,6005)
      WRITE(6,6001)
      WRITE(6,6002)MZCHF,MZTAR,MZLMX,MZLP1,MZPTS,MZMSH,MZMNP,
     X             MZSLP,MZTET,MZDEG,MZNRG,MZMET,MZPHT,MZEPI,MZEST,
     X             MZDEC,MZDIP,MZREC,MZMEG
C
C
C  READ DATA FROM UNIT 5
C  *********************
C
C PI/PR VARIABLES (SEE ALSO DAMPING VARIABLES BELOW):
C
C     IPHOTO  =-1  CALCULATE PARTIAL PHOTORECOMBINATION CROSS SECTIONS TO
C                  STATES THAT ARE BOUND BY ENERGIES BETWEEN EPHMIN,EPHMAX.
C             > 0  CALCULATE PHOTOIONIZATION CROSS SECTIONS FROM INITIAL
C                  STATES (NPISYM,NPIEB) IN STGB TO THE FIRST IPHOTO ELECTRON
C                  CONTINUA. IF IPHOTO.GT.MZPHT THEN THE FIRST MZPHT PARTIALS
C                  ARE RESOLVED BUT THE PARTIAL SUM IS OVER IPHOTO STILL.
C                  ADD 1000 TO GET TOTAL PHOTOABSORPTION AS WELL (REQUIRES
C                  MQDT). IF IPHOTO.GE.NAST THEN THE (UNDAMPED) PARTIAL SUM
C                  SHOULD EQUAL THE (UNDAMPED) TOTAL PHOTOABSORPTION.
C                  (DEFAULT = 1)
C             = 0  OFF
C     NPISYM  > 0  PI FROM THE FIRST NPISYM STGB SYMMETRIES (DEFAULT=1)
C     NPIEB   > 0  PI FROM THE FIRST NPIEB STGB ENERGIES, PER SYMMETRY, (DEFAULT=1)
C     NODAMP  > 0  GENERATE PHOTORECOMBINATION/IONIZATION WITH NO DAMPING,
C                  DEPENDING ON IPHOTO (DEFAULT 0, DAMPING ON).
C
C END PI/PR SPECIFIC VARIABLES
C
C DAMPING VARIABLES:
C          DEFAULTS: EXCITATION DAMPING ON, DR/RR OFF.
C
C     NTYP1   = 1  INCLUDE TYPE 1 (CORE) DECAY (DEFAULT).
C             = 0  EXCLUDE IT.
C     NTYP2I  = 1  INCLUDE TYPE 2 IN (RMATRIX BOX) DECAY (DEFAULT).
C             = 0  EXCLUDE IT.
C     NTYP2OF = 1  INCLUDE TYPE 2 OUT (CONTINUUM-RYDBERG) DECAY.
C             = 0  EXCLUDE IT.
C             =-1  NOT SET BECAUSE NDRMET=0 (DEFAULT).
C     NTYP2OR = 1  INCLUDE TYPE 2 OUT (RYDBERG-RYDBERG) DECAY (DEFAULT).
C             = 0  EXCLUDE IT.
C     NMIN    =    MINIMUM PRINCIPAL QUANTUM NUMBER FOR FINAL DECAY STATES
C                  OF NON-STGB TYPE 2 DECAY (NTYP2OF/R); USUALLY 1 GREATER THAN
C                  THE LARGEST STGB VALUE. BY DEFAULT NMIN=-1 IS UNSET. HOWEVER,
C                  IF NTYP2OR OR NTYP2OF =1 THEN NMIN IS REQUIRED. BUT,
C                  IF NTYP2I=1 THEN THE CODE ATTEMPTS TO READ NMIN FROM THE
C                  STGB B00 FILE (IF IT HAS NOT ALREADY BEEN SET POSITIVE).
C     NDRMET  =    NUMBER OF INITIAL METASTABLE STATES FOR DR/RR (DEFAULT=0).
C     IAUGER  > 0  READ CORE RATES FROM FILE AUGER, FREE FORMAT: AAUNITS, THEN
C                  ITARG, AA(AAUNITS). AA(RYD)=AA(AAUNITS)/AAUNITS WHERE
C                  AAUNITS = 1 RYD, 0.5 AU, 2.06706E16 /SEC ETC (DEFAULT=0).
C     IGAUGE  = 0  USE LENGTH GAUGE, =1, USE VELOCITY GAUGE (DEFAULT=0).
C
C END DAMPING SPECIFIC VARIABLES
C
C MQDT VARIABLES:
C       DEFAULTS: OFF - NON-MQDT OPERATION.
C
C     IMODE --  CONTROLS READ/WRITE OF UNPHYSICAL MATRIX IN MQDT OPERATION.
C           = 0 WRITE THE UNPHYSICAL MATRIX TO FILE (JBIN) - DEFAULT.
C               THIS WOULD NORMALLY BE FOR A COARSE ENERGY MESH.
C           = 1 READ THE UNPHYSICAL MATRIX FROM FILE (JBIN).
C               SOLUTION ON A (NEWLY DEFINED) FINE ENERGY MESH OBTAINED SOLELY
C               BY INTERPOLATION OF THE PREVIOUS COARSE MESH DATA.
C           =-1 SINGLE PASS OPERATION. FULL SOLUTION ON A COARSE MESH.
C               INTERPOLATIVE SOLUTION ON A FINE MESH - SEE IEQ (NO JBIN).
C     IJBIN = 0 DEFAULT, DO NOT WRITE JBIN FOR IMODE=0.
C     IQDT  = 0 NO MQDT EXCEPT GAILITIS VIA N.GT.QNMAX (I.E. QDT=.TRUE.) DEFAULT
C     IQDT  =-1 PARALLEL QDT=.TRUE. OPERATION BUT **NOT** AVERAGED, SO DAMPING
C               STILL RESTRICTED TO RESONANCES CONVERGING TO LOWEST THRESHOLD.
C     IQDT  = 1 FULL MQDT, ALL CHANNELS TREATED AS OPEN, USES UNPHYSICAL K/S-MX.
C               NOTE IQDT.GT.0 WILL INCLUDE DIPOLE PERTURBING POTENTIALS IF
C               I/PERT IS SET APPROPRIATELY. SEE ALSO IMODE.
C           = 2  WORK WITH UNPHYSICAL K-MX RATHER THAN S-MX.
C     IEQ   --  CONTROLS HOW OFTEN THE UNPHYSICAL MATRIX IS UPDATED.
C           > 0 THEN UPDATED AT IEQ LINEARLY SPACED ENERGIES ACROSS THE TOTAL
C               ENERGY RANGE DEFINED BY THE INPUT ENERGY MESH. (IMODE=-1)
C           < 0 THEN UPDATED AT EVERY |IEQ|'TH POINT OF THE MESH, FINE FOR
C               CONSTANT STEP IN ENERGY, NOT SO GOOD (INEFFICIENT) FOR CONSTANT
C               STEP IN EFFECTIVE QUANTUM NUMBER.
C               DEFAULT = -1, THE K/S-MATRIX IS UPDATED AT EVERY ENERGY SO A
C               COARSE MESH SHOULD BE USED (IMODE=0). THEN RE-RUN WITH A FINE
C               ENERGY MESH (IMODE=1).
C     QETEST = 1.E-7 SCALED RYDBERGS (DEFAULT). THE K/S-MX IS ONLY RE-INTERPOLATED
C              WHEN ETOT HAS CHANGED BY MORE THAN QETEST SINCE THE LAST TIME.
C              GIVES A SMALL TIME SAVING WHEN USING A VERY FINE MESH E.G. 1.E-8.
C              SHOULD NOT NEED TO BE CHANGED. SHOULD BE SMALLER THAN COARSE STEP
C     NCUTOFF=MAX PRINCIPAL QUANTUM NUMBER FOR WHICH DR IS CALCULATED,
C             CASE OF IQDT.GT.0 ONLY. DEFAULT ALL (1000000).
C     FNUMIN= THE EFFECTIVE QUANTUM NUMBER BELOW WHICH THE CLOSED CHANNEL IS
C             OMITTED, USED BY IQDT=1,2 - DEFAULT=0.
C     FNUHYB= THE EFFECTIVE QUANTUM NUMBER BELOW WHICH THE CLOSED CHANNEL IS
C             THETA RATHER THAN S & C, USED BY IQDT=1,2 - DEFAULT=0.
C
C END MQDT SPECIFIC VARIABLES
C
C STANDARD STGF VARIABLES:
C
C     IPRINT = -2 FOR MINIMUM PRINT
C            = -1 OMEGAS PARTIAL IN BIG L AT EACH ENERGY
C            =  0 OMEGAS PARTIAL IN BIG L, AND TOTAL, AT EACH ENERGY
C            =  1 REACTANCE MX, OMEGAS PARTIAL IN SMALL AND BIG L.."..
C            =  2 DETAILS OF PERTURBING POTENTIALS.
C            =  3 FOR MAXIMUM PRINT (LARGE)
C  IRAD IS NOT USED CURRENTLY AS STGBF IS UNDAMPED
C      IRAD  = 0 FOR NO RADIATIVE DATA ON UNIT 9
C            = 1 FOR RADIATIVE DATA ON UNIT 9
C            = 2 FOR RADIATIVE DATA ON UNIT 9 AND NO COLLISION STRENGTHS
C     IPERT  = 0 FOR OMISSION OF LONG-RANGE MULTIPOLE POTENTIALS
C            = 1,2,3,4 FOR THEIR INCLUSION (SEE PERT BELOW AS WELL)
C                 1 AND 2 OMIT LONG-RANGE POTENTIALS WHEN CLOSED-
C                       CHANNEL RTWO EXCEEDS MESH.
C                 3 AND 4 DO NOT, THEY JUST NEGLECT CONTRIBUTION FROM
C                       RTWO TO INFINITY INSTEAD.
C                 1 AND 3 PERTURB THE T-MATRIX,
C                 2 AND 4 PERTURB THE K-MATRIX (WHEN IPERT RESET
C                         NEGATIVE INTERNALLY).
C     PERT   = 'YES' SIMPLE OPTION TO SWITCH-ON PERTURBATIONS
C            = 'NO'  OFF - DEFAULT.
C     AC     = ACCURACY REQUIRED (1.E-5 DEFAULT)
C     RONE   = DEBUG PARAMETER (NORMALLY TAKE RONE = 1.)
C     IMESH  = 1 FOR FIXED INCREMENT IN ENERGIES
C                FOLLOWED BY
C                MXE, E0, EINCR FOR NUMBER OF ENERGIES,
C                               FIRST ENERGY AND INCREMENT
C                OPTIONALLY SET QNMAX TO APPLY QDT (GAILITIS IN SQDT)
C     IMESH  = 2 FOR FIXED INCREMENT IN EFFECTIVE QUANTUM
C                NUMBERS FOLLOWED BY
C                DQN, QNMAX, EMIN, EMAX, DEOPEN
C                DEFINED IN SUBROUTINE  MESH
C     ********** SETS IPERT=0 FOR NU .GT. QNMAX (I.E. QDT USED)
C
C     IMESH = 3 TO READ ENERGY MESH, FOLLOWED BY
C               MXE
C               (EMESH(M),M=1,MXE)
C     IMESH = -S TO CHOOSE MESH APROPRIATE FOR CASES WITH TOTAL
C                SPIN 2S+1
C                FOLLOWED BY DATA AS FOR IMESH=2
C     IOPT1 = 1 FOR ALL SLPI CASES
C           = 2 FOR SELECTED SLPI CASES FOLLOWED BY
C               IS, IL, IP FOR CASES SELECTED TERMINATING WITH
C               -1 -1 -1
C           = -1 OR -2 AS ABOVE FOR + CASES BUT FIRST FOLLOWED BY
C             NASTD,(NLEV(N),N=1,NASTD)
C           = 10    FOR JAJOM, LS OMEGA WRITTEN
C           = 11    FOR JAJOM, NO OMEGA WRITTEN.
C     NASTD = NUMBER OF GROUPS (CAN BE READ DIRECTLY)
C     IWT     DEFINES ENERGY WEIGHTING USED
C           = 0  MEAN
C           = 1  TERM  (2S+1)*(2L+1)
C           =-1 LEVEL (2J+1)
C     IRDEC = 0 FOR NO RADIATIVE DECAYS (DEFAULT) BUT SWITCHED ON BY NTYP1>0.
C           > 0 RADIATIVE DECAYS FOR EXCITATION (OPTIONAL) AND DR
C               (REQUIRED FOR NON-ZERO DR).
C           = 1 BELL AND SEATON
C           = 2 HICKMAN-ROBICHEAUX (MQDT ONLY, REVERTS TO =1 ELSE).
C     MINLT,MAXLT : IOPT1 IS SUBJECT TO SATSIFYING LRGL2.GE.MINLT AND
C                 LRGL2.LE.MAXLT  (LRGL2 = L OR 2*J). SEE ALSO LRGLAM.
C     LRGLAM=    VALUE OF LRGL2 (TOTAL L, OR 2*J) TO APPLY TOP-UP AT.
C                SET .LT. 0 TO TURN-OFF TOP-UP (DEFAULT).
C                (SO TOP-UP IS NO LONGER CONTROLLED BY IPERT).
C                IN LS COUPLING, THIS IMPLIES MAXLT=LRGLAM SINCE WE HAVE
C                TOP-UP IN SMALL L AND LARGE L (MAXLT IS RESET IF NECESS).
C                IN B.P. MODE WE TOP-UP ONLY IN SMALL L SO HIGHER LRGL2'S
C                CAN BE PRESENT AND TOP-UP IN K/J IS TAKEN FROM THEM.
C                (IT IS NOT NECESS FOR MAXLT TO BE RESET THEN.)
C                OPTIMALLY, SET LRGLAM=2*MAX(J)-2.
C                IF IOPT1=2, JUST SET NON-NEGATIVE TO TURN ON TOP-UP
C                (PRECISE VALUE DETERMINED INTERNALLY FROM YOUR PARTIAL
C                 WAVE LIST IS, IL, IP). THUS, NO J/K TOP-UP.
C                NOTE, IT IS NOW POSSIBLE TO TOP-UP WHILE NEGLECTING
C                THE LONG-RANGE MULTIPOLE POTENTIALS.
C     LCBE  = VALUE OF LRGL2 FOR WHICH CBE OMEGA'S ARE CALCULATED,
C             DIPOLE TOP-UP IS THEN DONE WITH THE CBE OMEGA'S.
C             DEFAULT=999 IS RESET TO LRGLAM, SO SET NEGATIVE TO USE
C             CC OMEGAS IN DIPOLE TOP-UP (NOT RECOMMENDED).
C     ITOP  = CONTROLS HOW NON-DIPOLE TOP-UP GOES OVER TO THE DEGENERATE
C             ENERGY CASE - SEE SR.TOP2 FOR DETAILS.
C             THE DEFAULT, =-1, SHOULD NOT NEED CHANGING.
C     ELAS  ='NO' ELASTIC TRANSITIONS IN OMEGA FILE
C     ELAS  ='YES' ELASTIC TRANSITIONS IN OMEGA FILE, SWITCHED-ON BY NDRMET.
C     IPRKM = 1 TO WRITE K-MATRIX ELEMENTS TO THE SEQUENTIAL FILE KMAT.DAT
C             FOR INPUT TO THE DIFFERENTIAL CROSS SECTION CODE
C             difls (LS) OR difjk (BP)
C           = 2 WRITE UNPHYSICAL K-MATRIX DATA TO kmatlsn, D-MATRIX DATA TO
C               dmatls1 AND CHANNEL INFO TO chanlsn. (TOM)
C           = 3 TO WRITE A SEQUENTIAL FILE pwflst, CONTAINING A LIST OF
C             PARTIAL WAVES AND ENERGIES AND A DIRECT ACCESS FILE rmabs,
C             CONTAINING THE K-MATRIX ELEMENTS. THESE FILES ARE USED FOR
C             INPUT TO THE PROGRAM pcrsx, WHICH GENERATES PARTIAL CROSS
C             SECTIONS OVER A RANGE OF ANGLES, AS WELL AS TOTAL CROSS
C             SECTIONS. ***NO LONGER OPERATIONAL - NRB***
C           = 4 WRITE UNPHYSICAL K/S-MATRIX TO zk/smtls.dat SO THAT IT CAN BE
C               READ BY stgicfdamp FOR THE CALCULATION OF INTERMEDIATE-COUPLING
C               COLLISION STRENGTHS.
C           = 0 NO WRITES (DEFAULT).
C     IRD0 >= 100, FOR IPRKM=4, WRITE LS K/S-MATRIX FILES BY SYMMETRY VIZ.
C             zk/smtls.001, zk/smtls.002 etc.
C           < 100, FOR IPRKM=4, WRITE A SINGLE LS K/S-MATRIX FILE zk/smtls.dat.
C             DEFAULT: 105
C     IDIP  = 1 WRITE DIPOLE LINE STRENGTHS TO strength.dat.
C           = 0 NO WRITES.        (DEFAULT: 0 IPRKM=0-3, 1 IPRKM=4)
C     ISKP0 = VALUE OF L/2J ABOVE WHICH OMEGA'S ARE FIRST TESTED TO SEE IF
C             HIGHER PARTIAL WAVES CAN BE NEGLECTED FOR A GIVEN ENERGY.
C             USEFUL FOR NX CODE FOR RANGING L=10-80 OVER E=~0 - 8 RY,
C             SAY, WHERE HIGH-L GIVES NEGLIGIBLE OMEGAS AT LOW-E, BUT
C             CAUSES NUMERICAL PROBLEMS NEVERTHELESS.
C     LINC  = VALUE BY WHICH L/2J IS INCREMENTED; DEFAULT=1/2 AS CASE OF
C             AUTOMATIC GENERATION IN STG2 OR RECUP. USED WITH ISKP0.
C     NOMWRT= NUMBER OF ELEMENTS OF THE OMEGA ARRAY THAT ARE WRITTEN TO
C             AND READ FROM DIRECT ACCESS, AND THEN WRITTEN TO FILE OMEGA
C             IF .EQ. 0 NO OMEGAS ARE WRITTEN.
C             IF .NE. 0, THEN RESET FROM DEFAULT VALUE OF NAST*(NAST+/-1)/2
C                .GT. 0, NOMWRT OMEGAS ARE WRITTEN ROW-WISE, INC ZEROES
C                            -- EDIT OMEG TO DROP ZEROES (DEFAULT, ALL)
C                .LT. 0, -NOMWRT OMEGAS BETWEEN OPEN STATES ARE WRITTEN,
C                                                           COLUMN-WISE.
C     IBETA > 0 THEN WRITE EXTRA STUFF TO STGBF FOR BETA PARAMETER.
C     IBIGE = 1 EVALUATE AN PRINT INFINITE ENERGY (ACTUALLY EINF*ZA**2 RY)
C               OMEGA. DIPOLE ONLY SO NO LONGER RECOMMENDED.
C           = 0 DO NOT (DEFAULT).
C     LMX   = LARGEST PERTURBING MULTIPOLE INCLUDED WHEN IPERT=1/PERT=YES,
C             DEFAULT=2 I.E. DIPOLE AND QUADRUPOLE. NOTE, ONLY A SINGLE
C             MULTIPOLE POTENTIAL IS TREATED I.E. IF DIPOLE EXISTS THEN
C             THE OCTUPOLE IS NEGLECTED EVEN IF LMX=3.
C     ISGPT, ITRMN, ITRMX .NE. 0 THEN WRITE THE PARTIAL-WAVE CROSS SECTIONS
C            FROM TRANSITION ITRMN TO TRANSITION ITRMX AND ALSO THE SUM OF
C            THE THESE PARTIAL WAVE CROSS SECTIONS FOR EACH LSPI PARTIAL WAVE
C            TO THE FILE sigpw.dat
C     ABVTHR - DROP ENERGIES WITHIN ABVTHR (Z-SCALED RY) ABOVE A THRESHOLD
C     BELTHR - DROP ENERGIES WITHIN BELTHR (Z-SCALED RY) BELOW A THRESHOLD
C              APPLIES TO IMESH=1 ONLY. DEFAULT FOR IONS IS -1., -1. I.E.
C              NONE ARE DROPPED. DEFAULT FOR NEUTRALS IS 1.E-3, 1.E-3.
C              NOTE: BOTH MUST BE SET NON-NEGATIVE TO ACTIVATE EITHER ONE,
C              SO IF ONLY ONE IS TO BE RESTRICTIVE SET THE OTHER TO ZERO.
C     PRINT  = 'FORM' THEN THE OMEGA FILE IS FORMATTED (DEFAULT).
C              'UNFORM' THEN AN UNFORMATTED OMEGAU IS CREATED INSTEAD.
C
C
C****OPTIONS BELOW ARE FOR EXPERIENCED USERS ONLY:
C
C     NEWAR = 1 FORCES RECALCULATION OF ARDEC AT EVERY ENERGY KEEPING ONLY
C               FINAL STATES BELOW THE IONIZATION LIMIT (DEFAULT).
C           = 0 DOES NOT, AND SUMS OVER ALL ARAD - EXTREMELY DANGEROUS FOR DR
C               SINCE RADIATIVE TRANSITIONS TO AUTOIONIZING STATES ARE THEN
C               COUNTED AS RECOMBINED. THIS CAN LEAD TO A VERY LARGE OVER-
C               ESTIMATE OF THE DR CROSS SECTION. ***HOWEVER***, IF YOU ARE
C               INTERESTED IN (DAMPED) EXCITATION, THEN NEWAR=0 MIGHT BE
C               MORE APPROPRIATE.
C     IOMSW = 1 MQDT: OMIT CLOSED CHANNELS WITH N<L+0.1, DEFAULT.
C           = 0 MQDT: KEEP (WITH A=-A, IOMIT(ICHAN)=-1 IN SR.SC WHEN A<0).
C           =-1 HYBRID: USE THETA FOR NU<FNUHYB.AND.NU.LT.L ELSE IOMSW=0.
C     IPRTSW= 1 FORCE IPERT POSITIVE (DEFAULT ONLY FOR IRAD>0 I.E. STGBF I/O)
C           = 0 ALLOW NEGATIVE IPERT, DEFAULT EXCEPT ABOVE CASE.
C           =-1 FORCE NEGATIVE IPERT.
C     LPRTSW=   VALUE OF LRGL2 ABOVE WHICH NEGATIVE IPERT ALLOWED.
C               DEFAULT = -1 FOR IONS, I.E. ANY LRGL2 IN PRINCIPLE BUT THE
C               PRESENCE OF THE COULOMB POTENTIAL MEANS IN PRACTICE THAT
C               IPERT NEVER GOES NEGATIVE FOR THE LOWEST FEW L, EVEN WHEN E=0.
C               DEFAULT=5 FOR NEUTRALS, SINCE RINF SCALES AS 1/SQRT(E).
C     KFLAG = 0 REGENERATE K-QUANTUM NUMBER INTERNALLY, DO NOT ATTEMPT TO
C               READ IT FROM H.DAT (DEFAULT).
C           = 1 READ K-QUANTUM NUMBER FROM H.DAT, NOT WRITTEN BY STANDARD
C               INNER REGION CODES. SHOULD NOT BE NEEDED NOW.
C     ICCINT = 1 INCLUDE CLOSED-CLOSED PERTURBING INTEGRALS, MQDT & NON-MQDT
C                OPERATION - DEFAULT.
C            = 0 OMIT THEM.
C     INTPQ  = 0 USE CORINT FOR CLOSED CHANNEL MQDT S,C INTEGRALS (DEFAULT).
C            = 1 USE THETA ETC TO GENERATE Q INTEGRALS.
C
C
C INITIALIZE NAMELIST
C
C VARIABLES SPECIFIC TO STGBF0DAMP
C
      UNITS=13.60580
      UNITS=1.0
      IPHOTO=1
      EPHMIN=-1.D+7
      EPHMAX=0.0
      NODAMP=0
      NPISYM=1
      NPIEB=1
C END
C
C VARIABLES SPECIFIC TO STGFDAMP AND STGBF0DAMP
C
      NTYP1=1
      NTYP2I=1
      NTYP2OF=-1         !BECAUSE NDRMET=0
      NTYP2OR=1
      NMIN=-1            !DETERMINE FROM STGB
      IAUGER=0
      NDRMET=0
      NCUTOFF=1000000    !SHOULDN'T NEED CHANGING
      IGAUGE=0           !LENGTH
C END
C
C MQDT SPECIFIC VARIABLES (DEFAULTS: OFF)
C
      IMODE=0
      IQDT=0
      IEQ=-1           !NEEDED FOR IMODE=-1 ONLY
      QETEST=1.E-7     !SHOULDN'T NEED CHANGING
      FNUMIN=2.5        !NOT REQUIRED FOR PRODUCTION WORK
      FNUHYB=-1.0      !NOT REQUIRED FOR PRODUCTION WORK
C END
      IPRINT=-2
      IPRKM=0
      IRAD=0             !FIXED IN STGBF0DAMP
      IPERT=0
      PERT='NO'
      AC=-1.0E-5
      ac1=1.d-9
      ac2=1.d-4
      iomit0=0
      RONE=ONE
      IMESH=2
      IOPT1=1
      IRDEC=0
      LRGLAM=-1
      MINLT=-1
      MAXLT=1000
      ISKP0=-1
      LINC=1
      NASTD=0
      IWT=-1
      LCBE=999
      ELAS='NO'
      NOMWRT=0           !STGBF0DAMP
      IBETA=0
      IBIGE=0
      IDIP=-1
      LMX=-1
      ISGPT=0
      ITRMN=0
      ITRMX=0
      ABVTHR=-1.
      BELTHR=-1.
      ITOP=-1
      PRINT='FORM'
      IJBIN=0
      IRD0=105
C
C DO NOT CHANGE NEXT 7 VARIABLES UNLESS YOU REALLY KNOW WHAT YOU ARE DOING.
      NEWAR=1
      IOMSW=11
      IPRTSW=1           !STGBF0DAMP
      LPRTSW=-1
      KFLAG=0
      ICCINT=1
      INTPQ=0
C
      READ(5,STGF)
C
      BFORM=PRINT.EQ.'FORM'.OR.PRINT.EQ.'form'
      IF(KFLAG.NE.0)KFLAG=1
C
      IF(NODAMP.GT.0)THEN
        NTYP2I=0
        IF(IPHOTO.NE.0)NTYP2I=1
        NTYP1=0
        NTYP2OF=0
        NTYP2OR=0
      ENDIF
      IF(NDRMET.GT.0)THEN
         IF(NTYP2OF.EQ.0)WRITE(6,612)
         IF(NTYP2OF.LT.0)THEN
           WRITE(6,611)
           NTYP2OF=1
         ENDIF
      ENDIF
      IF(NTYP1.LT.0)NTYP1=0
      IF(NTYP2I.LT.0)NTYP2I=0
      IF(NTYP2OR.LT.0)NTYP2OR=0
      IF(NTYP2OF.LT.0)NTYP2OF=0
C
      IF(IQDT.LE.0)THEN
        IOMSW=10
        IMODE=0
      ELSE
        IOMSW=MOD(IOMSW,10)+ISIGN(10,IOMSW)         !FORCE
        IF(FNUHYB.GT.0)IOMSW=-IABS(IOMSW)       !SO USE 10 RATHER THAN 0
        IF(AC.LT.DZERO)THEN
          AC=1.D-6
        ELSE
          AC=MAX(AC,1.D-10)
        ENDIF
      ENDIF
      AC=ABS(AC)
      IF(IQDT.EQ.0)INTPQ=0
      IF(IRAD.GT.0.OR.IOMSW.LT.0)INTPQ=0            !FOR NOW
      IF(IWARN.EQ.999)THEN
        IF(IQDT.LE.0)IWARN=0
        IF(IQDT.GT.0)IWARN=1
      ENDIF
      IF(IMODE.GE.0.OR.IQDT.LE.0)IEQ=-1
      IF(IEQ.EQ.0)IEQ=-1
      IF(IEQ.EQ.1)IEQ=2
      IF(IMODE.LT.0.AND.IEQ.EQ.-1)IMODE=0           !SINCE NO INTERP
      IQDT0=IQDT
      IQDT=IQDT/100
      IF(IQDT.EQ.0)IQDT=IQDT0
      IF(IMODE.EQ.0)IQDT0=100*IQDT                  !WRITE JBIN
      IF(IMODE.NE.0)IQDT0=IQDT                      !MAY READ JBIN
      IF(NTYP1.GT.0.AND.IRDEC.EQ.0)THEN
        IF(IQDT.LE.0)THEN
          IRDEC=1
        ELSE
          IRDEC=2
        ENDIF
      ENDIF
      IF(IQDT.LT.0)THEN                    !NTYP1 ONLY WHEN SQDT
        IF(NTYP2I+NTYP2OF+NTYP2OR.GT.0)
     X     WRITE(6,*)'***WARNING: NTYP2 RADIATION SWITCHED-OFF FOR'
     X             ,' IQDT .LT. 0 OPERATION'
        NTYP2I=0
        NTYP2OF=0
        NTYP2OR=0
      ENDIF
C
      IF(NMIN.EQ.0.OR.NMIN.GT.1000.AND.(NTYP2OR+NTYP2OF).GT.0)THEN
        WRITE(6,614)NMIN
        NMIN=0
        NTYP2OF=0
        NTYP2OR=0
      ENDIF
      IF(NMIN.LT.0.AND.NTYP2I.EQ.0.AND.(NTYP2OR+NTYP2OF).GT.0)THEN
        WRITE(6,610)
        STOP'*** NMIN NOT SET FOR NTYP2O RADIATION (AND NTYP2I.EQ.0)***'
      ENDIF
      IF((NTYP2OR+NTYP2OF).EQ.0)NMIN=0        !NMIN NOT NEEDED
C
      IF(IAUGER.GT.0)THEN
        IF(IQDT.LT.0)THEN
          WRITE(6,*)' FOR IAUGER > 0, WE NEED MQDT: SET IQDT=1 OR 2'
          STOP' FOR IAUGER > 0, WE NEED MQDT: SET IQDT=1 OR 2'
        ENDIF
      ENDIF
C
      IF(IPHOTO.NE.0)THEN
        IF(NTYP2OF.GT.0)THEN
          NTYP2OF=0
          WRITE(6,*)'***WARNING: NTYP2OF RADIATION SWITCHED-OFF FOR'
     X             ,' IPHOTO .NE. 0 OPERATION'
          IF(NDRMET.GT.0)THEN
            WRITE(6,*)'***ERROR: CANNOT HAVE IPHOTO.NE.0 WITH NDRMET'
     X      ,'.GT.0 AND NTYP2OF.GT.0'
          WRITE(6,*)' USE STGFDAMP TO GET UNRESOLVED PHOTORECOMBINATION'
     X      ,' VIA NDRMET'
            STOP 'CANNOT HAVE IPHOTO AND NDRMET BOTH SWITCHED-ON HERE'
          ENDIF
        ENDIF
        IF(IQDT.LT.0)THEN
          WRITE(6,*)' FOR IPHOTO .NE. 0, WE NEED MQDT: SET IQDT=1 OR 2'
          STOP' FOR IPHOTO .NE. 0, WE NEED MQDT: SET IQDT=1 OR 2'
        ENDIF
      ENDIF
      IF(IPHOTO.GE.1000)THEN
        IF(IQDT.LE.0)THEN
        WRITE(6,*)' FOR IPHOTO .GE. 1000, WE NEED MQDT: SET IQDT=1 OR 2'
          STOP' FOR IPHOTO .GE. 1000, WE NEED MQDT: SET IQDT=1 OR 2'
        ENDIF
        IF(NTYP2I.GT.0.AND.NODAMP.EQ.0)THEN
          WRITE(6,*)' NO PHOTOABSORPTION WHEN NTYP2I RADIATION PRESENT'
          WRITE(6,*)' SET IPHOTO .LT. 1000'
          STOP 'NO PHOTOABSORPTION WHEN NTYP2I RADIATION PRESENT'
        ENDIF
      ENDIF
C
      IF(IPRKM.EQ.2.AND.IQDT.NE.2)IPRKM=0
      IF(ISKP0.LE.0)THEN
        IF(IPRKM.EQ.0.AND.IQDT.LE.0)THEN
          ISKP0=10
        ELSE
          ISKP0=15
        ENDIF
      ENDIF
C
      PQRD=IQDT0.GT.0.AND.IQDT0.LT.100.OR.ABS(IEQ).NE.1
      IF(QETEST.LE.TZERO)QETEST=1.E-10
      IF(IPRTSW.EQ.0.AND.IRAD.GT.0)IPRTSW=1
      IF(NDRMET.GT.0.AND.ELAS.NE.'YES')THEN
        WRITE(6,609)
        ELAS='YES'         !ENSURE ELASTIC PRESENT FOR DR
      ENDIF
      IONE=1
      IF(ELAS.EQ.'YES')IONE=0
      IF(LMX.LT.0)LMX=2
      IF(IBIGE.NE.0)IBIGE=1
      IF(MAXLT.LT.0)MAXLT=1000
      INSKP=1000
      IF(MINLT.GT.ISKP0)INSKP=MINLT+1
COLD  IF(LRGLAM.GE.0.AND.MAXLT.NE.1000)LRGLAM=MAXLT  ! ALLOW BP J/K TOP
      LCBE=MIN(LCBE,LRGLAM-1)
      IF(LRGLAM.GE.0.AND.LCBE.LT.0)WRITE(6,698)
      IF(ITOP.NE.-2)ITOP=-1
C
      IF(NDRMET.GT.MZMET)THEN
        WRITE(6,*)' ***DIMENSION ERROR, NDRMET=',NDRMET,' >MZMET=',MZMET
        STOP' ***DIMENSION ERROR, NDRMET>MZMET'
      ENDIF
      IF(NPISYM.GT.MZMET)THEN
        WRITE(6,*)' ***DIMENSION ERROR, NPISYM=',NPISYM,' >MZMET=',MZMET
        STOP' ***DIMENSION ERROR, NPISYM>MZMET'
      ENDIF
      IF(NPIEB.GT.MZEPI)THEN
        WRITE(6,*)' ***DIMENSION ERROR, NPIEB=',NPIEB,' >MZEPI=',MZEPI
        STOP' ***DIMENSION ERROR, NPIEB>MZEPI'
      ENDIF
C
C ADJUST IPERT, NPERT=1 DO NOT SWITCH-OFF PERTURBATION.
C
      IF(PERT.EQ.'YES')THEN
        IF(NDRMET.LE.0)IPERT=4                !ALWAYS USE K-MX PERT
        IF(NDRMET.GT.0)IPERT=4
      ENDIF
      IF(IQDT.LT.0)IPERT=0                   !NO PERT HERE
COLD      IF(IRAD.GT.0.AND.IPERT.GT.2)IPERT=IPERT-2
COLD      IF(IQDT*IRDEC*IRAD.NE.0)IPERT=0        !NOT IN STGBF YET
CNEW: DO NOT SWITCH-OFF AS STGBF JUST DROPS THE RTWO TO INFINITY INTEGRAL,
CNEW  FOR NOW, BUT WILL AT SOME POINT DO THE LONG-RANGE INTEGRALS AS IN ALPHAQ.
C
      NPERT=0
      IF(IABS(IPERT).GT.2)THEN
        NPERT=1
        I2=ISIGN(2,IPERT)
        IPERT=IPERT-I2
      ENDIF
      IPERTR=IPERT
C
      IF(ISGPT.NE.0)OPEN(14,FILE='sigpw.dat',STATUS='UNKNOWN')
      IF(IPRKM.EQ.1)OPEN(20,FILE='KMAT.DAT',STATUS='UNKNOWN')
      IF(IPRKM.EQ.2.AND.IPHOTO.NE.0)
     X  OPEN(38,FILE='dmatls1',FORM='UNFORMATTED',STATUS='UNKNOWN')
      IF(IPRKM.EQ.4)THEN
        IF(IDIP.LT.0)IDIP=1
        OPEN(19,FILE='jbinls',FORM='UNFORMATTED',STATUS='UNKNOWN')
        IF(IRD0.LT.100)THEN
          IF(IQDT.EQ.1)THEN
            OPEN(32,FILE='smtls.dat',FORM='UNFORMATTED'
     X          ,STATUS='UNKNOWN')
          ELSE
            OPEN(32,FILE='zkmls.dat',FORM='UNFORMATTED'
     x          ,STATUS='UNKNOWN')
          ENDIF
        ENDIF
      ENDIF
C
C  SELECT TYPE OF ENERGY MESH
C
      QNMAX=-ONE
C
      IF(IMESH.EQ.1)THEN
C
C  CASE OF IMESH = 1
C
        MXE=1
        E0=ONE
        EINCR=TZERO
C
        READ(5,MESH1)
C
        IF(MXE.GT.MZMSH)THEN
          WRITE(6,699)MXE
          STOP
        ENDIF
C
        IF(IMODE.LE.0)QETEST=MIN(QETEST,ABS(IEQ)*EINCR/2)
C
        E=E0-EINCR
        DO I=1,MXE
          E=E+EINCR
          EMESH(I)=E
        ENDDO
C
      ELSE IF (IMESH.EQ.2.OR.IMESH.LT.0) THEN
C
C  CASE OF IMESH = 2 OR = -S
C
        DEOPEN=AC
C
        READ(5,MESH2)
C
      ELSE IF(IMESH.EQ.3) THEN
C
C  CASE OF IMESH = 3
C
        READ(5,MESH3)
C
        EINCR=ONE
        READ(5,*)EMESH(1)
        DO M=2,MXE
          READ(5,*)EMESH(M)
          EINCR=MIN(EINCR,EMESH(M)-EMESH(M-1))
        ENDDO
C
        IMESH=1
        IF(IMODE.LE.0)QETEST=MIN(QETEST,ABS(IEQ)*EINCR/2)
C
      ENDIF
C
C
      ISP=0
      IF (IMESH.LT.0) ISP=ABS(IMESH)
C
C   SELECT IOPT1
C
      IF(NASTD.GT.0)IOPT1=-ABS(IOPT1)
C
C  CASE OF IOPT1 NEGATIVE
C
      IF (IOPT1.LT.0) THEN
         IOPT1=-IOPT1
         IF(NASTD.EQ.0)READ(5,*)NASTD
         IF(NASTD.GT.MZTAR)THEN
           WRITE(6,697)NASTD
           STOP
         END IF
         READ(5,*)(NLEV(N),N=1,NASTD)
         WRITE(6,6021)NASTD,(NLEV(N),N=1,NASTD)
      END IF
C
C CASE OF MQDT
C
      IF (IOPT1.GE.10.OR.IQDT.GT.0) THEN
C
C OPEN K-/S-MATRIX OUTPUT FILE FOR MQDT.
        IF(IMODE.EQ.0.AND.IJBIN.NE.0)THEN
          IF(IPRKM.NE.4)
     X    OPEN(21,FILE='JBIN',STATUS='UNKNOWN',FORM='UNFORMATTED')
C OPEN D-MATRIX OUTPUT FILE FOR MQDT.
          IF(IPHOTO.NE.0)
     X    OPEN(39,FILE='DBIN',STATUS='UNKNOWN',FORM='UNFORMATTED')
        ENDIF
C OPEN K-/S-MATRIX INPUT FILE FOR MQDT.
        IF(IMODE.GT.0)THEN
          IF(IPRKM.NE.4)
     X    OPEN(21,FILE='JBIN',STATUS='OLD',FORM='UNFORMATTED')
C OPEN D-MATRIX INPUT FILE FOR MQDT.
          IF(IPHOTO.NE.0)
     X    OPEN(39,FILE='DBIN',STATUS='OLD',FORM='UNFORMATTED')
        ENDIF
C
        IF(IOPT1.GE.10.AND.IRAD.NE.0) THEN
          WRITE(6,*)' IRAD SET ZERO BECAUSE IOPT1.GE.10'
          IRAD=0
        ENDIF
      ENDIF
C
C  CASE OF IOPT1 = 2
C
      IF(IOPT1.EQ.2) THEN
        WRITE(6,602)
        KSLP=0
        IF(LRGLAM.GE.0)LRGLAM=0
C
   10   READ(5,*,END=3999)IS,IL,IP
C
        IF(LRGLAM.GE.0)LRGLAM=MAX(IL,LRGLAM)
        IF(IS.NE.999.AND.IL.NE.-1)THEN
          KSLP=KSLP+1
          ISLP=10000*IABS(IS)+100*IL+IP
          IF(IS.LT.0)ISLP=-ISLP
          MSLP(KSLP)=ISLP
          WRITE(6,603)ISLP
          IF (ISP .GT. 0) THEN
             IF (ISP .NE. IABS(IS)) THEN
                WRITE(6,'('' SPIN FOR THIS CASE .NE. IMESH'')')
                STOP
             END IF
          END IF
          GOTO 10
        ENDIF
C
        IF(KSLP.EQ.0)THEN
          WRITE(6,600)
          STOP
        ENDIF
C
        IF(KSLP.GT.MZSLP)THEN
          WRITE(6,605)KSLP
          STOP
        ENDIF
C
      ENDIF
C
C
 3999 WRITE(6,601)IPRINT,IRAD,IPERT,LMX,AC,IMESH,IOPT1,IRDEC,IMODE,IQDT
     X       ,IEQ,IOMSW,NCUTOFF,FNUMIN,FNUHYB,NDRMET,NTYP1,NTYP2I
     X       ,NTYP2OF,NTYP2OR,NMIN,IGAUGE,IAUGER,IPHOTO,NODAMP,NPISYM
     X       ,NPIEB
C
C
C  RADIATIVE TRANSITION PROBABILITIES
C  **********************************
C
      IF(IRDEC.GT.0.OR.IBIGE.EQ.1.OR.IRAD.GT.0.OR.IDIP.GT.0)THEN
C
        CALL READ1
C
        DO I=1,NAST
          IPAR(I)=-1
        ENDDO
        KMAX=(NAST*(NAST-2*IONE+1))/2
        DO K=1,KMAX
          ARAD(K)=-ONE
        ENDDO
C
C TWIDDLE: NRB
        NASTR=NAST
        NASTDO=NASTD
        NASTD=0
C
    6   CALL READ2(IOPT1)
C
        CALL RAD
C
        IF(IEND.EQ.0)THEN
          IF(MORE2.GT.0)THEN
            GOTO 6
          ELSE
            WRITE(6,606)
            K=0
            DO I=1+IONE,NAST
              DO J=1,I-IONE
              K=K+1
              IF(ARAD(K).LT.TZERO)THEN
                WRITE(6,*)J,I,ARAD(K)
                ARAD(K)=TZERO
              ENDIF
              ENDDO
            ENDDO
          ENDIF
        ENDIF
C
C RESTORE: NRB
        NASTD=NASTDO
C
        REWIND 10
C
      ENDIF
C
C  AUGER WIDTHS; INPUT AS AAUNITS THEN CONVERTED TO A.U.
C  ************
C
      IF(IAUGER.GT.0)THEN
        OPEN(4,FILE='AUGER',STATUS='UNKNOWN')
C AAUNITS = 1 RYD, 0.5 AU, 2.06706E16 /SEC.
        DO I=1,MZTAR
          AAUGER(I)=TZERO
        ENDDO
        READ(4,*)AAUNITS
        DO I=1,MZTAR
          READ(4,*,END=39)II,AAA
          AAUGER(II)=AAA/(TWO*AAUNITS)
        ENDDO
   39   CONTINUE
        CLOSE(4)
      ENDIF
C
C INITIALIZE FOR PHOTO
C
      IF(IPHOTO.GT.0)THEN
        IPHOTO0=MOD(IPHOTO,1000)
        IPHOTO0=MIN(IPHOTO0,MZPHT)
        DO K=1,NPISYM
          DO J=1,NPIEB
            DO I=0,IPHOTO0
              DO IE=1,MXE
                XPI(IE,I,J,K)=TZERO
              ENDDO
            ENDDO
          ENDDO
        ENDDO
      ENDIF
      IF(IPHOTO.GE.1000)THEN
        DO K=1,NPISYM
          DO J=1,NPIEB
            DO IE=1,MXE
              XPITOT(IE,J,K)=TZERO
            ENDDO
          ENDDO
        ENDDO
      ENDIF
C
C  START MAIN CALCULATIONS
C  ***********************
C
      WRITE(6,604)
C
      CALL ACSUB
C
C  READ R-MATRIX DATA FOR TARGET
C
      CALL READ1
C
      IF(LPRTSW.LT.0.AND.(NZED.EQ.NELC.OR.IQDT.GT.0))THEN
        LPRTSW=5
        IF(NSPN2.EQ.0)LPRTSW=2*LPRTSW+1
      ENDIF
C
      CALL SCALE1(IOPT1)
C
      IF(NZED.EQ.NELC)THEN
        TZED=ZERO
        IF(ABVTHR.LT.0.)ABVTHR=1.E-3
        IF(BELTHR.LT.0.)BELTHR=1.E-3
      ELSE
        TZED=ONE
      ENDIF
C
C SET-UP ENERGY MESH
C
      IF(IMESH.EQ.1) CALL PRUNE(ABVTHR,BELTHR)
      IF(IMESH.EQ.2 .OR. IMESH.LT.0) CALL MESH
C
C     WRITE PRELIMINARY INFORMATION TO INPUT FILE FOR STGICF
C
      IF(IPRKM.EQ.4)THEN
        WRITE(19) MXE,NZED,NELC
        WRITE(19) (EMESH(IE),IE=1,MXE)
      ENDIF
C
C DECIDE WHEN TO UPDATE UNPHYSICAL K/S-MATRIX
C
      IF(IQDT.GT.0)THEN
        IF(IMESH.EQ.1.OR.IEQ.LT.0)THEN
          IF(IEQ.LT.0)THEN
            IEQ=-IEQ
            IEQ0=IEQ
          ELSE
            IEQ0=MXE/(IEQ-1)
            IF(IEQ0.EQ.0)IEQ0=1
          ENDIF
          DO IE=1,MXE
            IEE(IE)=0
            IF(MOD(IE-1,IEQ0).EQ.0)IEE(IE)=IE
          ENDDO
          IEE(MXE)=MXE
        ELSE
          DEQ=(EMAX-EMIN)/(IEQ-1)
          EQ=EMIN
          DO IE=1,MXE
            IF(EMESH(IE).GE.EQ)THEN
              IEE(IE)=IE
              EQ=EQ+DEQ
            ELSE
              IEE(IE)=0
            ENDIF
          ENDDO
        ENDIF
      ENDIF
C
C  INITIAL WRITES TO UNIT 8
C
      IF(IRAD.GT.0)THEN
        H=ACNUM
        KP2=4*((MZPTS-1)/4)+1
        RTWO=(KP2-1)*H+RZERO
        RTWOC=RTWO
        KP2C=KP2
        IPERTW=IPERT
        IF(IPERT.GT.0)IPERTW=1
C
        CALL BODE(H,KP2,IPERT,RZERO)
C
        OPEN(8,FILE='F00',STATUS='UNKNOWN',FORM='UNFORMATTED')
C
        REWIND(8)
        WRITE(8)NZED,NELC
        WRITE(8)NAST,(ENAT(I),I=1,NAST),(ISAT(I),LAT(I),I=1,NAST)
     X        ,(ARDEC(I),I=1,NAST)
        WRITE(8)KP2
        WRITE(8)RZERO,H
        WRITE(8)(WBODE(I),I=1,KP2)
        WRITE(8)IPERTW,IQDT
        IF(IQDT.GT.0)THEN
          MXE0=0
          DO IE=1,MXE
            IF(IEE(IE).NE.0)THEN
              MXE0=MXE0+1
              OMEGDR(1,MXE0)=EMESH(IE)
            ENDIF
          ENDDO
          WRITE(8)MXE0
          WRITE(8)(OMEGDR(1,I),I=1,MXE0)
        ELSE
          WRITE(8)MXE
          WRITE(8)(EMESH(I),I=1,MXE)
        ENDIF
        WRITE(8)BSTO
      ENDIF
C
C  START CALCULATION OF OMEGAS
C  ***************************
C
C  INITIALISE OMEGAS TO ZERO
C
      IF(IRAD.LT.2)THEN
C
        IF(NOMWRT.EQ.0)THEN
          WRITE(6,*)
          WRITE(6,*)' *** OMEGA FILE IS NOT WRITTEN IN THIS CASE ***'
          NOMT=0
        ELSE
          NOMT0=(NAST*(NAST+1-2*IONE))/2
          NOMT=MIN(NOMT0,ABS(NOMWRT))
          IF(NOMWRT.LT.0)NOMT=-NOMT
          NOMWRT=NOMT
C
          CALL OMEG(0,EMESH,MXE,ENAT,NAST,OMEGA,NOMWRT,IONE)
C
          IF(NDRMET.GT.0)THEN
            DO I=1,MXE
              DO J=1,NDRMET
                OMEGDR(J,I)=ZERO
              ENDDO
            ENDDO
          ENDIF
        ENDIF
C
        DO IE=1,MXE
          ISKP(IE)=INSKP
        ENDDO
        INSKP=-INSKP
C
      ENDIF
C
C  READ DIRECTORY FOR B AND D DATAFILES
C**************************************
C
      IF(NTYP2I.NE.0.OR.IPHOTO.NE.0)THEN
        CALL READD0
        CALL READB0
      ENDIF
C
C  START LOOP ON SLPI CASES
C  ************************
C
      KASE=1
      DO I=1,NAST
        IPAR(I)=-1
      ENDDO
C
C  READ R-MATRIX DATA FOR NEXT SLPI CASE
C  *************************************
C
 1000 CALL READ2(IOPT1)
C
C TERMINATE IF EOF ON H.DAT
C
      IF(MORE2.EQ.-777)GO TO 3000
C
      IF(INSKP.LT.0.AND.NSPN2.EQ.0)THEN
        IF(ISKP0.EQ.15.OR.ISKP0.EQ.10)ISKP0=2*ISKP0+MOD(LRGL2,2)
        IF(MINLT.GT.ISKP0)THEN
          INSKP=MINLT+2
        ELSE
          INSKP=1000
        ENDIF
        DO IE=1,MXE
          ISKP(IE)=INSKP
        ENDDO
      ELSE
        INSKP=IABS(INSKP)
      ENDIF
C
      ISLP=10000*IABS(NSPN2)+100*LRGL2+NPTY2
      IF(NSPN2.LT.0)ISLP=-ISLP
      IF(LRGLAM.GE.0)THEN
        IF(NSPN2.NE.0)MAXLT=MIN(LRGLAM,MAXLT)  !FOR FTOP
        IF(NSPN2.EQ.0)MAXLT=MIN(LRGLAM+2,MAXLT)
      ENDIF
      IF(LRGL2.LT.MINLT.OR.LRGL2.GT.MAXLT)THEN
        IF(MORE2.NE.0)GO TO 1000
        GO TO 3000
      ENDIF
C
C  FOR IOPT1=2, CHECK WHETHER REQUIRED VALUE OF SLPI HAS BEEN FOUND
C
      IF(IOPT1.EQ.2)THEN
        DO 30 K=KASE,KSLP
          IF(ISLP.NE.MSLP(K))GOTO 30
          KK=K
          GOTO 40
   30   CONTINUE
C
C  CASE NOT FOUND
C
        GOTO 2000
C
C  CASE FOUND
C    RE-ORDER STORED UNIT 5 DATA
C
   40   IF(KK.NE.KASE)MSLP(KK)=MSLP(KASE)
C
      ENDIF
C
C
C  SCALE R-MATRIX DATA FOR SLPI CASE
C  *********************************
C
      IPERT=IPERTR
C
      CALL SCALE2
C
      IF(LRGLAM.GE.0)CALL TOP1(LRGLAM)
C
      IFLAG=IWARN                  !LIMIT WARNING MESSAGES
      IFLEG=IWARN                  !LIMIT WARNING MESSAGES
C
      IF(IPERT.EQ.0)WRITE(6,641)
      IF(IPRINT.GT.0.AND.IRAD.NE.2) WRITE(6,640)
C
      IF(IRAD.NE.0.AND.IOPT1.LE.9) THEN
        WRITE(8)NSPN2,LRGL2,NPTY2
        NAME='F'//NUM(KASE/10)//NUM(KASE-10*(KASE/10))
        OPEN(9,FILE=NAME,STATUS='UNKNOWN',FORM='UNFORMATTED')
        REWIND(9)
        WRITE(9)NSPN2,LRGL2,NPTY2
        WRITE(9)MNP2,NCHF
        WRITE(9)(ECH(I),I=1,NCHF)
        IF(IBETA.EQ.0)THEN
          WRITE(9)(CC(I),I=1,NCHF)
        ELSE
          WRITE(9)(CC(I),I=1,NCHF)
     X    ,(L2P(I),I=1,NCHF),(LAT(ITARG(I)),I=1,NCHF)
     Y    ,(ITARG(I),I=1,NCHF),(KJ(I),I=1,NCHF)
        ENDIF
        WRITE(9)(VALUE(I),I=1,MNP2)
        WRITE(9)((WMAT(J,I),J=1,MNP2),I=1,NCHF)
        IF(IPERT.GT.0)WRITE(9)(((CF(I,J,L),I=1,NCHF),J=1,NCHF),L=1,2)
      ENDIF
C
C  INITIALIZE JAJOM DATA FOR UNIT 22 (KAB,JAN94)
C
      IF(IOPT1.GE.10) CALL OUTJJ(0,LRGLAM,MXE)
C
C  INITIALIZE TESTS FOR NTYP2O RADIATION
C
      DO I=1,NCHF
        EWIDSV1(I)=-999
        EWIDSV2(I)=EWIDSV1(I)
        NWIDSV(I)=-99
      ENDDO
C
C
C  READ B AND D DATAFILES FOR THIS SLP (AND FORM DDEC)
C  ***********************************
C
      IF(NTYP2I.NE.0.OR.IPHOTO.NE.0)CALL BDORG
C
C  SEE IF ANY PQ DATA EXISTS TO BE READ
C
      ETOT=EMESH(1)
      IF(PQRD)CALL READPQ(0,QETEST,ISLP,IOPT1,QJUMP,PQRD)
C
C WRITE CHANNEL INFO. (TOM)
C
      IF(IPRKM.EQ.2.AND..NOT.PQRD)THEN
        NAMKLS='chanls'//NUM(KASE)
        OPEN(37,FILE=NAMKLS)
        WRITE(37,723)NSPN2,LRGL2,NPTY2
        WRITE(37,723)NAST
        DO I=1,NAST
          WRITE(37,725)I,ISAT(I),LAT(I),ENAT(I)
        ENDDO
        WRITE(37,723)NCHF
        DO I=1,NCHF
          WRITE(37,727)I,ITARG(I),LLCH(I),KJ(I),ECH(I)
        ENDDO
        WRITE(37,723)MXE
C INITIAL UNPHYSICAL K-MATRIX OUTPUT. (TOM)
        NAMKLS='kmatls'//NUM(KASE)
        OPEN(36,FILE=NAMKLS,FORM='UNFORMATTED',STATUS='UNKNOWN')
        WRITE(36)(ECH(I),I=1,NCHF)
C TOM
        IF(IPHOTO.NE.0)WRITE(38)IGAUGE
      ENDIF
      IF(IPRKM.EQ.4.AND..NOT.PQRD)THEN
        WRITE(19)NCHF,NSPN2,LRGL2,NPTY2
        DO I=1,NCHF
          WRITE(19)ITARG(I),LLCH(I)
        ENDDO
        IF(IRD0.GE.100)THEN
          K1=KASE/100
          K2=(KASE-100*K1)/10
          K3=KASE-100*K1-10*K2
          NAME=NUM(K1)//NUM(K2)//NUM(K3)
          IF(IQDT.EQ.1)THEN
            OPEN(32,FILE='smtls.'//NAME,FORM='UNFORMATTED'
     X          ,STATUS='UNKNOWN')
          ELSE
            OPEN(32,FILE='zkmls.'//NAME,FORM='UNFORMATTED'
     X          ,STATUS='UNKNOWN')
          ENDIF
        ENDIF
      ENDIF
C
C
C  START ENERGY LOOP
C  *****************
C
      EQSAVE=-999999.
C
      DO 50 IE=1,MXE
C
        IF(IRAD.LT.2.AND.LRGL2.GT.ISKP(IE).AND.IPRKM.LE.0)GO TO 50
        IPERT=IPERTR
        ETOT=EMESH(IE)
        IF(WARNE)THEN
          IF(IPRCENT.EQ.100)THEN
            IF(ETOT.GT..5*VALUE(1))THEN
              WRITE(6,690)ETOT,.5*VALUE(1)
              WARNE=.FALSE.
            ENDIF
          ELSE
            IF(ETOT.GT.0.5*TRACE)THEN                         !EZERO
              WRITE(6,691)ETOT,0.5*TRACE
              WARNE=.FALSE.
            ENDIF
          ENDIF
        ENDIF
        IF(IPRINT.GT.0)WRITE(6,680)ETOT
C
C IN IQDT MODE SEE IF WE NEED TO UPDATE
C
        IF(IQDT.GT.0)THEN
          IF(PQRD)THEN
            IF(ETOT-EQSAVE.GT.QETEST)THEN
              CALL READPQ(IE,QETEST,ISLP,IOPT1,QJUMP,PQRD)
              EQSAVE=ETOT
            ENDIF
          ELSE
            QJUMP=IEE(IE).EQ.0
          ENDIF
        ENDIF
C
        CALL POINTS(IOPT1,QJUMP)
C
C
C  CALCULATE OMEGAS
C
        CALL REACT(IOPT1,QJUMP,PQRD)
C
C
C SUPRESS ANY MORE WARNING MESSAGES FOR CURRENT SYMMETRY
C
        IFLAG=ABS(IFLAG)
        IFLEG=ABS(IFLEG)
C
   50 CONTINUE
C
      IF(IRAD.NE.0)CLOSE(9,STATUS='KEEP')
      IF(.NOT.PQRD)THEN
        IF(IPRKM.EQ.4.AND.IRD0.GE.100)CLOSE(32,STATUS='KEEP')
        IF(IPRKM.EQ.2)THEN
          CLOSE(36,STATUS='KEEP')
          CLOSE(37,STATUS='KEEP')
        ENDIF
      ENDIF
C
      IF(IOPT1.EQ.2)THEN
        IF(KASE.EQ.KSLP)GOTO 3000
        KASE=KASE+1
      ENDIF
C
C  END OF ENERGY LOOP, GO TO NEXT SLPI CASE
C  ******************
C
 2000 IF(IOPT1.EQ.1)THEN
        IF(MORE2.NE.0)THEN
            KASE=KASE+1
            GOTO 1000
        ENDIF
        GOTO 3000
      ENDIF
C
C  CASE OF IOPT1=2
C
      IF(MORE2.NE.0)GOTO 1000
      IF(IOPT1.EQ.2)THEN
C
C  CASES NOT FOUND ON UNIT 10
C
        WRITE(6,660)
        DO K=KASE,KSLP
          WRITE(6,661)MSLP(K)
        ENDDO
        WRITE(6,662)
      ENDIF
C
C  END OF SLPI LOOP
C  ****************
C
C
C  PRINT TOTAL OMEGAS
C  ******************
C
 3000 IF(IRAD.EQ.2) GOTO 3200
C
      IF(IOPT1.GE.10)THEN
        CALL OUTJJ(IOPT1,LRGLAM,MXE)
        CLOSE(11,STATUS='KEEP')
      ENDIF
C
      IF(IOPT1.NE.11)THEN
C
        IF(NSPN2.EQ.0)THEN
C
          IF(NASTD.GT.0.AND.IWT.GE.0)WRITE(6,763)
C
          DO I=1,NAST
            IF(NASTD.GT.0)LAT(I)=IWD(I)
            LAT(I)=LAT(I)+1
            LAT(I)=LAT(I)*(-1)**ISAT(I)
            ISAT(I)=0
          ENDDO
        ELSE
C
C CHECK COMPLETENESS OF PARITY
C
          DO I=1,NAST
            IF(IPAR(I).LT.0)WRITE(6,675)I
            ISAT(I)=ISAT(I)*(-1)**IPAR(I)
          ENDDO
          IF(NASTD.GT.0.AND.IWT.LE.0)WRITE(6,763)
        ENDIF
C
C WRITE TERM INFORMATION FOR USE BY STGICF
C
        IF(IPRKM.EQ.4)THEN
          OPEN(17,FILE='term.dat',FORM='FORMATTED',STATUS='UNKNOWN')
          WRITE(17,'(I5)') NAST
          AZ=MAX(NZED-NELC,1)
          AZSQ=AZ*AZ
          DO ITT=1,NAST
            ERYD=AZSQ*ENAT(ITT)
            WRITE(17,'(3I5,F16.7)') ABS(ISAT(ITT)),LAT(ITT),IPAR(ITT)
     X                             ,ERYD
          ENDDO
          CLOSE(17,STATUS='KEEP')
        ENDIF
C
C WRITE COLLISION STRENGTH OMEGA
C
        IF(NOMWRT.NE.0)THEN
          IF(BFORM)THEN
            OPEN(7,FILE='OMEGA',STATUS='UNKNOWN')
            REWIND(7)
            WRITE(7,*)NZED,NELC
            IF(IPRINT.GT.-1)WRITE(6,650)
            WRITE(7,*)NAST,MXE+IBIGE,NOMWRT
            WRITE(7,*)(ISAT(I),LAT(I),I=1,NAST)
            WRITE(7,710)(ENAT(I),I=1,NAST)
            IF(NOMWRT.LT.0)THEN               !GET ROUNDED ENERGIES
              NREC=1+(NAST-1)/5
              DO N=1,NREC
                BACKSPACE(7)
              ENDDO
              READ(7,710)(ENATR(I),I=1,NAST)
            ENDIF
          ELSE
            OPEN(7,FILE='OMEGAU',STATUS='UNKNOWN',FORM='UNFORMATTED')
            REWIND(7)
            WRITE(7)NZED,NELC
            IF(IPRINT.GT.-1)WRITE(6,650)
            WRITE(7)NAST,MXE+IBIGE,NOMWRT
            WRITE(7)(ISAT(I),LAT(I),I=1,NAST)
            WRITE(7)(ENAT(I),I=1,NAST)
          ENDIF
C
          IF(NOMWRT.LT.0)THEN
            NTAROP=1
            NTAROR=1
          ENDIF
          DO IE=1,MXE
            IF(NOMWRT.GT.0)THEN
              NOMT=NOMWRT
            ELSE
              DO IT=NTAROP,NAST
                IF(EMESH(IE).LT.ENAT(IT))GO TO 31
              ENDDO
              IT=NAST+1
  31          NTAROP=IT-1
              NOMT=(NTAROP*(NTAROP-2*IONE+1))/2
              NOMT=MIN(NOMT,-NOMWRT)
              NOMT=-NOMT
            ENDIF
C
            CALL OMEG(IE,EMESH,MXE,ENAT,NAST,OMEGA,NOMT,IONE)
C
            NOMT=ABS(NOMT)
            IF(IPRINT.GT.-1)WRITE(6,701)EMESH(IE),(OMEGA(N),N=1,NOMT)
            IF(.NOT.BFORM)WRITE(7)EMESH(IE),(OMEGA(N),N=1,NOMT)
            IF(BFORM)THEN
              IF(NOMWRT.LT.0)THEN  !GET NOMT CONSISTENT WITH ENATR
                WRITE(7,700)EMESH(IE)
                BACKSPACE(7)
                READ(7,700)E
                BACKSPACE(7)
                DO IT=NTAROR,NAST
                  IF(E.LT.ENATR(IT))GO TO 32
                ENDDO
                IT=NAST+1
  32            NTAROR=IT-1
                NOMTR=(NTAROR*(NTAROR-2*IONE+1))/2
                NOMTR=MIN(NOMTR,-NOMWRT)
                IF(NOMTR.GT.NOMT)THEN
                  DO N=NOMT+1,NOMTR
                    OMEGA(N)=0.0
                  ENDDO
                ENDIF
                NOMT=NOMTR
              ENDIF
              WRITE(7,700)EMESH(IE),(OMEGA(N),N=1,NOMT)
            ENDIF
          ENDDO
C
C WRITE INFINITE ENERGY OMEGA (WELL EINF Z-SCALED RYDBERGS).
C CURRENTLY, DIPOLE ONLY, BUT LS AND IC.
C
          NOMT=ABS(NOMWRT)
          IF(IBIGE.EQ.1)THEN
            IF(BFORM)WRITE(7,700)EINF,(ABS(SLIN(N)),N=1,NOMT)
            IF(.NOT.BFORM)WRITE(7)EINF,(ABS(SLIN(N)),N=1,NOMT)
          ENDIF
C
          CLOSE(7,STATUS='KEEP')
          IF(BFORM)WRITE(6,695)
          IF(.NOT.BFORM)WRITE(6,694)
          IF(ELAS.EQ.'YES')WRITE(6,609)
C
        ENDIF
C
C WRITE THE LINE STRENGTHS FOR INPUT TO STGICF - NOTE THE SIGN OF
C SLIN IS THE SIGN OF THE DIPOLE TRANSITION MATRIX ELEMENT
C
          IF(IDIP.GT.0)THEN
            OPEN(31,FILE='strength.dat',FORM='FORMATTED'
     X          ,STATUS='UNKNOWN')
            WRITE(31,'(2(I5))') NAST,SIGN(NOMT0,NOMWRT)
            AZ=MAX(NZED-NELC,1)
            CONS=THREE/(LOG(EINF*AZ**2)*FOUR)
            WRITE(31,'(6(1PE12.5))') (CONS*SLIN(N),N=1,NOMT0)
            CLOSE(31,STATUS='KEEP')
          ENDIF
C
C TERMINATOR
C
          IF(IPRKM.EQ.4)THEN
            WRITE(19)-1,-1,-1,-1
            CLOSE(19,STATUS='KEEP')
            IF(IRD0.LT.100)CLOSE(32,STATUS='KEEP')
          END IF
C
C WRITE OMEGDR
C
        IF(NDRMET*NOMT.GT.0)THEN
          OPEN(18,FILE='OMEGDR',STATUS='UNKNOWN')
          REWIND(18)
C
          WRITE(18,*)NZED,NELC
          WRITE(18,*)NAST,MXE,NDRMET
          WRITE(18,*)(ISAT(I),LAT(I),I=1,NAST)
          WRITE(18,710)(ENAT(I),I=1,NAST)
          DO IE=1,MXE
            WRITE(18,700)EMESH(IE),(OMEGDR(J,IE),J=1,NDRMET)
          ENDDO
C
          CLOSE(18,STATUS='KEEP')
          WRITE(6,696)
          IF(NTYP2OF.EQ.0)WRITE(6,612)
        ENDIF
C
C
C WRITE PHOTORECOMBINATION OMEGPR
C
        IF(IPHOTO.LT.0)THEN
          OPEN(27,FILE='OMEGPR',STATUS='UNKNOWN')
          REWIND(27)
C
          WRITE(27,*)NZED,NELC
          WRITE(27,*)NAST,MXE,NDRMET
          WRITE(27,*)(ISAT(I),LAT(I),I=1,NAST)
          WRITE(27,710)(ENAT(I),I=1,NAST)
          DO IE=1,MXE
            WRITE(27,700)EMESH(IE),(OMEGPR(J,IE),J=1,NDRMET)
          ENDDO
C
          CLOSE(27,STATUS='KEEP')
        ENDIF
C
C
C WRITE PARTIAL AND TOTAL PHOTOIONIZATION CROSS SECTIONS
C
        IPHOTO0=MOD(IPHOTO,1000)
        IF(IPHOTO.GT.0)THEN
          IF(IPHOTO0.GT.0)THEN
            IF(IPHOTO0.LT.NAST)WRITE(6,716)NAST
            OPEN(28,FILE='XPISUM',STATUS='UNKNOWN')
            REWIND(28)
            OPEN(29,FILE='XPIPAR',STATUS='UNKNOWN')
            REWIND(29)
          ENDIF
          IF(IPHOTO0.GT.MZPHT)THEN
            III=MIN(IPHOTO0,NAST)
            WRITE(6,715)III,MZPHT,III
            IPHOTO0=MZPHT
          ENDIF
          IF(IPHOTO.GE.1000)THEN
            OPEN(30,FILE='XPATOT',STATUS='UNKNOWN')
            REWIND(30)
          ENDIF
C
          IF(IPHOTO0.GT.0)THEN
            WRITE(29,*)NZED,NELC
            WRITE(29,*)NAST,MXE,NPISYM,NPIEB
            WRITE(29,*)(ISAT(I),LAT(I),I=1,NAST)
            WRITE(29,710)(ENAT(I),I=1,NAST)
          ENDIF
C
          DO IB=1,NPISYM
            DO IE1=1,NPIEB
              IF(IPHOTO.GE.1000)WRITE(30,*)ISB(IB),ILB(IB),IPB(IB),IE1
              IE2=1
              IF(IPHOTO0.GT.0)THEN
                WRITE(28,*)ISB(IB),ILB(IB),IPB(IB),IE1
                WRITE(29,*)ISB(IB),ILB(IB),IPB(IB),IE1
                DO IE2=1,MXE
                  IF(XPI(IE2,0,IE1,IB).GT.1.E-10) GO TO 137
                ENDDO
  137           WRITE(28,711)EBB(IE1,IB),MXE-IE2+1
                WRITE(29,711)EBB(IE1,IB),MXE-IE2+1
              ENDIF
              IF(IPHOTO.GE.1000)WRITE(30,711)EBB(IE1,IB),MXE-IE2+1
              DO IE=IE2,MXE
                EEE=EPI(IE,IE1,IB)*UNITS
                IF(IPHOTO0.GT.0)THEN
C                 SUM=TZERO
C                 DO IO=IPHOTO0,1,-1
C                   SUM=SUM+XPI(IE,IO,IE1,IB)
C                   IF(SUM.GT.1.E-10)GO TO 138
C                 ENDDO
C                 ******************************************************
C         correction so that dphotoarrange can work - DCG, from parallel
C
                    IIMX=IPHOTO0
                    IF(NAST.LT.IPHOTO0) IIMX=NAST
                    IF(EEE+EBB(IE1,IB).GE.ENAT(IIMX)) THEN
                      IO=IIMX
                      GO TO 138
                    ELSE
                      DO II=1,IIMX
                        IF(ENAT(II).GT.EEE+EBB(IE1,IB)) THEN
                          IO=II-1
                          GO TO 138
                        END IF
                     END DO
                    END IF
C                 ******************************************************
  138             WRITE(28,700)EEE,XPI(IE,0,IE1,IB)
                  WRITE(29,700)EEE,(XPI(IE,I,IE1,IB),I=1,IO)
                ENDIF
                IF(IPHOTO.GE.1000)WRITE(30,700)EEE,XPITOT(IE,IE1,IB)
              ENDDO
            ENDDO
          ENDDO
C
          IF(IPHOTO0.GT.0)THEN
            CLOSE(28,STATUS='KEEP')
            CLOSE(29,STATUS='KEEP')
          ENDIF
          IF(IPHOTO.GE.1000)THEN
            CLOSE(30,STATUS='KEEP')
            IF(IPRKM.EQ.2)CLOSE(38,STATUS='KEEP')
          ENDIF
        ENDIF
C
C WRITE SUMMARY OF DAMPING TO END OF UNIT6 AS A REMINDER.
C
        WRITE(6,613)NTYP1,NTYP2I,NTYP2OF,NTYP2OR,NMIN
C
C WRITE INFO ON ENERGIES AT WHICH S-MATRIX WAS UPDATED IN IQDT MODE.
C
c        IF(IQDT.GT.0.AND.IEQ.NE.1)THEN
c          OPEN(33,FILE='infqdt',STATUS='UNKNOWN')
c          WRITE(33,*)(IEE(I),I=1,MXE)
c        ENDIF
C
      ENDIF
C
 3200 IF(IRAD.NE.0) THEN
        WRITE(8)-1,-1,-1
        CLOSE(8,STATUS='KEEP')
        WRITE(6,663)
      ENDIF
C
C SUN
      DUM=DTIME(TARRY)
      TIME=TARRY(1)
C CRAY
CRAY  CALL SECOND(TIME)
C
      TIME=TIME/60.0
      WRITE(6,999) TIME
  999 FORMAT(//1X,'CPU TIME=',F9.3,' MIN',5X)
C
C
      STOP
C
C  FORMATS
C  *******
C
  600 FORMAT( //10X,'READS IOPT1 = 2 FOLLOWED BY TERMINATOR'//)
  601 FORMAT(//5X,'DATA READ FROM UNIT 5'/
     1  10X,'IPRINT = ',I2/
     2  10X,'IRAD   = ',I2/
     3  10X,'IPERT  = ',I2/
     *  10X,'LMX    = ',I2/
     4  10X,'AC     = ',1PE9.2/
     5  10X,'IMESH  = ',I2/
     6  10X,'IOPT1  = ',I2/
     *  10X,'IRDEC  = ',I2/
     *  10X,'IMODE  = ',I2/
     *  10X,'IQDT   =',I3/
     *  10X,'IEQ    =',I3/
     *  10X,'IOMSW  =',I3/
     *  10X,'NCUTOFF= ',I7/
     *  10X,'FNUMIN = ',0PF4.1/
     *  10X,'FNUHYB = ',F4.1/
     *  10X,'NDRMET = ',I2/
     7  10x,'NTYP1  = ',I2/
     8  10X,'NTYP2I = ',I2/
     9  10X,'NTYP2OF= ',I2/
     A  10X,'NTYP2OR= ',I2/
     B  10X,'NMIN   = ',I2/
     E  10X,'IGAUGE = ',I2/
     F  10X,'IAUGER =',I3/
     G  10X,'IPHOTO=',I4/
     H  10X,'NODAMP = ',I2/
     X  10X,'NPISYM = ',I2/
     X  10X,'NPIEB  = ',I2//)
  602 FORMAT(/5X,'VALUES OF  10000*IS+100*IL+IP  READ FOR IOPT1=2')
 6021 FORMAT(5X,'PARAMETERS READ FOR IOPT1 INITIALLY NEGATIVE',/
     +       10X,'NASTD  =',I3/10X,'NLEV   =',20I3)
  603 FORMAT(52X,I7)
  604 FORMAT(' ')
  605 FORMAT(//10X,30('*')//10X,
     + 'NUMBER OF SLPI CASES = ',I3,
     + ' EXCEEDS MAXIMUM OF MZSLP'//10X,30('*')//)
  606 FORMAT(///5X,'***** DATA ON UNIT 10 INSUFFICIENT '
     +  //5X,'***** FOR CALCULATION OF ALL RADIATIVE PROBABILTIES'//)
  609 FORMAT('*** ATTENTION: OMEGA FILE CONTAINS ELASTIC '
     X           ,'TRANSITIONS BECAUSE DR IS SWITCHED-ON'/)
  610 FORMAT(/'*** ERROR: NMIN NOT SET FOR NTYP2OR/F RADIATION (AND'
     X,' UNABLE TO DETERMINE IT FROM STGB DATA BECAUSE NTYP2I.EQ.0)'
     X/' EITHER SET NMIN OR SWITCH-OFF NTYP2OR/F RADIATION VIA: '
     X,' NTYP2OR=0 NTYP2OF=0')
  611 FORMAT(/'*** ATTENTION: DR SWITCHED-ON BUT RR BACKGROUND '
     X,'(NTYP2OF) NOT SPECIFIED'/'*** IT HAS BEEN SWITCHED-ON; TO'
     X,' SWITCH IT OFF SET: NTYP2OF=0')
  612 FORMAT('*** ATTENTION: OMEGDR FILE MAY BE INCOMPLETE BECAUSE'
     X,' THE RR BACKGROUND IS OFF (NTYP2OF.EQ.0)'/)
  613 FORMAT(//80('*')/17('*'),3X,'SUMMARY OF DAMPING CHOSEN:',3X,
     X  '1=ON  0=OFF',3X,17('*')//
     7  10x,'NTYP1  = ',I2,5X,'INNER-ELECTRON DAMPING'/
     8  10X,'NTYP2I = ',I2,5X,'OUTER-ELECTRON IN-BOX DAMPING'/
     9  10X,'NTYP2OF= ',I2,5X,'OUTER-ELECTRON NON-BOX DAMPING:'
     X     ,' FREE-BOUND (RR)'/
     A  10X,'NTYP2OR= ',I2,5X,'OUTER-ELECTRON NON-BOX DAMPING:'
     X     ,' RYDBERG-RYDBERG'/
     B  10X,'NMIN   = ',I2,5X,'LOWEST N FOR NON-BOX DAMPING'//
     C  80('*'))
  614 FORMAT(/' COMMENT: NTYP2O RADIATION IS BEING SWITCHED-OFF'
     X,' BECAUSE YOU SPECIFIED NMIN = ',I6)
  640 FORMAT(//'   ETOT',3X,'QDT',2X,'IPERT',2X,
     1 'INITIAL AND FINAL TARGET LEVELS, AND COLLISION STRENGTHS'/)
  641 FORMAT(/10X,10('+'),' RUN WITH IPERT = 0 ',10('+')/)
  650 FORMAT(///80('*')/80('*')//20X,'ENERGIES AND TOTAL OMEGAS'/
     1  20X,25('*')/)
  660 FORMAT(//10X,30('*')/
     1 10X,'NO DATA ON R-MATRIX FILE FOR'/
     2 10X,'10000*IS+100*IL+IP = '/)
  661 FORMAT(10X,I10)
  662 FORMAT(/10X,30('*')//)
  663 FORMAT(//10X,'RADIATIVE FILE WRITTEN'//)
  675 FORMAT(' WARNING: PARITY OF TARGET STATE',I4
     X  ,' HAS NOT BEEN DETERMINED')
  680 FORMAT(///5X,'ETOT = ',1PE14.6/5X,21('=')/)
  690 FORMAT(//5X,60('*')/5X,'* ETOT = ',E11.3,
     + ' LARGER THAN .5*VALUE(1) = ',E11.3,' *',5X,
     + /5X,'* RESULTS MAY BE INACCURATE.',
     + ' NO MORE SIMILAR WARNINGS.',5X,'*'/5X,60('*')//)
  691 FORMAT(//5X,57('*')/5X,'* ETOT = ',E11.3,
     + ' LARGER THAN .5*EZERO = ',E11.3,' *',5X,
     + /5X,'* RESULTS MAY BE INACCURATE.',
     + ' NO MORE SIMILAR WARNINGS.',2X,'*'/5X,57('*')//)
  694 FORMAT(//10X,46('*')/
     + 10X,'* COLLISION STRENGTHS WRITTEN TO FILE OMEGAU *'/
     + 10X,46('*')//)
  695 FORMAT(//10X,45('*')/
     + 10X,'* COLLISION STRENGTHS WRITTEN TO FILE OMEGA *'/
     + 10X,45('*')//)
  696 FORMAT(//8X,49('*')/
     + 8X,'* DR COLLISION STRENGTHS WRITTEN TO FILE OMEGDR *'/
     + 8X,49('*')//)
  697 FORMAT(10X,30('*')/10X,'NASTD = ',I5,
     + ' IS LARGER THAN MZTAR'/10X,30('*')//)
  699 FORMAT(10X,33('*')/10X,'MXE = ',I6,
     + ' IS LARGER THAN MZMSH'/10X,33('*')//)
  698 FORMAT(/10X,62('*')//10X,'STRONG WARNING: CC OMEGAS ARE BEING'
     X,' USED FOR THE DIPOLE TOP-UP'/25X,
     X ' RECOMMEND SETTING LCBE=LRGLAM'//10X,62('*'))
 6000 FORMAT(///1X,70('+')//10X,'STGBF0DAMP UoS v4.8'/
     + 10X,19('*')//5X,'HISTORY OF MODIFICATIONS'//
     + 10X,'(1) BETTER ACCURACY FOR LARGE L '/
     + 10X,'(2) SUM TO INFINITY (TOP-UP) FOR DIPOLE TRANSITIONS'/
     + 10X,'(3) USE OF QDT TO GIVE',
     + ' GAILITIS AVERAGE '/
     + 10X,'(4) USE OF IRDEC TO GIVE RADIATIVE DECAYS '
     + /10X,'(5) HANDLES NEW BUTTLE FIT'
     + /10X,'(6) OPENS FILES B00, B01, ....'
     + /10X,'(7) DATA ON',
     + ' B FILES REQUIRES NUMEROV INTEGRATIONS IN STGBB, STGBF')
 6003 FORMAT(10X,'(8) CORRECTION OF ROUNDING-ERRORS AT THRESHOLDS'
     + /10X,'(9) PRINTS DIMENSIONS '
     + /9X,'(10) COMBINES NEARLY DEGENERATE TARGET LEVELS '
     + /9X,'(11) NAMELIST INPUT'
     + /9X,'(12) REACTANCE MATRIX OUTPUT '
     + /9X,'(13) WORD ADDRESSABLE OUTPUT'/9X
     + ,'(14) PRINTS MAJOR WARNINGS IF IPERT RESET=0 '/9X
     +,'(15) MANY MINOR AND 1 MAJOR DEVELOPMENT SO IPERT NEVER RESET=0'
     + /9X,'(16) TOP-UP CONTROL SEPARATED FROM IPERT '
     + /9X,'(17) QUADRUPOLE TOP-UP INCLUDED'
     + /9X,'(18) DIPOLE TOP-UP CAN BE EVALUATED WITH CBe OMEGAS'
     + /9X,'(19) RADIATIVE DECAYS IN B.P. MODE ADDED'
     +)
 6005 FORMAT(9X,'(20) INFINITE ENERGY OMEGA ADDED (DIPOLE ONLY)'
     + /9X,'(21) DIMENSIONS FROM INCLUDE, NO PREPROCESSING'
     + /9X,'(22) OCTUPOLE ETC. TOP-UP (FOR PSEUDO-STATE IONIZATION)'
     + /9X,'(23) OCTUPOLE ETC. PERTURBING POTENTIALS (FOR DITTO)'
     + /9X,'(24) DETAILED SQDT, WITH TYPE-I DAMPING, FOR DR/RE'
     + /9X,'(25) DETAILED MQDT, WITH TYPE-I & II DAMPING, FOR DR/RE'
     + /9X,'(26) AUGER (CORE) DAMPING'
     + /9X,'(27) PARTIAL (DAMPED) PHOTOIONIZATION/RECOMBINATION'
     + /9X,'(28) NEUTRAL CASE ADDED'
     + /9X,'(29) DARC HD.DAT (AND H.DAT VIA DARC INTERFACE)',
     + /9X,'(30) PARTITIONED R-MATRIX'
     +)
 6001 FORMAT(//
     + 5X,'IQDT= 0 (DEFAULT) FOR NON-QDT OPERATION, EXCEPTING GAILITIS'/
     + 22X,'AVERAGE WHEN NU.GT.QNMAX - ANY MESH.'//
     + 5X,'IQDT=-1 FOR QDT APPLIED TO SINGLE CLOSED TARGET-STATE:'/
     + 13X,'DETAILED & AVERAGED, DAMPED & UNDAMPED, EXCITATION & DR.'//
     + 5X,'IQDT=+1 FOR S-MX QDT APPLIED TO ALL CLOSED TARGET-STATES:'/
     + 13X,'DETAILED, DAMPED & UNDAMPED, EXCITATION & DR.'//
     + 5X,'IQDT=+2 DITTO BUT FOR FOR K-MX.'//
     + 5X,'CASE IQDT .GT. 0 THEN:'//
     + 5X,'IMODE= 0 (DEFAULT) WRITE UNPHYSICAL K/S-MATRIX TO FILE.'//
     + 5X,'IMODE=+1 READ (AND INTERPOLATE) K/S-MATRIX FROM FILE.'//
     + 5X,'IMODE=-1 SINGLE PASS: COMPUTE AND INTERPOLATE (NO FILES).'//
     + 5X,'IN THIS CASE SET IEQ EQUAL TO THE NUMBER OF COARSE MESH'
     +    ,' ENERGIES.'//
     +//1X,70('+')/)
 6002 FORMAT(//10X,'COMPILED FOR DIMENSIONS -'//
     + 15X,'CHANNELS                   MZCHF =',I6/
     + 15X,'TARGET STATES              MZTAR =',I6/
     + 15X,'MULTIPOLES                 MZLMX =',I6/
     + 15X,'SMALL L VALUES             MZLP1 =',I6/
     + 15X,'OUTER-REGION RADIAL POINTS MZPTS =',I6/
     + 15X,'ENERGY-MESH POINTS (PHYS)  MZMSH =',I6/
     + 15X,'R-MATRIX POLES             MZMNP =',I6/
     + 15X,'S, L, PI CASES             MZSLP =',I6/
     + 15X,'COEFFICIENTS FOR THETA     MZTET =',I6/
     + 15X,'DEGENERATE CHANNELS        MZDEG =',I6/
     + 15X,'TERMS IN BUTTLE FIT        MZNRG =',I6/
     + 15X,'METASTABLES FOR PI/PR      MZMET =',I6/
     + 15X,'FINAL STATES FOR PHOTOION  MZPHT =',I6/
     + 15X,'INITIAL ENERGIES FOR PI    MZEPI =',I6/
     + 15X,'ALL BOUND STATE ENERGIES   MZEST =',I6/
     + 15X,'UNRES RAD DECAYS TYPE-2I   MZDEC =',I6/
     + 15X,'RESOLVED RAD DECAYS T-2I   MZDIP =',I6/
     + 15X,'RECORD LENGTH FOR ONE WORD MZREC =',I6/
     + 15X,'M-WORDS OF INTERNAL MEM.   MZMEG =',I6//)
C MXTST=(MZTAR*(MZTAR+1))/2
  700 FORMAT(1PE16.10,6(1PE11.3)/(16X,6(E11.3)))
  701 FORMAT(1PE12.5,6(1PE11.3)/(12X,6(E11.3)))
  710 FORMAT(1P5E16.6)
  711 FORMAT(E20.10,I8)
  715 FORMAT(/'***ATTENTION XPIPAR: INCREASE MZPHT TO ',I4,' TO GET'
     X     ,' ALL REQUESTED/POSSIBLE PARTIALS.'/
     X'   IPHOTO IS REDUCED TO: ',I4,' MODULO 1000'/
     X'***THE PARTIAL SUM IN XPISUM IS OVER THE ORIGINAL ',I4,
     X' ELECTRON TARGETS STILL.***'/)
  716 FORMAT(/'***WARNING XPISUM: THE SUM OVER PARTIALS IS INCOMPLETE'
     X,' AND MAY NOT REPRESENT THE TOTAL PHOTOIONIZATION CROSS SECTION'
     X/' INCREASE IPHOTO MODULO 1000 TO ',I4,' TO GET THE SUM OVER ALL'
     X,' (NAST) ELECTRON TARGETS.***'/)
  723 FORMAT(3I10)
  725 FORMAT(3I5,E20.10)
  727 FORMAT(4I5,E20.10)
  763 FORMAT(//' *********WARNING, STAT. WEIGHTS IN OMEGA FILE ARE '
     X,'MEANINGLESS FOR GROUPED TERMS/LEVELS !!'//)
C
      END
C
C**********************************************************
C
      SUBROUTINE ABG(E0,L,AC,A,BG)
C
C  COMPUTES FUNCTION G(X,L) TO ACCURACY AC.
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
      PARAMETER (P0=ONE/252.)
      PARAMETER (P1=1.05)
      PARAMETER (P2=2.1)
C
      PI=ACOS(-ONE)
      E=E0
      X=ONE/SQRT(-E)
C
C  CALCULATION OF A AND EAC=E*A*C
C
      IF(L.GT.0)GOTO 2
      A=ONE
      EAC=TZERO
      GOTO 20
    2 IF(L.GT.1)GOTO 4
      A=ONE+E
      EAC=E
      GOTO 20
    4 IF(X.LT.DBLE(L+1)) GOTO 12
      C=TZERO
      A=ONE
      A1=1
      A2=-E
      A3=TWO*E
      DO 10 I=1,L
      A2=A2+A3
      A1=A1+A2
      A=A*A1
      C=C+DBLE(I)/A1
   10 CONTINUE
      EAC=E*A*C
      GOTO 20
C  CASE OF X.LT.(L+1)
   12 A=ONE
      A1=TZERO
      DO 16  I=1,L
      A=A*(ONE+DBLE(I*I)*E)
      A2=DBLE(I)
      DO 14 J=1,L
      IF(J.EQ.I) GOTO 14
      A2=A2*(ONE+DBLE(J*J)*E)
   14 CONTINUE
      A1=A1+A2
   16 CONTINUE
      EAC=E*A1
C
C  COMPUTE A1=PI*BG/A-E*C=1/(2*X)+PSI(X)-LN(X)
C
   20 A1=TZERO
C
C  TEST CONVERGENCE OF ASYMPTOTIC EXPANSION
C
      XN=(754.*AC)**(-.125)
      IF(X.GT.XN)GOTO 40
C
C  USE RECURRENCE FORMULAE
C
      N=XN-X+1
      XN=X+N
      E=-ONE/(XN*XN)
      A1=A1-(ONE/X+ONE/XN)/TWO+LOG(XN/X)
      IF(N.LT.2)GOTO 40
      N=N-1
      DO 30 I=1,N
      A1=A1-ONE/(X+DBLE(I))
   30 CONTINUE
C
C  USE ASYMPTOTIC EXPANSION
C
   40 A1=A1+(((P1*E+ONE)*E+P2)*E+21)*E*P0
C
C  COMPLETE CALCULATION
C
      BG=(A*A1+EAC)/PI
C
      RETURN
      END
C
C**********************************************************
C
      SUBROUTINE ACSUB
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC
C
      ACNUM=(24.*AC)**.166666667
      ACJWBK=(6.*AC)**.2
      ACZP=16.*AC
      LACC=0
      IF(AC.LT.1.E-3)LACC=2
      IF(AC.LT.1.E-4)LACC=4
C
      RETURN
      END
C***************************************************************
C
      SUBROUTINE ALPHA(NCHOPO)
C
C NRB;
C EVALUATE LONG-RANGE PERTURBING INTEGRALS
C
      IMPLICIT REAL*8 (A-H,O-Y)
C
      INCLUDE 'PARAM'
C
      PARAMETER(TZERO=0.0)
C
      COMMON/CALP/ASS(MZCHF,MZCHF),ASC(MZCHF,MZCHF),ACS(MZCHF,MZCHF)
     1 ,ACC(MZCHF,MZCHF)
C  ***  NOTE CHANGE OF CC TO CCT IN /CHAN/ ***
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT
      COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN
C
C
C EVALUATE ALPHA INTEGRALS IN IQDT AND NON-IQDT CASES
C
      IF(IQDT.EQ.0.OR.INTPQ.NE.0)THEN
        CALL ALPHAN(NCHOPO)
      ELSE
        CALL ALPHAQ(NCHOPO)
      ENDIF
C
C ZERO-OUT INTEGRALS FOR OMITTED CHANNELS (IF NOT ALREADY DONE)
C
      DO J=1,NCHF
        DO I=1,NCHF
          IF(IOMIT(I).GT.0.OR.IOMIT(J).GT.0)THEN
            ASS(I,J)=TZERO
            ASC(I,J)=TZERO
            ACS(I,J)=TZERO
            ACC(I,J)=TZERO
          ENDIF
        ENDDO
      ENDDO
C
      RETURN
      END
C***************************************************************
C
      SUBROUTINE ALPHAN(NCHOP)
C
C NRB: WE'S ALPHA WITH INDICES OF FS(K,I),FC(K,J) INTERCHANGED
C      (THROUGHOUT THE CODE) FOR GREATER SPEED. ALSO USE OF TEMP
C      FOR A LITTLE SOMETHING EXTRA.      25/07/97
C
C
C  CALCULATES ALPHA INTEGRALS
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
C
      LOGICAL QDT
C
      COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC
      COMMON/CALP/ASS(MZCHF,MZCHF),ASC(MZCHF,MZCHF),ACS(MZCHF,MZCHF)
     1 ,ACC(MZCHF,MZCHF)
      COMMON/CBODE/WBODE(MZPTS),TBODE(MZPTS,MZLMX+1)
      COMMON/CQDT/R2ST(MZCHF),QDT,NQ
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHPP,NCHPP1
      COMMON/COULSC/FS(MZPTS,MZCHF),FSP(MZCHF),FC(MZPTS,MZCHF)
     1 ,FCP(MZCHF)
      COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2
      COMMON/CPOT/BW(MZCHF,MZCHF),LAMP(MZCHF,MZCHF)
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/NRBLMX/LMX
      COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT
      COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN
      COMMON/NRBRCT/
     X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF)
     X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF)
     X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF)
     X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF)
     X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF)
     X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF)
     X,RMAT(MZCHF,MZCHF)
C
      DIMENSION IOMTT(MZCHF),CNORM(MZCHF),SNORM(MZCHF)
C
      PI=ACOS(-ONE)
      NCHOP1=NCHOP+1
      IOCINT=IABS(ICCINT)
      JMAX=NCHF
      IF(IOCINT.NE.1)JMAX=NCHOP
C
C  INITIALISE ALPHA TO ZERO
C
      DO I=1,NCHF
        DO J=I,NCHF
          ASS(J,I)=TZERO
          ASC(J,I)=TZERO
          ACS(J,I)=TZERO
          ACC(J,I)=TZERO
        ENDDO
      ENDDO
C
      DO I=1,NCHF
        IOMTT(I)=IOMIT(I)
        IF(RINF(I).LT.TZERO)IOMTT(I)=1
        IF(RINF(I).GT.RZERO.AND.R2ST(I).GT.RTWO)IOMTT(I)=1
CT        IF(RINF(I).GT.RZERO.AND.IPERT.GT.0)IOMTT(I)=1
      ENDDO
C
C
C  CONTRIBUTION FROM RZERO TO RTWO
C  START LOOP ON RADIAL POINTS
C
C NRB: THIS RZERO TO RTWO PART IS VERY TIME CONSUMING,
C      EVEN FOR JUST A FEW HUNDRED POINTS.
C
      IF(KP2.GT.1)THEN
C
C  OPEN-OPEN AND OPEN-CLOSED PARTS
C
        IF(NCHOP.NE.0) THEN
          DO I=1,NCHOP
            IF(IOMTT(I).EQ.0)THEN
            DO J=I,JMAX
              LIJ=LAMP(J,I)
              IF(LIJ.NE.1.AND.LIJ.LE.LMX+1.AND.IOMTT(J).EQ.0) THEN
                DO K=1,KP2
                  WIJ=TBODE(K,LIJ)*BW(J,I)
                  T1=WIJ*FS(K,J)
                  T2=WIJ*FC(K,J)
                  ASS(J,I)=ASS(J,I)+FS(K,I)*T1
                  ACS(J,I)=ACS(J,I)+FS(K,I)*T2
                  ASC(J,I)=ASC(J,I)+FC(K,I)*T1
                  ACC(J,I)=ACC(J,I)+FC(K,I)*T2
                ENDDO
              ENDIF
            ENDDO
            ENDIF
          ENDDO
        ENDIF
C
C  CLOSED-CLOSED PART
C
        IF(ICCINT.EQ.1.AND.NCHOP.NE.NCHF) THEN
          DO I=NCHOP1,NCHF
            IF(IOMTT(I).EQ.0)THEN
            DO J=I,NCHF
              LIJ=LAMP(J,I)
              IF(LIJ.NE.1.AND.LIJ.LE.LMX+1.AND.IOMTT(J).EQ.0) THEN
                DO K=1,KP2
                  WIJ=TBODE(K,LIJ)*BW(J,I)
                  T1=WIJ*FS(K,J)
                  ASS(J,I)=ASS(J,I)+FS(K,I)*T1
                  ASC(J,I)=ASC(J,I)+FC(K,I)*T1
                  ACS(J,I)=ACS(J,I)+FS(K,I)*WIJ*FC(K,J)
                ENDDO
              ENDIF
            ENDDO
            ENDIF
          ENDDO
        ENDIF
      ENDIF
C
C
C  ASYMPTOTIC INTEGRALS FOR R=RTWO TO INFINITY
C
C NRB: THIS IS FAST COMPARED TO RZERO TO RTWO, EXCEPT CASE
C      WHEN RZERO APPROXS RTWO.
C
      DO I=1,NCHF
        IF(R2ST(I).GT.RTWO)IOMTT(I)=1
      ENDDO
C
      IF(ICCINT.EQ.1.AND.NCHOP.EQ.0) THEN
        CALL CCINT(IOMTT,NCHOP)
      ELSE
        CALL OOINT(IOMTT,NCHOP)
        IF(NCHOP.NE.NCHF) THEN
          IF(IOCINT.EQ.1)CALL OCINT(IOMTT,NCHOP)
          IF(ICCINT.EQ.1)CALL CCINT(IOMTT,NCHOP)
        ENDIF
      ENDIF
C
C CONVERT TO (P) Q INTEGRALS
C
      IF(IQDT.GT.0.AND.INTPQ.NE.0)THEN
C
C OPEN-CLOSED
C
        DO J=NCHOP1,NCHF
          TNORM=SIN(PI*FKNU(J))*C(J)-COS(PI*FKNU(J))*S(J)
          TNORM=TNORM/FS(1,J)
          CNORM(J)=TNORM*COS(PI*FKNU(J))
          SNORM(J)=TNORM*SIN(PI*FKNU(J))
        ENDDO
        DO I=1,NCHOP
          DO J=NCHOP1,NCHF
            ACS(J,I)=ASS(J,I)
            ACC(J,I)=ASC(J,I)
            ASS(J,I)=-CNORM(J)*ASS(J,I)
            ASC(J,I)=-CNORM(J)*ASC(J,I)
            ACS(J,I)=SNORM(J)*ACS(J,I)
            ACC(J,I)=SNORM(J)*ACC(J,I)
          ENDDO
        ENDDO
C
C CLOSED-CLOSED
C
        DO I=NCHOP1,NCHF
          DO J=I,NCHF
            ASC(J,I)=ASS(J,I)
            ACS(J,I)=ASS(J,I)
            ACC(J,I)=ASS(J,I)
            ASS(J,I)=CNORM(J)*CNORM(I)*ASS(J,I)
            ASC(J,I)=-CNORM(J)*SNORM(I)*ASC(J,I)
            ACS(J,I)=-SNORM(J)*CNORM(I)*ACS(J,I)
            ACC(J,I)=SNORM(J)*SNORM(I)*ACC(J,I)
          ENDDO
        ENDDO
C
      ENDIF
C
C  SYMMETRISE ALPHA
C
      DO I=1,NCHF
        AA=(ASC(I,I)+ACS(I,I))/TWO
        ASC(I,I)=AA
        ACS(I,I)=AA
      ENDDO
C
      IF(NCHF.NE.1) THEN
        DO I=2,NCHF
          K=I-1
          DO J=1,K
            ASS(J,I)=ASS(I,J)
            ACC(J,I)=ACC(I,J)
            ASC(J,I)=ACS(I,J)
            ACS(J,I)=ASC(I,J)
          ENDDO
        ENDDO
      ENDIF
C
      IF(IPRINT.GT.1)THEN
        WRITE(6,750)
        DO I=1,NCHOP
          DO J=I,NCHOP
            LIJ=LAMP(J,I)
            IF(LIJ.NE.1.AND.LIJ.LE.LMX+1) THEN
              WRITE(6,760)J,I,ASS(J,I),ASC(J,I),ACS(J,I),ACC(J,I)
            ENDIF
          ENDDO
        ENDDO
        IF(IOCINT.EQ.1)THEN
        DO I=1,NCHOP
          DO J=NCHOP1,NCHF
            LIJ=LAMP(J,I)
            IF(LIJ.NE.1.AND.LIJ.LE.LMX+1) THEN
              WRITE(6,760)J,I,ASS(J,I),ASC(J,I)
            ENDIF
          ENDDO
        ENDDO
        ENDIF
        IF(ICCINT.EQ.1)THEN
        DO I=NCHOP1,NCHF
          DO J=NCHOP1,NCHF
            LIJ=LAMP(J,I)
            IF(LIJ.NE.1.AND.LIJ.LE.LMX+1) THEN
              WRITE(6,760)J,I,ASS(J,I),ASC(J,I),ACS(J,I)
            ENDIF
          ENDDO
        ENDDO
        ENDIF
      ENDIF
C
  750 FORMAT(/' J,I AND ASS(J,I), ASC(J,I), ACS(J,I), ACC(J,I)'/)
  760 FORMAT(2I5,4E14.6)
C
      RETURN
      END
C**********************************************************
C
      SUBROUTINE ALPHAQ(NCHOP)
C
C NRB:
C  CALCULATES ALPHA INTEGRALS FOR MQDT CASE
C  INTERFACES WITH FR'S CORINT ROUTINE.
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
C
      LOGICAL QDT
C
      COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC
      COMMON/CALP/ASS(MZCHF,MZCHF),ASC(MZCHF,MZCHF),ACS(MZCHF,MZCHF)
     1 ,ACC(MZCHF,MZCHF)
      COMMON/CBODE/WBODE(MZPTS),TBODE(MZPTS,MZLMX+1)
C  ***  NOTE CHANGE OF CC TO CCT IN /CHAN/ ***
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHPP,NCHPP1
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/COULSC/FS(MZPTS,MZCHF),FSP(MZCHF),FC(MZPTS,MZCHF)
     1 ,FCP(MZCHF)
      COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2
      COMMON/CPOT/BW(MZCHF,MZCHF),LAMP(MZCHF,MZCHF)
      COMMON/CQDT/R2ST(MZCHF),QDT,NQ
      COMMON/NRBDD2/FSP2(MZCHF),FCP2(MZCHF),IFDD2
      COMMON/NRBLMX/LMX
      COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT
      COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN
      COMMON/NRBZED/TZED,LPRTSW
C
      DIMENSION IOMTT(MZCHF)
C
C
C  INITIALISE ALPHA TO ZERO
C
      DO J=1,NCHF
        DO I=J,NCHF
          ASS(I,J)=TZERO
          ASC(I,J)=TZERO
          ACS(I,J)=TZERO
          ACC(I,J)=TZERO
        ENDDO
      ENDDO
C
      IF(ICCINT.NE.1.AND.NCHOP.EQ.0) RETURN
C
      IF(IFDD2.NE.0)STOP'ALPHAQ: NEED DERIVATIVES AT RTWO'
C
      DO I=1,NCHF
        IOMTT(I)=IOMIT(I)*2
        IF(IOMIT(I).LE.0)THEN
          IF(I.GT.NCHOP.AND.R2ST(I).LT.RTWOC)IOMTT(I)=1
          IF(RINF(I).LE.TZERO)IOMTT(I)=2
CT          IF(RINF(I).GT.RZERO.AND.IPERT.GT.0)IOMTT(I)=2
        ENDIF
      ENDDO
C
      NCHOP1=NCHOP+1
      IOCINT=IABS(ICCINT)
      JMAX=NCHF
      IF(IOCINT.NE.1)JMAX=NCHOP
C
C
C  CONTRIBUTION FROM RZERO TO RTWO
C  START LOOP ON RADIAL POINTS
C
C NRB: THIS RZERO TO RTWO/C PART IS VERY TIME CONSUMING,
C      EVEN FOR JUST A FEW HUNDRED POINTS.
C
      IF(IRAD.EQ.0)THEN
        R0=RTWOC
        KP2T=KP2C
      ELSE             !RTWO ARTIFICIALLY LARGE (BUT LOW-L SO....)
        R0=RZERO
        KP2T=1
        IF(KP0.NE.KP2T)STOP'KP0 .NE. 1 ??'
      ENDIF
C
      IF(KP2T.GT.1)THEN
C
C  OPEN-OPEN AND OPEN-CLOSED PARTS
C
        IF(NCHOP.GT.0) THEN
          DO I=1,NCHOP
            DO J=I,JMAX
              LIJ=LAMP(J,I)
              IF(LIJ.NE.1.AND.LIJ.LE.LMX+1.AND.IOMTT(J).LE.1) THEN
                DO K=1,KP2T
                  WIJ=TBODE(K,LIJ)*BW(J,I)
                  T1=WIJ*FS(K,J)
                  T2=WIJ*FC(K,J)
                  ASS(J,I)=ASS(J,I)+FS(K,I)*T1
                  ACS(J,I)=ACS(J,I)+FS(K,I)*T2
                  ASC(J,I)=ASC(J,I)+FC(K,I)*T1
                  ACC(J,I)=ACC(J,I)+FC(K,I)*T2
                ENDDO
              ENDIF
            ENDDO
          ENDDO
        ENDIF
C
C  CLOSED-CLOSED PART
C
        IF(ICCINT.EQ.1.AND.NCHOP.NE.NCHF) THEN
          DO I=NCHOP1,NCHF
            IF(IOMTT(I).LE.0)THEN
              DO J=I,NCHF
                LIJ=LAMP(J,I)
                IF(LIJ.NE.1.AND.LIJ.LE.LMX+1.AND.IOMTT(J).LE.0) THEN
                  DO K=1,KP2T
                    WIJ=TBODE(K,LIJ)*BW(J,I)
                    T1=WIJ*FS(K,J)
                    T2=WIJ*FC(K,J)
                    ASS(J,I)=ASS(J,I)+FS(K,I)*T1
                    ACS(J,I)=ACS(J,I)+FS(K,I)*T2
                    ASC(J,I)=ASC(J,I)+FC(K,I)*T1
                    ACC(J,I)=ACC(J,I)+FC(K,I)*T2
                  ENDDO
                ENDIF
              ENDDO
            ENDIF
          ENDDO
        ENDIF
      ENDIF
C
C
C  ASYMPTOTIC INTEGRALS FOR R=RTWO/C TO INFINITY
C
      DO I=1,NCHF
        IF(RINF(I).GT.RTWO)IOMTT(I)=2
      ENDDO
C
      NCH=NCHOP
      IF(ICCINT.EQ.1)NCH=NCHF
      DO 55 I=1,NCH
        IF(IOMTT(I).GT.1)GO TO 55
        DO 50 J=I,JMAX
          IF(IOMTT(J).GT.1)GO TO 50
          IF(I.GT.NCHOP.AND.IOMTT(I)+IOMTT(J).GT.0)GO TO 50
          LIJ=LAMP(J,I)
          IF(LIJ.EQ.1.OR.LIJ.GT.LMX+1)GOTO 50
          L1=LLCH(I)
          L2=LLCH(J)
          E1=EPS(I)/TWO
          E2=EPS(J)/TWO
          KTRUE=LIJ
          IF(KP2T.GT.1)THEN
            DF1=FSP2(I)
            DG1=-FCP2(I)
            DF2=FSP2(J)
            DG2=-FCP2(J)
          ELSE
            DF1=FSP(I)
            DG1=-FCP(I)
            DF2=FSP(J)
            DG2=-FCP(J)
          ENDIF
          F1=FS(KP2T,I)
          G1=-FC(KP2T,I)
          F2=FS(KP2T,J)
          G2=-FC(KP2T,J)
C
          CALL CORINT(L1,L2,E1,E2,KTRUE,R0,TZED,F1,DF1,G1,DG1,F2,DF2
     X            ,G2,DG2,F1F2,G1F2,F1G2,G1G2)
C
          BWIJ=BW(I,J)
          ASS(J,I)=ASS(J,I)+BWIJ*F1F2
          ASC(J,I)=ASC(J,I)-BWIJ*G1F2
          ACS(J,I)=ACS(J,I)-BWIJ*F1G2
          ACC(J,I)=ACC(J,I)+BWIJ*G1G2
   50   CONTINUE
   55 CONTINUE
C
C  SYMMETRISE ALPHA
C
      DO I=1,NCHF
        A=(ASC(I,I)+ACS(I,I))/TWO
        ASC(I,I)=A
        ACS(I,I)=A
      ENDDO
C
      IF(NCHF.NE.1) THEN
        DO I=2,NCHF
          K=I-1
          DO J=1,K
            ASS(J,I)=ASS(I,J)
            ACC(J,I)=ACC(I,J)
            ASC(J,I)=ACS(I,J)
            ACS(J,I)=ASC(I,J)
          ENDDO
        ENDDO
      ENDIF
C
      IF(IPRINT.GT.1)THEN
        WRITE(6,750)
        WRITE(6,*)'OPEN-OPEN'
        DO I=1,NCHOP
          DO J=I,NCHOP
            LIJ=LAMP(J,I)
            IF(LIJ.NE.1.AND.LIJ.LE.LMX+1) THEN
              WRITE(6,760)J,I,ASS(J,I),ASC(J,I),ACS(J,I),ACC(J,I)
            ENDIF
          ENDDO
        ENDDO
        IF(IOCINT.EQ.1)THEN
        WRITE(6,*)'CLOSED-OPEN'
        DO I=1,NCHOP
          DO J=NCHOP1,NCHF
            LIJ=LAMP(J,I)
            IF(LIJ.NE.1.AND.LIJ.LE.LMX+1) THEN
              WRITE(6,760)J,I,ASS(J,I),ASC(J,I),ACS(J,I),ACC(J,I)
            ENDIF
          ENDDO
        ENDDO
        ENDIF
        IF(ICCINT.EQ.1)THEN
        WRITE(6,*)'CLOSED-CLOSED'
        DO I=NCHOP1,NCHF
          DO J=NCHOP1,NCHF
            LIJ=LAMP(J,I)
            IF(LIJ.NE.1.AND.LIJ.LE.LMX+1) THEN
              WRITE(6,760)J,I,ASS(J,I),ASC(J,I),ACS(J,I),ACC(J,I)
            ENDIF
          ENDDO
        ENDDO
        ENDIF
      ENDIF
C
 750  FORMAT(/' J,I AND ASS(J,I), ASC(J,I), ACS(J,I), ACC(J,I)'/)
 760  FORMAT(2I5,4E14.6)
C
      RETURN
      END
C***********************************************************************
       REAL*8 FUNCTION ARGAM(L,A)
C
       IMPLICIT REAL*8 (A-H,O-Z)
C
C CALCULATES ARGGAMMA(L+1+I*A)
C WHERE L IS AN INTEGER NOT LESS THAN ZERO
C
       B=ABS(A)
       B=250.0D0*B**0.25D0-A*A
       J0=L+1
       C=J0
       D=C*C
       Z=0.0D0
       IF(D -B)1,6,6
    1  B=SQRT (B)
       J1=B
       DO 5 J=J0,J1
       D=J
       D=A/D
       G1=ABS(D)
       IF(G1-0.1D0)2,3,3
    2  G1=D*D
       G2=-35.0D0*G1+45.0D0
       G2=-G1*G2+63.0D0
       G2=-G1*G2+105.0D0
       G1=D -D*G1*G2/315.0D0
       GO TO 4
    3  G1=ATAN (D)
    4  Z=Z+G1
    5  CONTINUE
       J0=J1+1
    6  D=J0
       G0=D*D
       U=A*A
       G1=1.0D0/(G0+U)
       G2=G1*G1
       G3=10.0D0*G0*G0-20.0D0*G0*U+2.0D0*U*U
       G3=G3*G2-21.0D0*G0+7.0D0*U
       G3=G3*G2+210.0D0
       G1=A*G3*G1/2520.0D0
        ARGAM=-Z+0.5D0*A*LOG(G0+U)+(D -0.5D0)*ATAN(A/D)-A-G1
       RETURN
      END
C***************************************************************
C
      REAL*8 FUNCTION ARGC(E,L,AC)
C
C  CALCULATES ARG(GAMMA(L+1-I/K)) -1/K -(1/K)*LN(K) - L*PI/2
C  NRB: NOT ACTUALLY CALLED BY INJWBK CASE TZED=0.
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/NRBZED/TZED,LPRTSW
C
      IF(TZED.EQ.0.)THEN
        ARGC=-DBLE(L)*1.570796327
        RETURN
      ENDIF
C
      IF(E.GT.0)GOTO 10
      ARGC=-(DBLE(L)+.25)*3.141592654
      RETURN
C
   10 FK=SQRT(E)
      ET=1./FK
      IP=L+1
      P=IP
      PP=IP*IP
C
      IF(AC.LT.1.E-4)GOTO 100
      A1=10.*SQRT(ET)-ET*ET
      IF(A1.GT.PP)GOTO 20
      X=PP*E
      XP1=X+1.
      XH=P*FK
      A=-1.570796327*(P+DBLE(L)-.5)
      GOTO 200
   20 L1=IP
      IP=1.+SQRT(A1)
      P=IP
      PP=IP*IP
      X=PP*E
      XP1=X+1.
      XH=P*FK
      A=-1.570796327*(P+DBLE(L)-.5)
      L2=IP-1
      DO 30 I=L1,L2
   30 A=A+ATAN(ET/DBLE(I))
      GOTO 200
C
  100 A1=35.*ET**.25-ET*ET
      IF(A1.GT.PP)GOTO 120
      X=PP*E
      XP1=X+1.
      XH=P*FK
      A=-1.570796327*(P+DBLE(L)-.5)
      GOTO 140
  120 L1=IP
      IP=1.+SQRT(A1)
      P=IP
      PP=IP*IP
      X=PP*E
      XP1=X+1.
      XH=P*FK
      A=-1.570796327*(P+DBLE(L)-.5)
      L2=IP-1
      DO 130 I=L1,L2
  130 A=A+ATAN(ET/DBLE(I))
  140 A=A+.000396825540*FK*E*(7.*(1.-3.*X)*XP1*XP1+
     C 2.*E*(1.-10.*X+5.*X*X))*XP1**(-5)
C
  200 A1=FK*X*X*.1667*PP
      IF(A1.GT.AC)GOTO 210
      A=A-FK*(2.-X)*.25*PP
      GOTO 220
  210 A=A-.5*ET*LOG(XP1)
  220 A2=(P-.5)*XH
      A1=A2*X*X
      IF(A1.GT.AC)GOTO 230
      A=A+A2*(1.-X*.33333333)
      GOTO 240
  230 A=A+(P-.5)*ATAN(XH)
  240 ARGC=A+FK/(12.*(1.+X))
C
      RETURN
      END
C**********************************************************************
C
      SUBROUTINE BDORG
C
C  ORGANIZE THE READING OF THE B AND D FILES
C
      IMPLICIT REAL*8 (A-H,O-y)
      IMPLICIT COMPLEX*16 (Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (MNPEXT=MZMNP+MZCHF)
C
      COMMON/A1/AVECT1(MNPEXT,MZEST),MXE1
      COMMON/BDSYM/ISB(MZSLP),ILB(MZSLP),IPB(MZSLP),NFILEB,
     1             ISDL(MZSLP),ILDL(MZSLP),IPDL(MZSLP),NFILED,
     2             ISDR(MZSLP),ILDR(MZSLP),IPDR(MZSLP),
     3             NFBD,NFB(3),NFD(3),MXEB(3)
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR),
     5 WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/GAUGE/IGAUGE
      COMMON/RADDEC/EDEC(MZDEC),DDEC(MNPEXT,MZDEC),NDEC
      COMMON/NRBPH1/ZCOEF(MNPEXT,MZCHF),OMEGPR(MZMET,MZMSH),EPHMIN,
     1              EPHMAX,IPHOTO,NODAMP
      COMMON/NRBPH6/EPI(MZMSH,MZEPI,MZMET),XPI(MZMSH,0:MZPHT,MZEPI
     X,MZMET),EBB(MZEPI,MZMET),XPITOT(MZMSH,MZEPI,MZMET),NPISYM,NPIEB
      COMMON/NRBPH7/ZBB(MZDIP,MZCHF),ZDIP(MZDIP,MZCHF)
     X,ZD(MZCHF,MZCHF),ZE(MZCHF,MZCHF),ZF(MZCHF,MZCHF)
     X,IDEC(MZEPI*MZMET),JDEC(MZDEC),IPIV(MZCHF),NDEC0
C
      MSLP3=10000*NSPN2+100*LRGL2+NPTY2
C
      NFBD=0
      DO 10 I=1,NFILEB
        LDIFF=ABS(ILB(I)-LRGL2)
        IF(NSPN2.EQ.0)LDIFF=LDIFF/2
        IF(ISB(I).EQ.NSPN2.AND.LDIFF.LE.1.AND.IPB(I).NE.NPTY2)THEN
          IF(ILB(I).EQ.0.AND.LRGL2.EQ.0)GO TO 10
          NFBD=NFBD+1
          IF(NFBD.GT.3)STOP'***BDORG, INPUT ERROR'
          NFB(NFBD)=I
          MSLP1=10000*ISB(I)+100*ILB(I)+IPB(I)
          DO J=1,NFILED
            MSLP2=10000*ISDL(J)+100*ILDL(J)+IPDL(J)
            MSLP4=10000*ISDR(J)+100*ILDR(J)+IPDR(J)
            IF(MSLP1.EQ.MSLP2.AND.MSLP3.EQ.MSLP4) THEN
              NFD(NFBD)=J
              GO TO 10
            ELSEIF(MSLP1.EQ.MSLP4.AND.MSLP3.EQ.MSLP2) THEN
              NFD(NFBD)=-J
              GO TO 10
            ENDIF
          ENDDO
        WRITE(6,*)' **WARNING**, UNABLE TO FIND D-FILE TO MATCH B-FILE'
          WRITE(6,*)ISB(I),ILB(I),IPB(I),NSPN2,LRGL2,NPTY2
C          STOP       !CPB 01/02/00
        ENDIF
   10 CONTINUE
C
      IF(NFBD.EQ.0)THEN
        WRITE(6,*)' *** NO B-FILE FOUND FOR THIS STGF CASE'
      ELSE
        WRITE(6,*)' *** B-FILES FOUND FOR THIS STGF CASE'
        DO N=1,NFBD
          I=NFB(N)
          WRITE(6,*)ISB(I),ILB(I),IPB(I)
        ENDDO
      ENDIF
C
      NDEC=0
      IF(IGAUGE.EQ.0)LV=1
      IF(IGAUGE.NE.0)LV=2
C
      DO MF=1,NFBD
        CALL READB(NFB(MF))
        MXEB(MF)=MXE1
C       write(6,*)'NFBD',MF
        CALL READD(NFD(MF),LV)
      ENDDO
C
C DETERMINE INITIAL STATES
C
      IF(IPHOTO.GT.0)THEN
C
C       LOOP OVER INITIAL SYMMETRIES
        ND=0
        NDEC0=0
        DO N=1,NFBD
          IB=NFB(N)
          IF(IB.LE.NPISYM)THEN
C
C         LOOP OVER INITIAL ENERGIES
            IE1MX=MIN(NPIEB,MXEB(N))
            DO IE1=1,IE1MX
              ND=ND+1
              NDEC0=NDEC0+1
              IDEC(NDEC0)=ND
              JDEC(ND)=NDEC0
            ENDDO
            ND=ND+MXEB(N)-IE1MX
          ELSE
            ND=ND+MXEB(N)
          ENDIF
        ENDDO
        IF(ND.NE.NDEC)STOP'***PHOTO: MIS-MATCH ON NDEC'
        IF(NDEC0.EQ.0)RETURN
      ELSEIF(IPHOTO.LT.0)THEN
        IF(NDEC.GT.MZDIP)THEN
          WRITE(6,*)' FOR IPHOTO < 0, INCREASE MZDIP TO: ',NDEC
          STOP 'FOR IPHOTO < 0, INCREASE MZDIP'
        ENDIF
        NDEC0=NDEC
        DO I=1,NDEC
          IDEC(I)=I
        ENDDO
      ELSE
        NDEC0=0
      ENDIF
C
      RETURN
      END
C
C***************************************************************
C
      SUBROUTINE BLOCK
C
C  PROVIDES
C     BLOCK DATA
C  CALLED AS SUBROUTINE TO AVOID LINKAGE PROBLEMS WITH LIBRARIES
C
C  DATA FOR QUADRATURES -
C  LAGUERRE AND LEGENDRE QUADRATURES WITH NUMBERS OF POINTS
C  N = 2, 4, 6, 8 AND 10
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/CBLK/XLAG(30),WLAG(30),XLEG(15),WLEG(15)
C
      DATA XLAG/
     1 .58578644,3.4142136,
     2 .32254769,1.7457611,4.5366203,9.3950709,
     3 .22284660,1.1889321,2.9927363,5.7751436,9.8374674,
     4 15.982874,
     5 .17027963,.90370178,2.2510866,4.26670017,7.0459054,
     6 10.758516,15.7406786,22.8631317,
     7 .13779347,.72945455,1.8083429,3.4014337,5.5524961,
     8 8.3301527,11.8437858,16.279258,21.996586,29.920697/
      DATA WLAG/
     1 .85355339,.14644661,
     2 .60315410,.35741869,.38887909E-1,.53929471E-3,
     3 .45896467,.41700083,.11337338,.10399197E-1,
     4 .26101720E-3,.89854791E-6,
     5 .36918859,.41878678,.17579499,3.3343492E-2,2.7945362E-3,
     6 9.0765088E-5,8.4857467E-7,1.0480012E-9,
     7 .30844112,.40111993,.21806829,6.2087456E-2,9.5015170E-3,
     8 7.5300839E-4,2.8259233E-5,4.2493140E-7,1.8395648E-9,
     9 9.9118272E-13/
      DATA XLEG,WLEG/.577350269,
     1 .339981044,.861136312,
     2 .238619186,.661209386,.932469514,
     3 .183434642,.525532410,.796666477,.960289856,
     4 .148874339,.433395394,.679409568,.865063367,.973906529,
     5 1.,
     6 .652145159,.347854845,
     7 .467913935,.360761573,.171324492,
     8 .362683783,.313706646,.222381034,.101228536,
     9 .295524225,.269266719,.219086363,.149451349,.066671344/
C
      RETURN
      END
C
C***************************************************************
C
      SUBROUTINE BODE(H,KP2,IPERT,RZERO)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (ONE=1.0)
      PARAMETER (T1=14.0)
      PARAMETER (T2=64.0)
      PARAMETER (T3=24.0)
      PARAMETER (T4=28.0)
C
      COMMON/CBODE/WBODE(MZPTS),TBODE(MZPTS,MZLMX+1)
      COMMON/NRBLMX/LMX
C
      W=T1*H/45
      WBODE(1)=W
      WBODE(KP2)=W
      W=T2*H/45
      M=KP2-1
      DO K=2,M,2
        WBODE(K)=W
      ENDDO
      W=T3*H/45
      M=KP2-2
      DO K=3,M,4
        WBODE(K)=W
      ENDDO
      W=T4*H/45
      M=KP2-4
      DO K=5,M,4
        WBODE(K)=W
      ENDDO
C
      IF(IPERT.EQ.0.OR.LMX.LT.1.OR.KP2.LE.1)RETURN
C
      R=RZERO-H
      DO K=1,KP2
        R=R+H
        TBODE(K,1)=ONE/R
      ENDDO
      DO I=1,LMX
        IP=I+1
        DO K=1,KP2
          TBODE(K,IP)=TBODE(K,I)*TBODE(K,1)
        ENDDO
      ENDDO
      DO I=1,LMX
        IP=I+1
        DO K=1,KP2
          TBODE(K,IP)=TBODE(K,IP)*WBODE(K)
        ENDDO
      ENDDO
C
      RETURN
      END
C
C***********************************************************************
C
      REAL*8 FUNCTION BUT0(NBUT,U)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      LOGICAL POLE
C
      COMMON/CBUT/FKN(0:MZNRG),UKN(0:MZNRG)
C
      BUT0=0.
C
C  CASE OF U.GT.0.04
      IF(U.GT..04)THEN
        FK=SQRT(U)
        POLE=.FALSE.
        DO 10 N=0,NBUT
        IF(ABS(FK-FKN(N)).GT..3)THEN
          BUT0=BUT0+1./(U-UKN(N))
        ELSE
          POLE=.TRUE.
          D1=FK-FKN(N)
        ENDIF
   10   CONTINUE
        IF(POLE)THEN
          D2=D1**2
          D=.33333333*D1*(1.+.066666667*D2*(1.+.0952381*D2))
          BUT0=2.*BUT0+(D+1./(2.*FK-D1))/FK
        ELSE
          BUT0=2.*BUT0+TAN(FK)/FK
        ENDIF
C
C  SUM FOR U.LT..04
      ELSE
        DO 20 N=0,NBUT
   20   BUT0=BUT0+1./(U-UKN(N))
C
C  CASE OF U.LT..04 AND U.GT.-.04
        IF(U.GT.-.04)THEN
          BUT0=2.*BUT0+1.+.33333333*U*(1.+.4*U)
C
C  CASE OF U.LT.-.04
        ELSE
          FK=SQRT(-U)
          BUT0=2.*BUT0+TANH(FK)/FK
        ENDIF
C
      ENDIF
C
      RETURN
      END
C***************************************************************
C
      SUBROUTINE CCINT(IOMTT,NCHOP)
C
C
C CLOSED-CLOSED:
C  CALCULATES T INTEGRALS USING LAGUERRE QUADRATURE
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      LOGICAL QDT
C
      INCLUDE 'PARAM'
C
      COMMON/CALP/ASS(MZCHF,MZCHF),ASC(MZCHF,MZCHF),ACS(MZCHF,MZCHF)
     1 ,ACC(MZCHF,MZCHF)
      COMMON/CPOT/BW(MZCHF,MZCHF),LAMP(MZCHF,MZCHF)
      COMMON/CBLK/XLAG(30),WLAG(30),XLEG(15),WLEG(15)
      COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF)
     X  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHPP,NCHPP1
      COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC
      COMMON/CTHET/BB(MZCHF,MZTET),BG(MZCHF,MZTET),MSUM(MZCHF)
      COMMON/CQDT/R2ST(MZCHF),QDT,NQ
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/NRBLMX/LMX
C
      DIMENSION TI(30),TDI(30),TPI(30),TJ(30),TDJ(30),TPJ(30)
     X,IOMTT(MZCHF)
C
C
      NCHOP1=NCHOP+1
C
      DO I=NCHOP1,NCHF
        IF(IOMTT(I).EQ.0)THEN
        DO J=I,NCHF
          IF(IOMTT(J).EQ.0)THEN
          LIJ=LAMP(J,I)
          IF(LIJ.NE.1.AND.LIJ.LE.LMX+1) THEN
            NLAG=2*LIJ+LACC
            NLAG=MIN(NLAG,10)
            BIJ=BW(J,I)
C
C  CAP K
            FNUI=BB(I,1)
            FNUJ=BB(J,1)
            FK=1./FNUI+1./FNUJ
C  INITIALISE FOR QUADRATURE
            NS=NLAG/2
            M=NS*(NS-1)
            N1=M+1
            N2=M+NLAG
            CALL TANDTDN(FK,N1,N2,I,TI,TDI,TPI)
            CALL TANDTDN(FK,N1,N2,J,TJ,TDJ,TPJ)
            T1=0.
            T2=0.
            T3=0.
C  START QUADRATURE
            DO N=N1,N2
              U=XLAG(N)
              R=RTWO+U/FK
C  CALCULATE THETA FUNCTIONS
C  ADD TO SUM
C++ VAX MOD
C     A1=(R**(-LIJ))*WLAG(N)*EXP(U+TPI+TPJ)
              A1=(R**(-LIJ))*WLAG(N)
              U2=.5*U
              AI=EXP(U2+TPI(N))
              AJ=EXP(U2+TPJ(N))
              TI(N)=TI(N)*AI
              TDI(N)=TDI(N)*AI
              TJ(N)=TJ(N)*AJ
              TDJ(N)=TDJ(N)*AJ
C++ END MOD
              T1=T1+TI(N)*A1*TJ(N)
              T2=T2+TDI(N)*A1*TJ(N)
              T3=T3+TI(N)*A1*TDJ(N)
            ENDDO
            F1=1./FK
            T1=T1*F1
            T2=T2*F1
            T3=T3*F1
            ASS(J,I)=ASS(J,I)+T1*BIJ
            ASC(J,I)=ASC(J,I)+T2*BIJ
            ACS(J,I)=ACS(J,I)+T3*BIJ
          ENDIF
          ENDIF
        ENDDO
        ENDIF
      ENDDO
      RETURN
      END
C************************************************************************
      SUBROUTINE CORINT(L1,L2,E1,E2,KTRUE,R0,ZCH
     1     ,F1,DF1,G1,DG1,F2,DF2,G2,DG2,F1F2,G1F2,F1G2,G1G2)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (NPTS0=MZPTS+250)
C
      COMPLEX*16 Z,ZZ,AK1,F12,DH,FUN2(NPTS0),FUN3(NPTS0),
     1  K21,K22,FUN1(NPTS0),COEF(4),K23,YP,Y0,YM,WP,W0,WM
C
C F. ROBICHEAUX
C THIS SUBROUTINE CALCULATES THE 4 INTEGRALS
C INT _R_0^INFTY (F_1,G_1)(F_2,G_2)/R^KTRUE BY DIRECT SOLUTION OF THE
C SCHR. EQ IN THE COMPLEX R-PLANE.
C IT IS ASSUMED THE F_I,G_I ARE SOLUTIONS OF THE DIFFERENTIAL EQUATION
C Y''_I+2(EI+ZCH/R-LI(LI+1)/R^2)Y_I=0
C
C THE INPUTS ARE:
C ZCH -- THE CHARGE
C R0 -- RADIUS TO BEGIN THE INTEGRATION
C KTRUE -- THE MULTIPOLE OF THE POTENTIAL (SEE ABOVE)
C LI -- INTEGER, THE ANGULAR MOMENTUM OF THE PARTIAL WAVE
C EI -- THE ENERGY OF THE PARTIAL WAVE (NOTE: E2<E1)
C FI -- THE VALUE OF F_I(R_0)
C GI -- THE VALUE OF G_I(R_0)
C DFI -- THE VALUE OF DF/DR|_I(R_0)    - I=1 NOT USED - NRB
C DGI -- THE VALUE OF DG/DR|_I(R_0)
C F1F2, F1G2, G1F2, G1G2 -- THE OUTPUT INTEGRALS
C
C MODIFIED BY NRB TO HANDLE INTEGRAL FROM RTWOC RATHER THAN RZERO.
C
      AC=1.E-4
C
      COEF(1)=1.7D0/4.8D0
      COEF(2)=5.9D0/4.8D0
      COEF(3)=4.3D0/4.8D0
      COEF(4)=4.9D0/4.8D0
      ITIM=0
      IF(E2 .GT. E1) STOP 'REVERSE 1 AND 2 CORINT'
C
      AL1=DBLE(L1*L1+L1)/2.D0
      AL2=DBLE(L2*L2+L2)/2.D0
      TES1=2.D0*ABS(E1+ZCH/R0-AL1/(R0*R0))
      IF(TES1 .LT. (2.D0*ABS(E1)))TES1=2.D0*ABS(E1)
      TES2=2.D0*ABS(E2+ZCH/R0-AL2/(R0*R0))
      IF(TES2 .LT. (2.D0*ABS(E2)))TES2=2.D0*ABS(E2)
      IF(TES1 .GT. TES2) THEN
        H=.2D0/SQRT(TES1)
      ELSE
        H=.2D0/SQRT(TES2)
      END IF
c      if(ac.gt.5.e-5)h=2.*h
      IF(E2 .GT. 0.D0) THEN
        YF=1.6D1/(SQRT(E1)-SQRT(E2)+1.D-6)
      ELSE
        IF(E1 .GT. 0.D0) THEN
          YF=1.6D1/SQRT(E1)
        ELSEIF(L1.LT.30)THEN          !CATCH OVERFLOW
          YF=10000*H
        ELSE
          F1F2=0.D0
          G1F2=0.D0
          F1G2=0.D0
          G1G2=0.D0
          RETURN                      !QUICK RETURN
        END IF
      END IF
      IGO=0
      NPTS=NINT(YF/H)
      IF(NPTS.LT.8)THEN
        F1F2=0.D0
        G1F2=0.D0
        F1G2=0.D0
        G1G2=0.D0
        RETURN                        !QUICK RETURN
      ENDIF
C
      IF(NPTS .GT. NPTS0) THEN
        IGO=1
        TL=L2*L1
        T=SQRT(TL)
        T=10.*T
        IF(AC.LT.5.E-5)T=T*2.
        TL=MIN(T,TL)
        NPTS=250+TL
        NPTS=MIN(NPTS,NPTS0)
      END IF
      H2=H*H/6.D0
      DH=(0.D0,1.D0)*H
      R=H
      R0SQ=R0*R0
      DO J = 1,NPTS
        R=R-H
        T=1.D0/(R0SQ+R*R)
        F12=(R0*T)+(0.D0,1.D0)*(R*T)
        FUN1(J)=F12
        FUN2(J)=F12*F12
        FUN3(J)=F12**KTRUE
      ENDDO
      DO J = 1,4
        FUN3(J)=FUN3(J)*COEF(J)
        FUN3(NPTS+1-J)=FUN3(NPTS+1-J)*COEF(J)
      ENDDO
C
      J=NPTS
C
      AL2H2=AL1*H2
      E2H2=1.D0-E1*H2
      ZCHH2=-ZCH*H2
      K21=2.D0*(E1+ZCH*FUN1(J)-AL1*FUN2(J))
      K22=2.D0*(E1+ZCH*FUN1(J-1)-AL1*FUN2(J-1))
      AK1=SQRT(K21)+SQRT(K22)
      Y0=(1.D0,1.D0)/1.D10
      YP=Y0*EXP(.5D0*H*AK1)
      K23=1.D0-K22*H2*.5D0
      K22=1.D0-K21*H2*.5D0
      FUN3(J)=FUN3(J)*Y0
      FUN3(J-1)=FUN3(J-1)*YP
C
      K=NPTS-2
      DO J = K,1,-1
        K21=K22
        K22=K23
        K23=E2H2+ZCHH2*FUN1(J)+AL2H2*FUN2(J)
        YM=Y0
        Y0=YP
        YP=((12.D0-10.D0*K22)*Y0-K21*YM)/K23
        FUN3(J)=FUN3(J)*YP
      ENDDO
C
      AL2H2=AL2*H2
      E2H2=1.D0-E2*H2
      K22=2.D0*(E2+ZCH*FUN1(1)-AL2*FUN2(1))
      K21=-2.D0*(ZCH-2.D0*AL2*FUN1(1))*FUN2(1)
      K23=E2H2+ZCHH2*FUN1(2)+AL2H2*FUN2(2)
      Y0=F2
      YP=Y0+DH*DF2+H2*K22*F2*3.D0+DH*H2*(K22*DF2+K21*F2)
      W0=G2
      WP=W0+DH*DG2+H2*K22*G2*3.D0+DH*H2*(K22*DG2+K21*G2)
      K22=1.D0-K22*H2*.5D0
      AK1=Y0*FUN3(1)+YP*FUN3(2)
      F12=W0*FUN3(1)+WP*FUN3(2)
C
      DO J = 3,NPTS
        K21=K22
        K22=K23
        K23=E2H2+ZCHH2*FUN1(J)+AL2H2*FUN2(J)
        YM=Y0
        Y0=YP
        Z=1.D0/K23
        ZZ=12.D0-10.D0*K22
        YP=(ZZ*Y0-K21*YM)*Z
        WM=W0
        W0=WP
        WP=(ZZ*W0-K21*WM)*Z
        AK1=AK1+YP*FUN3(J)
        F12=F12+WP*FUN3(J)
      ENDDO
C
      AK1=AK1*DH
      F12=F12*DH
      IF (IGO .EQ. 1)THEN
        IF(E2 .GT. 0.D0) THEN
          K21=(0.D0,1.D0)*ZCH*(1.D0/SQRT(2.D0*E2)
     X        -1.D0/SQRT(2.D0*E1))-KTRUE
          K22=(0.D0,1.D0)*(SQRT(2.D0*E1)-SQRT(2.D0*E2))
          Z=R0+DH*(NPTS-1)
          YM=FUN3(NPTS)/COEF(1)
          TES=ABS(Z)*ABS(SQRT(ABS(E1))-SQRT(ABS(E2)))
          IF(TES .LT. 1.D-6) THEN
            WM=YM*Z/(KTRUE-1)
          ELSE
            WM=(0.D0,0.D0)
            K23=K22+K21/Z
            DO J = 1,100
              Y0=-.05D0/K23
              Z=Z+Y0*2.D0
              WM=WM+YM*Y0
              K23=K22+K21/Z
              W0=.95D0/(1.D0-Y0*K23)
              YM=YM*W0
              WM=WM+YM*Y0
            ENDDO
          END IF
          AK1=AK1+WM*YP
          F12=F12+WM*WP
        END IF
      END IF
      Z=(F1+(0.D0,1.D0)*G1)*COEF(1)/(FUN3(1)*(R0**KTRUE))
      AK1=AK1*Z
      F12=F12*Z
C
      F1F2=DBLE(AK1)
      G1F2=DIMAG(AK1)
      F1G2=DBLE(F12)
      G1G2=DIMAG(F12)
C
C       WRITE(6,900)F1F2,G1F2,F1G2,G1G2
C 900   FORMAT(4F18.10)
      RETURN
      END
C**********************************************************
C
      SUBROUTINE COUL(INOUT)
C
C NRB:
C  CALCULATION OF COULOMB FUNCTIONS
C  GENERALIZED FOR MQDT CASE AND DERIVATIVES AT RTWOC.
C  DAMPING FEATURES ADDED, BASED ON TWG ORIGINAL.
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2)
C
      PARAMETER (TOLW=-1.D-6)
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
      PARAMETER (ZERO=(0.0,0.0))
      PARAMETER (ZONE=(1.0,0.0))
      PARAMETER (ZI=(0.0,1.0))
C
      LOGICAL QDT,BDD2
C
      CHARACTER ELAS*3
C
      COMMON/CQDT/R2ST(MZCHF),QDT,NQ
      COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC
      COMMON/CDEC/ARAD(MXTST),ARDEC(MZTAR),SLIN(MXTST),IRDEC,IEND
     X           ,IPAR(MZTAR),NEWAR
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/COMEGA/OMEGA(MXTST),IE,NOMWRT
      COMMON/COULSC/FS(MZPTS,MZCHF),FSP(MZCHF),FC(MZPTS,MZCHF)
     1 ,FCP(MZCHF)
      COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2
      COMMON/CPTOLD/RTWOO,KP2O
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/CEN/ETOT,MXE,NWT,NZ
      COMMON/NRBDD2/FSP2(MZCHF),FCP2(MZCHF),IFDD2
      COMMON/NRBHYB/FNUHYB,NCHCL,ICHCL(MZCHF),NCHHYB,ICHHYB(MZCHF)
      COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT
      COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN
      COMMON/NRBRCT/
     X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF)
     X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF)
     X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF)
     X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF)
     X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF)
     X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF)
     X,RMAT(MZCHF,MZCHF)
      COMMON/NRBSKP/ISKP(MZMSH),ISKP0,LINC,ELAS
      COMMON/THETAF/THFACT(MZCHF)
      COMMON/TYPE/NTYP1,NTYP2I,NTYP2OF,NTYP2OR,NMIN
      COMMON/ZCOUL/ZFS(MZPTS,MZCHF),ZFSP(MZCHF),ZFC(MZPTS,MZCHF)
     1 ,ZFCP(MZCHF),ZFKNU(MZCHF)
      COMMON/AUGER/AAUGER(MZTAR),IAUGER
      COMMON/NRBZED/TZED,LPRTSW
      common /nrbtmpac/ac1,ac2,iomit0
C
      DIMENSION FST(MZPTS)
      DIMENSION INOUT(MZCHF)
C
      BDD2=IQDT.GT.0.AND.IPERT.NE.0.AND.IRAD.EQ.0.AND.INTPQ.EQ.0
C
C NEW CODE (NPERT=1, SET VIA PERT='YES'- DEFAULT) DOES NOT SWITCH-OFF
C PERTURBATIONS. IF R2.GT.RTWO ALL SOLUTIONS ARE EVALUATED OUTWARDS
C FROM RZERO AND SUBSEQUENT CALL TO ALPHA NEGLECTS THE CONTRIBUTION
C FROM R.GT.RTWO. NRB-94
C
      TOL0=1.D-150
      IFLUG=0
      IFDD2=0
      RTEST=RTWO
      IF(NPERT.GT.0)RTEST=RTWOO
C
      PI=ACOS(-ONE)
      TPI=TWO*PI
      CONST=TPI
      IF(TZED.GT.TZERO)CONST=CONST/DBLE((NZED-NELC)**2)
      IONE=1
      IF(ELAS.EQ.'YES')IONE=0
      SQ2=SQRT(TWO)
C
C  CALCULATE OPEN-CHANNEL SOLUTIONS AT RTWO
C  AND PERFORM INWARDS INTERGATIONS TO RZERO
C  (FOR CASE OF RINF.GT.RZERO, THE REGULAR SOLUTION IS CALCULATED
C  AT RZERO USING SERIES AND INTEGRATED OUTWARDS).
C  IF R2.GT.RTWO REGULAR AND IRREGULAR SOLUTIONS ARE EVALUATED FROM
C  SERIES AT RZERO AND INTEGRATED OUTWARDS.
C
      IF(NCHOP.GT.0)THEN
        J=0
C
        DO I=1,NCHOP
          IF(IOMIT(I).EQ.0)THEN
          ICHAN=I
C
C...    CASE OF R2ST(I).LE.RTEST, PERTURBATION MAY BE USED
C
          IF(R2ST(I).LE.RTEST)THEN
C
            CALL INJWBK(EPS(I),LLCH(I),J)
C
            IF(R2ST(I).LE.RTWO)THEN
COLD             IPERT.EQ.0.AND.
              IF(               KP2.GT.1)THEN    ! KP2=1 WHEN H=0.0
                RTWOT=MAX(R2ST(I),RZERO)
                KP2T=(RTWOT-RZERO)/H +0.1*H
                KP2T=MIN(KP2T,MZPTS-1)
                IF(IRAD.GT.0)KP2T=MAX(5,KP2T)    ! NEED 2 POINTS
                KP2T=4*((KP2T-1)/4)
                RTWOT=DBLE(KP2T)*H+RZERO
                KP2T=KP2T+1
              ELSE
                RTWOT=RTWO
                KP2T=KP2
              ENDIF
C
              CALL JWBK(RTWOT,J,S(I),SP(I),C(I),CP(I))
C
              FS(KP2T,I)=S(I)
              FSP(I)=SP(I)
              FC(KP2T,I)=C(I)
              FCP(I)=CP(I)
              FSP2(I)=SP(I)
              FCP2(I)=CP(I)
            ELSE
              KP2T=(R2ST(I)-RZERO)/H+0.1*H
              KP2T=4*((KP2T-1)/4)
              RTWOT=DBLE(KP2T)*H+RZERO
              KP2T=KP2T+1
C
              CALL JWBK(RTWOT,J,S(I),SP(I),C(I),CP(I))  !RTWOO->RTWOT
C
              FS(MZPTS,I)=S(I)                          !HOLD, NOT USED?
              FC(MZPTS,I)=C(I)                          !HOLD, NOT USED?
C              RTWOT=RTWOO                              !RTWOO NOT USED FURTHER?
C              KP2T=KP2O                                !KP2O NOT USED FURTHER?
            ENDIF
C
C  INWARD INTEGRATION FROM R2(I) TO RZERO
C         (EXCEPT S WHEN RINF.GT.RZERO - OUTWARD)
C
            IF(KP2T.GT.1)THEN
              IF(RINF(I).LE.RZERO)THEN    ! 1.2*RINF(I) SLIGHTLY MORE ACCURATE
                W2=C(I)*SP(I)-CP(I)*S(I)
                IF(BDD2.AND.KP2T.GT.KP2C)THEN               !KP2T=KP2
                  CALL NUMSC(EPS(I),CCT(I),RTWOT,H,KP2T,KP2C,SP(I)
     X                      ,CP(I),I)
                  FSP2(I)=SP(I)
                  FCP2(I)=CP(I)
                  CALL NUMSC(EPS(I),CCT(I),RTWOC,H,KP2C,1,SP(I),CP(I),I)
                ELSE
                  CALL NUMSC(EPS(I),CCT(I),RTWOT,H,KP2T,1,SP(I),CP(I),I)
                ENDIF
                  S(I)=FS(1,I)
                  C(I)=FC(1,I)
                  FSP(I)=SP(I)
                  FCP(I)=CP(I)
                  INOUT(I)=0
                  W0=C(I)*SP(I)-CP(I)*S(I)
                  IF(IPRINT.GT.1.OR.ABS(W0-ONE).GT.10*AC)
     X                           WRITE(6,600)I,RINF(I),W0,W2
              ELSE
                IF(IPERT.GT.0)THEN
                  IF(LRGL2.GT.LPRTSW)IPERT=-IPERT
                  IF(IPRINT.GT.0)WRITE(6,720)
                ENDIF
C EVALUATE S                                       BY SERIES AT MIN(0.8*RINF,RZERO)
                KINF=(RZERO-0.8*RINF(I))/H
                IF(KINF.LT.0)KINF=0
                RINF0=RZERO-KINF*H
                CALL COULS(LLCH(I),EPS(I),RINF0,S(I),SP(I))
                                    INOUT(I)=1
                KINF=KINF+1
                IF(KINF.GT.1)THEN
                  IF(KINF.GT.MZPTS)THEN
                    WRITE(6,610)KINF
                    STOP 'SR.COUL: INCREASE MZPTS'
                  ENDIF
                  CALL NUMS(EPS(I),CCT(I),RINF0,H,1,KINF,S(I),SP(I),FST)
                ENDIF
                FSP(I)=SP(I)
                SS=S(I)
                SSP=SP(I)
                KPT=MIN(KP2C,KP2T)
                IF(IPERT.EQ.0)KPT=1
                IF(IPRINT.GT.1)KPT=KP2T
                IF(IRAD.GT.0)KPT=MAX(2,KPT)           !fix for F-files
                IF(BDD2.AND.KPT.GT.KP2C)THEN
                  CALL NUMS(EPS(I),CCT(I),RZERO,H,1,KP2C,SS,SSP,FST)
                  FSP2(I)=SSP
                  CALL NUMS(EPS(I),CCT(I),RTWOC,H,KP2C,KPT,SS,SSP,FST)
                ELSE
                  CALL NUMS(EPS(I),CCT(I),RZERO,H,1,KPT,SS,SSP,FST)
                  FSP2(I)=SSP
                ENDIF
                W2=C(I)*SSP-CP(I)*SS
                KPT=MIN(KPT,MZPTS)                 !CASE R2ST(I).GT.RTWO
                DO K=1,KPT
                  FS(K,I)=FST(K)
                ENDDO
C EVALUATE C
                IF(BDD2.AND.KP2T.GT.KP2C)THEN
                  CALL NUMS(EPS(I),CCT(I),RTWOT,H,KP2T,KP2C,C(I),CP(I)
     X                     ,FST)
                  FCP2(I)=CP(I)
                  CALL NUMS(EPS(I),CCT(I),RTWOC,H,KP2C,1,C(I),CP(I),FST)
                ELSE
                  FCP2(I)=CP(I)
                  CALL NUMS(EPS(I),CCT(I),RTWOT,H,KP2T,1,C(I),CP(I),FST)
                ENDIF
                W0=C(I)*FSP(I)-CP(I)*FS(1,I)
                IF(IPRINT.GT.1.OR.ABS(W0-ONE).GT.50*AC)
     X                         WRITE(6,600)-I,RINF(I),W0,W2
                FCP(I)=CP(I)
                KPT=KP2T
                IF(IPERT.EQ.0.AND.IRAD.GT.0.AND.KP2C.GT.KP2T)THEN
                  KPT=KP2C
                  CX=FST(KP2T)
                  CXP=FCP2(I)
                  CALL NUMS(EPS(I),CCT(I),RTWOT,H,KP2T,KP2C,CX,CXP,FST)
                ENDIF
                KPT=MIN(KPT,MZPTS)                 !CASE R2ST(I).GT.RTWO
                DO K=1,KPT
                  FC(K,I)=FST(K)
                ENDDO
              ENDIF
            ENDIF
C
C   OUTWARD INTEGRATION FROM R2(I) TO RTWO.
C
            IF(IPERT.NE.0.AND.KP2C.GT.KP2T)THEN     !KP2C=KP2 FOR IQDT=0
                CALL NUMSC(EPS(I),CCT(I),RTWOT,H,KP2T,KP2C,FSP2(I)
     X                                                    ,FCP2(I),I)
              W2C=FC(KP2C,I)*FSP2(I)-FCP2(I)*FS(KP2C,I)
              IF(IPRINT.GT.1.OR.ABS(W2C-ONE).GT.50*AC)
     X                       WRITE(6,601)I,R2ST(I),W2,W2C
            ENDIF
C
C...CASE OF R2ST(I).GT.RTEST, PERTURBATION CANNOT BE USED
C   NO LONGER ENTER HERE IF DEFAULT NPERT=1/PERT='YES' IS USED.
C
          ELSE
            IPERT=0
            IF(IRAD.EQ.0) THEN
              CALL SC(EPS(I),LLCH(I),RZERO,AC,
     X                FS(1,I),FSP(I),FC(1,I),FCP(I),IERR)
              S(I)=FS(1,I)
              SP(I)=FSP(I)
              C(I)=FC(1,I)
              CP(I)=FCP(I)
            ELSE
              IF(RINF(I).LT.RZERO) THEN
                CALL SC(EPS(I),LLCH(I),RZERO,AC,FS(1,I),FSP(I)
     X                 ,FC(1,I),FCP(I),IERR)
                S(I)=FS(1,I)
                C(I)=FC(1,I)
                SP(I)=FSP(I)
                CP(I)=FCP(I)
                FSP2(I)=FSP(I)
                FCP2(I)=FCP(I)
                CALL NUMSC(EPS(I),CCT(I),RZERO,H,1,KP2,FSP2(I)
     X                    ,FCP2(I),I)
                                    INOUT(I)=0
              ELSE
                WRITE(6,620)ETOT,I,R2ST(I),RTWO,I,RINF(I),RZERO,KP2
                STOP 'SR.COUL: NEED C-FUNCTION INWARD FROM RINF'
              ENDIF
            ENDIF
          ENDIF
          ENDIF
          J=J+15
        ENDDO
      ENDIF
C
C  CALCULATE MQDT SOLUTIONS AT RZERO
C
      NCHPP1=NCHOP+1
      IF(QDT.OR.IQDT.NE.0)THEN
c        ACC=AC/100
c        ACC=MAX(ACC,1.D-10)
c        TEST=1.D-4
                 acc=ac1
                 test=ac2
        IOMSW0=IOMSW
        IOMSW=MOD(IOMSW,10)
        NQQ=NQ
        IF(IQDT.GT.0)NQQ=NCHF
        IF(IOMSW.LT.0)THEN
          NCHPP1=1
          NQQ=NCHCL
        ENDIF
C
        DO 1000 I0=NCHPP1,NQQ
          I=I0
          IF(IOMSW.LT.0)I=ICHCL(I0)
          IF(IOMIT(I).NE.0)GO TO 1000
C
          ICHAN=I
          THFACT(I)=PI*FKNU(I)**3/TWO
C
          IF(IOMSW0.NE.IOMSW)THEN
            IFLEG0=IFLEG
            IFLEG=1
          ENDIF
C
          CALL SC(EPS(I),LLCH(I),RZERO,ACc,S(I),SP(I),C(I),CP(I),IERR)
C
c          write(6,*)'ichan=',i,'iomit=',iomit(i),'ierr=',ierr
          IF(IOMSW0.EQ.IOMSW)IERR=0
C
          IF(IERR.GT.0)THEN     !NOT CONVERGED, MOVE IN & TRY AGAIN
c            w0=c(i)*sp(i)-s(i)*cp(i)
c            write(76,*)ie,ierr,i,llch(i),iomit(i),w0
            IF(RINF(I).EQ.TZERO.OR.TZED.EQ.TZERO)THEN
              RSTART=RZERO*.8
            ELSEIF(LLCH(I).EQ.0)THEN
              RSTART=RZERO/2
            ELSE
              RSTART=MIN(1.2*RINF(I),0.8*RZERO)         !1.2 for c-func
            ENDIF
c            rstart=max(rstart,h)
 105        X=1.D0/RSTART
            WH=ABS(EPS(I)+X*(2.D0*TZED-CCT(I)*X))
            IF(RINF(I).EQ.TZERO)WH=WH/16.D0
            H0=ACNUM/SQRT(WH-TOLW)
            if(kp2.gt.1)H0=MIN(H,H0)                    !else h=0
            H0=H0/2
            KSTART=(RZERO-RSTART)/H0
c            write(*,*)i,llch(i),h,h0,wh,kstart
            if(kstart.lt.6)then             !stop rstart being increased
              kstart=6
              h0=(rzero-rstart)/kstart
            endif
            RSTART=RZERO-KSTART*H0
            KSTART=KSTART+1
            IOMIT(I)=0
            IFLEG=IFLEG0
C
           CALL SC(EPS(I),LLCH(I),RSTART,ACc,S(I),SP(I),C(I),CP(I),IERR)
C
C            IF(IERR.EQ.0)THEN       !STRICT
            IF(IOMIT(I).LE.0)THEN   !THIS ALLOWS USE OF NEARLY CONVERGED
              CALL NUMS(EPS(I),CCT(I),RSTART,H0,1,KSTART,S(I),SP(I),FST)
              CALL NUMS(EPS(I),CCT(I),RSTART,H0,1,KSTART,C(I),CP(I),FST)
c
              W=C(I)*SP(I)-S(I)*CP(I)
              IF(ABS(W-ONE).GT.TEST)                          !then
     x           IOMIT(I)=1
c                 write(76,*)ie,ierr,i,llch(i),iomit(i),w0,w
c              endif
              IF(IPRINT.GT.1)WRITE(6,631)IE,I,LLCH(I),FKNU(I),rstart,W
c            else
c              write(76,*)-ie,ierr,i,llch(i),iomit(i),w0,w
            ENDIF
c allow for big box (l=0) - adjust rzero/n to loop as often as sensible
            if(iomit(i).gt.0.and.llch(i).eq.0.and.rstart.gt.rzero/3)then
              rstart=rstart/2
              go to 105
            endif
          ENDIF
C
c          write(6,*)'ichan=',i,'iomit=',iomit(i),'ierr=',ierr
          IF(IOMIT(I).GT.0)GO TO 1000
          FS(1,I)=S(I)
          FC(1,I)=C(I)
          FSP(I)=SP(I)
          FCP(I)=CP(I)
          FSP2(I)=SP(I)
          FCP2(I)=CP(I)
c          IF(IOMIT(I).GT.0)GO TO 1000
C
          INOUT(I)=0
          IF(KP2.GT.1)THEN
            KINF=(0.6*RINF(I)-RZERO)/H
            IF(KINF.GE.KP2)RINF(I)=-RINF(I)
            IF(IOMIT(I).LE.0.AND.RINF(I).GT.TZERO)THEN
              IF(KINF.LT.0)KINF=0
              RINF0=RZERO+KINF*H
              KINF=KINF+1
              IF(KINF.GT.1)THEN
                CALL NUMS(EPS(I),CCT(I),RZERO,H,1,KINF,S(I),SP(I),FST)
                DO K=1,KINF
                  FS(K,I)=FST(K)
                ENDDO
                CALL SC(EPS(I),LLCH(I),RINF0,ACc,S(I),SP(I),C(I),CP(I)
     X                 ,IERR)
                CP0=CP(I)
                CALL NUMS(EPS(I),CCT(I),RINF0,H,KINF,1,C(I),CP(I),FST)
                FCP(I)=CP(I)
                CP(I)=CP0
                DO K=1,KINF
                  FC(K,I)=FST(K)
                ENDDO
              ENDIF
              IF(INTPQ.EQ.0)THEN
                IFLGW=0
                IF(BDD2.AND.KP2.GT.KP2C)THEN
                  IFLGW=1
                  CALL NUMSC(EPS(I),CCT(I),RINF0,H,KINF,KP2C,SP(I)
     X                      ,CP(I),I)
                    FSP2(I)=SP(I)
                    FCP2(I)=CP(I)
                  CALL NUMSC(EPS(I),CCT(I),RTWOC,H,KP2C,KP2,SP(I)
     X                      ,CP(I),I)
                ENDIF
                IF(IRAD.GT.0.OR.BDD2.AND.KP2.EQ.KP2C)THEN
                  IFLGW=1
                  CALL NUMSC(EPS(I),CCT(I),RINF0,H,KINF,KP2,SP(I)
     X                      ,CP(I),I)
                  IF(KP2C.GT.1)THEN
                    FSP2(I)=SP(I)
                    FCP2(I)=CP(I)
                  ENDIF
                ENDIF
                W0=FC(1,I)*FSP(I)-FS(1,I)*FCP(I)
                W2=W0
                IF(IFLGW.GT.0)W2=FC(KP2C,I)*FSP2(I)-FS(KP2C,I)*FCP2(I)
                IF(IPRINT.GT.1)WRITE(6,600)I,RINF(I),W0,W2
                IF(ABS(W0-W2).GT.TEST)RINF(I)=-RINF(I)
              ENDIF
            ENDIF
            S(I)=FS(1,I)
            SP(I)=FSP(I)
            C(I)=FC(1,I)
            CP(I)=FCP(I)
          ENDIF
          IF(RINF(I).GT.RZERO.AND.LRGL2.GT.LPRTSW)IPERT=-IABS(IPERT)
 1000   ENDDO
                 if(iomit0.gt.0)iomit(iomit0)=1
        IOMSW=IOMSW0
      ENDIF
C
C  CALCULATE CLOSED CHANNEL SOLUTIONS AT RTWO
C  AND PERFORM INWARDS INTEGRATIONS TO RZERO.
C  CASE R2.GT.RTWO EVALUATE THETA, THETADOT AT RZERO AND
C  INTEGRATE OUTWARDS.
C
      NCHFF=NCHF
      IF(INTPQ.EQ.0)NCHPP1=NCHOP1
      IF(IOMSW.LT.0)THEN
        NCHPP1=1
        NCHFF=NCHHYB
      ENDIF
C
      ITARGN=0
      DO I0=NCHPP1,NCHFF
        I=I0
        IF(IOMSW.LT.0)I=ICHHYB(I0)
        IF(IOMIT(I).EQ.0)THEN
        ICHAN=I
        IF(INTPQ.EQ.0)THFACT(I)=ONE
C
C     ARDEC=2*PI*GAMMA/Z**2, WHERE GAMMA IS IN ATOMIC UNITS
C     CONVERT TO Z-SCALED RYDBERG UNITS BY DIVIDING BY PI
C     MODIFY ECORE --> ECORE - I*GAMMA/2.
C     ABS(E) = ECORE - ETOT --> ABS(E) -I*GAMMA/2.
C
        IF(IRDEC.GT.0.AND.INTPQ.EQ.0)THEN
C
C RADIATIVE DECAYS; RECALCULATE ARDEC (DEPENDS ON ETOT) IF NECESS.
C
          IF(NEWAR.GT.0.AND.ITARG(I).NE.ITARGN)THEN
            ITARGN=ITARG(I)
            KVEC=((ITARG(I)-IONE)*(ITARG(I)-1-IONE))/2
            ARDEC(ITARG(I))=TZERO
            DO JLOOP=1,ITARG(I)-1
              KVEC=KVEC+1
              IF(ETOT-(ENAT(ITARG(I))-ENAT(JLOOP)).LE.ENAT(1))THEN
                ARDEC(ITARG(I))=ARDEC(ITARG(I))+ARAD(KVEC)
              ENDIF
            ENDDO
            ARDEC(ITARG(I))=ARDEC(ITARG(I))*CONST
            IF(IPRINT.GT.2)THEN
              WRITE(6,612) ITARG(I),ARDEC(ITARG(I))
            ENDIF
          ENDIF
          GAMMA=ARDEC(ITARG(I))/PI
          IF(IAUGER.GT.0)GAMMA=GAMMA+AAUGER(ITARG(I))*TWO
        ELSE
          GAMMA=TZERO
        ENDIF
C
        IF(NTYP1.EQ.0)GAMMA=TZERO
        EEE=ONE/FKNU(I)**2
        ZE=-EEE*ZONE+GAMMA*ZI/TWO
        ZFKNU(I)=ZONE/SQRT(-ZE)
C
C...  CASE OF R2ST(I).LE.RTEST, PERTURBATION MAY BE USED
C
        IF(R2ST(I).LE.RTEST)THEN
          IF(R2ST(I).LE.RTWO)THEN
            KP2T=KP2
            RTWOT=RTWO
  205       CALL THETA(RTWOT,I,T,TP,TD,TDP,ICONV)
C
            FS(KP2T,I)=T
            FC(KP2T,I)=TD
C
C CHECK FUNCTION NOT TOO SMALL FOR NUMT
C
            IF(ABS(T).LT.TOL0.OR.ABS(TD).LT.TOL0)THEN
              IFLUG=1
              KP2T=KP2T-4
              IF(KP2T.LT.1)KP2T=1
              RTWOT=(KP2T-1)*H+RZERO
C             IF(KP2T.LT.KP0)STOP 'SR.COUL: KP2T .LT. KP0'
              DO K=KP2T,KP2T+4
                FS(K,I)=TZERO
                FC(K,I)=TZERO
              ENDDO
              IF(KP2T.EQ.1)GO TO 207
              GO TO 205
            ENDIF
C
  207       IF(IPRINT.GT.1.AND.KP2T.LT.KP2)WRITE(6,735)I,RTWOT,RTWO
            FSP(I)=TP
            FCP(I)=TDP
            KRA=KP2T
            KRB=KP0                  !1
            TKRA=RTWOT
            KINF=1
            RINF0=RZERO
            IF(KP2T.LT.KP2)THEN
              DO K=KP2T,KP2
                ZFS(K,I)=ZERO
                ZFC(K,I)=ZERO
              ENDDO
            ENDIF
C
            IF(INTPQ.EQ.0)CALL ZTHETA(RTWOT,I,ZFS(KP2T,I),ZFSP(I)
     X                      ,ZFC(KP2T,I),ZFCP(I),ICONV,EEE,GAMMA)
C
          ELSE
            KINF=0
            IF(IPERT.NE.0)THEN
              KINF=(0.6*RINF(I)-RZERO)/H
              IF(KINF.GE.KP2)THEN
                RINF(I)=-RINF(I)
                KINF=0
              ENDIF
              IF(KINF.LT.0)KINF=0
            ENDIF
            RINF0=RZERO+KINF*H
            KINF=KINF+1
          ENDIF
C
          IF(R2ST(I).GT.RTWO.OR.RINF(I).GT.RZERO.AND.IPRINT.GT.0)THEN
C
C ASSUME SD=0=CD. (W(C,S)=1=-W(S,C) IN SR.SC)
C
            CALL SC(EPS(I),LLCH(I),RINF0,AC,FSA,FSPA,FCA,FCPA,IERR)
C
            IF(KINF.GT.1.AND.IOMIT(I).GT.0)THEN
              IOMIT(I)=0
              CALL SC(EPS(I),LLCH(I),RZERO,AC,FSA,FSPA,FCA,FCPA,IERR)
              KINF=1
              RINF0=RZERO
              RINF(I)=-RINF(I)
            ENDIF
C
            SINF=SIN(PI*FKNU(I))
            COSF=COS(PI*FKNU(I))
            T=FCA*SINF-FSA*COSF
            TP=FCPA*SINF-FSPA*COSF
            IF(TP.NE.TZERO)SSP0=T/TP
C
C RE-NORMALISED ENERGY DENSITY
C
C             W(T,TD)=1
            TD=SINF*FSA+COSF*FCA
            TDP=SINF*FSPA+COSF*FCPA
C
C             W(T,TD)=2/PI*NU**3
C           TD=TD*1.570796327*FKNU(I)**3
C           TDP=TDP*1.570796327*FKNU(I)**3
C
            IF(R2ST(I).GT.RTWO)THEN
              KRA=KINF
              KRB=KP2
              TKRA=RINF0
              ICONV=0
              FS(KRA,I)=T
              FSP(I)=TP
              FC(KRA,I)=TD
              FCP(I)=TDP
C
C AND NOW COMPLEX VERSION
C
              XNUI=DIMAG(ZFKNU(I))
              IF(XNUI .LT. 3.)THEN
                ZSINF=SIN(PI*ZFKNU(I))
                ZCOSF=COS(PI*ZFKNU(I))
                ZFS(KRA,I)=FCA*ZSINF-FSA*ZCOSF
                ZFSP(I)=FCPA*ZSINF-FSPA*ZCOSF
                ZFC(KRA,I)=ZSINF*FSA+ZCOSF*FCA
                ZFCP(I)=ZSINF*FSPA+ZCOSF*FCPA
              ELSE
C
C IMAGINARY PART OF PI*NU IS LARGE, SO REDEFINE SOLUTIONS
C
                FACT=ONE/SQ2
                ZFS(KRA,I)=FACT*(ZI*FCA-FSA)
                ZFSP(I)=FACT*(ZI*FCPA-FSPA)
                ZFC(KRA,I)=FACT*(FCA-ZI*FSA)
                ZFCP(I)=FACT*(FCPA-ZI*FSPA)
              ENDIF
            ENDIF
CNRB
          ENDIF
          IF(ICONV.EQ.0)THEN
            IF(RINF(I).GE.TZERO.AND.IOMIT(I).LE.0)THEN
              IF(KRA.GT.KRB.OR.IPERT.NE.0.OR.IRAD.GT.0)THEN
                CALL NUMT(EPS(I),CCT(I),TKRA,H,KRA,KRB,I)
                IF(INTPQ.EQ.0)CALL ZNUMT(ZE,CCT(I),TKRA,H,KRA,KRB,I)
              ENDIF
                          IF(KRA.GT.KRB)INOUT(I)=0
                          IF(KRA.LE.KRB)INOUT(I)=1
              IF(KINF.GT.1)THEN
                CALL NUMT(EPS(I),CCT(I),TKRA,H,KINF,-1,I)
                IF(INTPQ.EQ.0)CALL ZNUMT(ZE,CCT(I),TKRA,H,KINF,-1,I)
              ENDIF
              IF(IPRINT.GT.0.AND.RINF(I).GT.RZERO.AND.R2ST(I).LE.RTWO)
     X                                                           THEN
                SSP2=FS(1,I)/FSP(I)
                IF(ABS((SSP0-SSP2)/SSP2).GT.100*AC)THEN
                  WRITE(6,640)I,RINF(I),SSP0,SSP2
                ENDIF
              ENDIF
            ENDIF
          ELSE
            IPERT=0
            IF(IRAD.GT.0) THEN
              WRITE(6,630)ETOT,I,LLCH(I),FKNU(I)
              STOP 630
            ENDIF
          ENDIF
C
C...  CASE OF R2ST(I).GT.RTEST, PERTUBATION CANNOT BE USED
C   NO LONGER ENTER HERE IF DEFAULT NPERT=1/PERT='YES' IS USED.
C
        ELSE
          IPERT=0
          CALL SC(EPS(I),LLCH(I),RZERO,AC,FSA,FSPA,FCA,FCPA,IERR)
          SINF=SIN(PI*FKNU(I))
          COSF=COS(PI*FKNU(I))
          FS(1,I)=FCA*SINF-FSA*COSF
          FSP(I)=FCPA*SINF-FSPA*COSF
          XNUI=DIMAG(ZFKNU(I))
          IF(XNUI .LT. 3.)THEN
            ZSINF=SIN(PI*ZFKNU(I))
            ZCOSF=COS(PI*ZFKNU(I))
            ZFS(1,I)=FCA*ZSINF-FSA*ZCOSF
            ZFSP(I)=FCPA*ZSINF-FSPA*ZCOSF
          ELSE
            FACT=ONE/SQ2
            ZFS(1,I)=FACT*(ZI*FCA-FSA)
            ZFSP(I)=FACT*(ZI*FCPA-FSPA)
          ENDIF
          IF(IRAD.GT.0) THEN
            SS=FS(1,I)
            SSP=FSP(I)
            CALL NUMS(EPS(I),CCT(I),RZERO,H,1,KP2,SS,SSP,FST)
                                    INOUT(I)=1
            DO K=1,KP2
              FS(K,I)=FST(K)
            ENDDO
          ENDIF
        ENDIF
        IF(RINF(I).GT.RZERO.AND.LRGL2.GT.LPRTSW)IPERT=-IABS(IPERT)
        ENDIF
      ENDDO
C
      IF(IFLUG.GT.0.AND.IPRINT.GT.1)WRITE(6,730)
C
      IF(IPRINT.GT.1)THEN
        WRITE(6,701)ETOT
        WRITE(6,705)RTWO,KP2,H
        WRITE(6,700)
        IMAX=1
c        imax=kp2
        DO J=1,NCHF
          DO I=1,IMAX
            WRITE(6,710)J,I,FS(I,J),FSP(J),FC(I,J),FCP(J)
          ENDDO
        ENDDO
      ENDIF
C
C
      IF(IPRTSW.GT.0)IPERT=IABS(IPERT)
      IF(IPRTSW.LT.0)IPERT=-IABS(IPERT)
C
      RETURN
C
  600 FORMAT(23X,' I =',I4,', RINF =',F7.2,', W0 =',F9.6,
     +  ', W2 =',F9.6/)
  601 FORMAT(23X,' I =',I4,', R2(I)=',F7.2,', W2 =',F9.6,
     +  ', W2C=',F9.6/)
  610 FORMAT('SR.COUL: INCREASE MZPTS TO ',I6)
  612 FORMAT(I15,1PE20.4)
  620 FORMAT(///10X,30('*')//10X,'FOR ETOT = ',E14.6/
     + 10X,'(R2ST(',I2,')=',F8.2,').GT.(RTWO = ',F8.2,')  AND'/
     + 10X,'(RINF(',I2,') = ',F8.2,').GT.(RZERO=',F8.2,')'/
     + 10X,'KP2 = ',I4,/
     + 10X,'CANNOT CALCULATE RADIATIVE DATA FOR THIS CASE'/
     + 10X,'TRY LARGER VALUE OF MZPTS'///)
  630 FORMAT(///10X,30('*')//10X,'FOR ETOT = ',E14.6/
     + 10X,'CHANNEL ',I2,' HAS'/
     + 10X,'CHANNEL ANGULAR MOMENTUM QUANTUM NUMBER = ',I2/
     + 10X,'CHANNEL EFFECTIVE QUANTUM NUMBER = ',F8.2/
     + 10X,'CANNOT CALCULATE RADIATIVE DATA FOR THIS CASE.'
     + /10X,'TRY SMALLER VALUE OF QNMAX OR LARGER'
     +, ' VALUE OF MZTET'///)
  631 FORMAT(/5X,'SUBROUTINE COUL, IE=',I5,'  ICHAN=',I4,'  LL = ',I2,
     +   '  FNU = ', F10.2,'  RHO = ',1PE10.3,'  W = ',0PF10.6)
  640 FORMAT(' ***WARNING: POSSIBLE INACCURACY IN SR.THETA, RINF'
     X,' EXCEEDS RZERO FOR CHANNEL'/
     X 3X,' I =',I3,', RINF =',F7.2,', AT R0 S/SP(SC) =',1PE13.6,
     +  ', S/SP(THETA) =',1PE13.6/)
  700 FORMAT(//10X,'COULOMB FUNCTIONS S,SP,C AND CP'/)
  701 FORMAT(//10X,' E = ',F10.6/11X,14('-'))
  705 FORMAT(//'   RTWO = ',1PE12.4,',  KP2 = ',I4,',  H = ',0PF10.6)
  710 FORMAT(2I5,4E15.6)
  720 FORMAT(5X,5('*'),' REGULAR COULOMB FUNCTION FROM SERIES ',5('*')/)
  730 FORMAT(3X,'I',3X,'RTWOT',8X,'RTWO')
  735 FORMAT(I5,2F10.4)
C
      END
C
C**********************************************************
C
      SUBROUTINE COULFG(LL,EPS,RHO,ACC,F,FP,G,GP,K,IERR,ACTACC)
c     + absf,absg)
C
C  CALCULATES COULOMB FUNCTIONS F AND G AND THEIR DERIVATIVES
C
C  ORIGINAL VERSION PUBLISHED IN COMP. PHYS. COMM.25, 87, 1982.
C  PRESENT VERSION MODIFIED TO AVOID UNDERFLOW AND OVERFLOW
C  CONDITIONS IN THE SUMMATIONS OVER N OF
C         U(N)=A(N)*RHO**(N+L+1)
C     AND V(N)=D(N)*RHO**(N+L+1)
C  U(N) AND V(N) ARE CALCULATED RECURSIVELY.
C
C
C  INPUT -
C        LL=ANGULAR MOMENTUM QUANTUM NUMBER
C        EPS=Z-SCALED ENERGY IN RYDBERGS
C        RHO=Z-SCALED RADIAL VARIABLE IN ATOMIC UNITS
C        ACC=ACCURACY REQUIRED
C
C  OUTPUT -
C        F=REGULAR FUNCTION
C        FP=DERIVATIVE OF F
C        G=IRREGULAR FUNCTION
C        GP=DERIVATIVE OF G
C        K=NUMBER OF TERMS NEEDED IN EXPANSION
C        IERR=ERROR CODE
C        ACTACC=ACCURACY ACTUALLY ACHIEVED
C
C  CONVERGENCE CRITERION -
C        VALUE OF WRONSKIAN CONVERGED TO ACCURACY OF 0.5*ACC
C
C  ERROR CODES -
C        IERR=0, CONVERGED WITH ACTACC.LT.ACC
C        IERR=1, CONVERGED WITH ACTACC.GT.ACC
C        IERR=2, NOT CONVERGED WITH 301 TERMS IN MAIN SUMMATION
C        IERR=3, NOT CONVERGED - DANGER OF OVERFLOW
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DOUBLE PRECISION DUBU0,DUBU1,DUBU2,DUBV0,DUBV1,DUBV2,
     +  DUBQ1,DUBF,DUBFP,DUBS,DUBSP,DA4,DP2,DREPS,DFNPLP,DRHO,DP1,DCLP
     + ,W1D,W2D,DDW1,DDW2,DONE,DTWO
c    + ,dabsf,dabsg
C
CNRB:
C     DO NOT USE ANYTHING LESS THAN *8 ANYWHERE. IF POSSIBLE, USE
C     EXPLICIT *16 FOR LARGE CASES, ESPECIALLY ON A CRAY.
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
      PARAMETER (FOUR=4.0)
C
C  INITIALIZATION
C
      PI=ACOS(-ONE)
      EULER=-0.577215664901532860606512D0      !INELEGANT
      R2PI=ONE/(TWO*PI)
      PS0=ONE+TWO*EULER
C
      IERR=0
      LP1=LL+1
      L2=2*LL
      L2P1=L2+1
      FL=LL
      FLP1=LP1
      FL2P1=L2P1
      E2=EPS/TWO
      R2=TWO*RHO
      ACC2=TWO*ACC
C
C     INITIALIZE FA=FACTORIAL(2*LL+1)
C     AND PS=PSI(2*LL+2)+PSI(1)
C
      FA=ONE
      PS=PS0
C
C
C  CALCULATE ALPHA(N) AND BETA(N) AND INITIALIZE S AND SP
C  CONTINUE CALCULATION OF FA AND PS
C
C     S AND SP FOR N=0
      X3=-L2
      X2=L2P1
      X1=-TWO*R2**(-LP1)
      SP=X3*X1
      X1=R2*X1
      S=X1
c                absg=abs(x1)
C
C     INITIALIZE FOR COEFFICIENTS IN RECURSION FORMULAE
      P1=FL*E2
      P2=P1
      Q1=-E2
C
C     INITIALIZE ALPHA AND BETA
      ALP1=ONE
      ALP2=ONE+P2
      BET1=TZERO
      BET2=Q1
C
      IF(LL.EQ.0)GOTO 20
C
C     S AND SP FOR N=1
      X3=X3+TWO
      X2=X2-ONE
      X1=X1/X2
      SP=SP+X3*X1
      X1=R2*X1
      S=S+X1
c               absg=absg+abs(x1)
C
C     LOOP FOR N=2 TO 2*LL
      DO 10 N=2,L2
C
C     CONTINUE CALCULATION OF FA AND PSI
      FN=N
      FA=FN*FA
      PS=PS+ONE/FN
C
C     CONTINUE CALCULATION OF S AND SP
      X3=X3+TWO
      X2=X2-ONE
      X1=X1/(X2*FN)
      SP=SP+X3*X1*ALP2
      X1=R2*X1
      S=S+X1*ALP2
c                absg=absg+abs(x1*alp2)
C
C     COMPUTE COEFFICIENTS IN RECURSION FORMULAE
      P1=P1-E2
      P2=P2+P1
      Q1=Q1-E2
C     NOW HAVE P2=-N*(N-2*LL-1)*EPS/4
C     AND Q1=-N*EPS/2
C
C     NEW ALPHA AND BETA
      ALP0=ALP1
      ALP1=ALP2
      ALP2=ALP1+P2*ALP0
      BET0=BET1
      BET1=BET2
      BET2=BET1+P2*BET0+Q1*ALP0
  10  CONTINUE
C
C     NORMALIZE S AND SP, COMPLETE CALCULATION OF FA AND PS
      S=S*FA
      SP=SP*FA
c                absg=absg*abs(fa)
      FA=FL2P1*FA
      PS=PS+ONE/FL2P1
C
C     COMPLETE CALCULATION OF ALPHA AND BETA
      P1=P1-E2
      P2=P2+P1
      Q1=Q1-E2
      ALP0=ALP1
      ALP1=ALP2
      BET0=BET1
      BET1=BET2
      BET2=BET1+P2*BET0+Q1*ALP0
C
   20 CONTINUE
C     NOW HAVE ALP1=ALPHA(2*LL+1)
C     AND BET1=BETA(2*LL+1), BET2=BETA(2*LL+2)
C
C     VALUE OF A=A(EPS,LL)
      A=ALP1
      A4=FOUR*A
      CL=TWO*A*LOG(ABS(R2))
      CLP=TWO*A/RHO
C
C  CALCULATE F AND FP AND CONTINUE CALCULATION OF S AND SP
C
C     CALCULATE A0,A1,D0,D1
      A0=(TWO**LP1)/FA
      A1=-A0/FLP1
      PS=TWO*PS*A
      D0=(BET1-PS)*A0
      D1=(BET2-PS-(TWO+ONE/FLP1)*A)*A1
C
C     INITIALIZE F,FP, CONTINUE CALCULATION OF S,SP
C          -VALUES FOR N=0
C           U0 AND V0
      FNPLP1=FLP1
      C1=RHO**LL
      U0=A0*C1
      V0=D0*C1
      FP=FNPLP1*U0
      SP=SP+FNPLP1*V0
      U0=U0*RHO
      V0=V0*RHO
      F=U0
c                absf=abs(f)
      S=S+V0
c                absg=abs(v0)      +absg
      W1D=F*(CLP*F+SP)-FP*S
      NNN=0
C
C          - VALUES FOR N=1
C            U1 AND V1
      FNPLP1=FNPLP1+ONE
      C1=C1*RHO
      U1=A1*C1
      V1=D1*C1
      FP=FP+FNPLP1*U1
      SP=SP+FNPLP1*V1
      U1=U1*RHO
      V1=V1*RHO
      F=F+U1
c                absf=absf+abs(u1)
      S=S+V1
c                absg=absg+abs(v1)
      W2D=F*(CLP*F+SP)-FP*S
      DDW2=ABS(W2D-W1D)
C
C     INITIALIZE FOR COEFFICIENTS IN RECURSION FORMULAE
      P1=-TWO*FLP1
      P2=P1
      Q1=A4+TWO*A*FL2P1
      REPS=RHO*EPS
C
C  CONVERT TO DOUBLE
                            DONE=1
                            DTWO=2
                          DUBU0=U0
                          DUBU1=U1
                          DUBV0=V0
                          DUBV1=V1
                          DUBQ1=Q1
                          DUBS=S
                          DUBSP=SP
                          DUBF=F
                          DUBFP=FP
c           dabsf=absf
c           dabsg=absg
                     DA4=A4
                     DP2=P2
                     DREPS=REPS
                     DFNPLP=FNPLP1
                     DRHO=RHO
                     DP1=P1
                     DCLP=CLP
C                  W1D=W1
C                  W2D=W2
C                  DDW1=DW1
C                  DDW2=DW2
C     LOOP FOR N=2 TO 300
      DO 40 N=2,300
C
C     COMPUTE COEFFICIENTS IN RECURSION FORMULAE
      DP1=DP1-DTWO
      DP2=DP2+DP1
      DUBQ1=DUBQ1+DA4
C     NOW HAVE P2=-N*(N+2*LL+1)
C     AND DUBQ1=2*A*(2*N+2*LL+1)
C
C      COMPUTE DUBU2=U(N) AND DUBV2=V(N)
      DUBU2=(DTWO*DUBU1+DREPS*DUBU0)/DP2
      DUBV2=(DTWO*DUBV1+DREPS*DUBV0+DUBQ1*DUBU2)/DP2
C
C     INCREMENT DUBFP AND DUBSP
      DFNPLP=DFNPLP+DONE
      DUBFP=DUBFP+DFNPLP*DUBU2
      DUBSP=DUBSP+DFNPLP*DUBV2
C
C     INCREMENT DUBF AND DUBS
      DUBU2=DUBU2*DRHO
      DUBV2=DUBV2*DRHO
      DUBF=DUBF+DUBU2
c                dabsf=dabsf+abs(dubu2)
      DUBS=DUBS+DUBV2
c                dabsg=dabsg+abs(dubv2)
C
C     CALCULATE WRONSKIAN
      W1D=W2D
      DDW1=DDW2
      W2D=DUBF*(DCLP*DUBF+DUBSP)-DUBFP*DUBS
      DDW2=ABS(W2D-W1D)
C
C     CONVERGENCE TEST
      K=N+1
      IF(DDW1.GT.ACC2)GOTO 30
      IF(DDW2.GT.ACC2)GOTO 30
      IF(ABS(W2D).LT.1.E10)GOTO 50
C
C TEST FOR OVERFLOW
   30 IF(ABS(DUBS)+ABS(DUBSP)+ABS(DUBF)+ABS(DUBFP).GT.1.D100)THEN
      IERR=3
      RETURN
      ENDIF
C  NEW DUBU0,DUBU1,DUBV0,DUBV1
      DUBU0=DUBU1
      DUBU1=DUBU2
      DUBV0=DUBV1
      DUBV1=DUBV2
C
   40 CONTINUE
C
C  NOT CONVERGED
C
      IERR=2
      ACTACC=ABS(0.25*W2D-1.)
      GOTO 60
C
C  CONVERGED
C
   50 ACTACC=ABS(0.25*W2D-1.)
      IF(ACTACC.GT.ACC)IERR=1
C
C  COMPLETE CALCULATION OF G AND GP
C
   60                    S=DUBS
                         SP=DUBSP
                         F=DUBF
                         FP=DUBFP
c                         absf=dabsf
c                         absg=dabsg
c                         absg=absg*r2pi
      G=(S+CL*F)*R2PI
      GP=(SP+CL*FP+CLP*F)*R2PI
C
      RETURN
C
      END
C**********************************************************
C
      SUBROUTINE COULS(LL,EPS,RHO,S,SP)
C
C  CALCULATES COULOMB FUNCTION S AND ITS DERIVATIVE SP
C  FROM POWER-SERIES EXPANSION.
C NRB
C  NEUTRAL CASE ADDED
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DOUBLE PRECISION C1,D0,D1,D2,DM,DEPS,DRHO,F,FLP1,FNPLP1,FP,
     +  P1,P2,REPS,U0,U1,U2,UM, A,B,C, T0,DZ
C
CNRB:
C     DO NOT USE ANYTHING LESS THAN *8 ANYWHERE. IF POSSIBLE, USE
C     EXPLICIT *16 FOR LARGE CASES, ESPECIALLY ON A CRAY.
C
      LOGICAL T(0:2),TP(0:2)
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
C
      COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/NRBZED/TZED,LPRTSW
C
C  INITIALISATIONS
C
      TPI=TWO*ACOS(-ONE)
      DRHO=RHO
      DEPS=EPS
      DZ=TZED
      FLP1=LL+1
      ACC10=.1*AC
      DO I=0,1
      T(I)=.FALSE.
      TP(I)=.FALSE.
      ENDDO
      T0=ONE
      NSUM=200
      IF(TZED.EQ.0)THEN
        IF(DEPS.LT.0)THEN
          WRITE(6,*)
     X 'ERROR: SR.COULS IS NOT CODED FOR NEGATIVE ENERGY NEUTRALS'
          STOP'SR.COULS IS NOT CODED FOR NEGATIVE ENERGY NEUTRALS'
        ENDIF
        T0=SQRT(SQRT(DEPS))
        NSUM=400
      ENDIF
C
C  POWER-SERIES EXPANSION
C  **********************
C
C   VALUES FOR N=0
      FNPLP1=FLP1
      C1=T0*DRHO**LL
      U0=C1
      D0=FNPLP1*U0
      DM=ABS(D0)
      FP=D0
      U0=U0*DRHO
      UM=ABS(U0)
      F=U0
C
C   VALUES FOR N=1
      FNPLP1=FNPLP1+ONE
      C1=C1*DRHO
      U1=-C1*DZ/FLP1
      D1=FNPLP1*U1
      DM=MAX(ABS(D1),DM)
      FP=FP+D1
      U1=U1*DRHO
      UM=MAX(ABS(U1),UM)
      F=F+U1
C
C   INITIALIZE FOR COEFFICIENTS IN RECURSION FORMULAE
      P1=-TWO*FLP1
      P2=P1
      REPS=DRHO*DEPS
C
C   LOOP FOR N=2 TO 200
      DO 40 N=2,NSUM
C     COMPUTE COEFFICIENTS IN RECURSION FORMULAE
      P1=P1-TWO
      P2=P2+P1
C     NOW HAVE P2=-N*(N+2*LL+1)
C     COMPUTE U2 AND INCREMENT FP
      FNPLP1=FNPLP1+ONE
      U2=(TWO*DZ*U1+REPS*U0)/P2
      D2=FNPLP1*U2
      DM=MAX(ABS(D2),DM)
      FP=FP+D2
C     MODIFY U2 AND INCREMENT F
      U2=U2*DRHO
      UM=MAX(ABS(U2),UM)
      F=F+U2
c        write(67,*)n,f,u2,fp,d2
C     TEST CONVERGENCE
      IF(ABS(U2).LT.ABS(F)*ACC10)THEN
        T(2)=.TRUE.
      ELSE
        T(2)=.FALSE.
      ENDIF
      IF(ABS(D2).LT.ABS(FP)*ACC10)THEN
        TP(2)=.TRUE.
      ELSE
        TP(2)=.FALSE.
      ENDIF
      DO I=0,2
      IF(.NOT.T(I))GOTO 21
      ENDDO
      IF(IPRINT.GT.1)THEN
        UM=UM/ABS(F)
        WRITE(6,610)LL,EPS,UM
      ENDIF
      GOTO 50
   21 DO I=0,2
      IF(.NOT.TP(I))GOTO 23
      ENDDO
      IF(IPRINT.GT.1)THEN
        DM=DM/ABS(FP)
        WRITE(6,620)LL,EPS,DM
      ENDIF
      GOTO 50
C     NEW U0,U1,T AND TP
   23 U0=U1
      U1=U2
      DO I=0,1
      T(I)=T(I+1)
      TP(I)=TP(I+1)
      ENDDO
   40 CONTINUE
C
C  SERIES NOT CONVERGED
      WRITE(6,600)LL,EPS,RHO
      STOP 'COULS: SERIES NOT CONVERGED'
C
C  NORMALISATION
C  *************
C
C   NORMALISE FOR FUNCTIONS .5*F AND .5*FP
C
   50 S=F
      SP=FP
      DO K=1,LL
      C=ONE/DBLE(K*(2*K+1))
      S=S*C
      SP=SP*C
      ENDDO
C
C   CALCULATE CAP B AND FUNCTIONS S AND SP
      IF(EPS.GT.0)THEN
        A=ONE
        IF(LL.GT.0)THEN
          A1=DZ
          A2=-EPS
          A3=EPS+EPS
          DO I=1,LL
          A2=A2+A3
          A1=A1+A2
          A=A*A1
          ENDDO
        ENDIF
        IF(EPS.LT.0.01.OR.TZED.EQ.0)THEN
          B=A
        ELSE
          B=A/(ONE-EXP(-TPI/SQRT(EPS)))
        ENDIF
      C=SQRT(B)
      ELSE
      C=ONE
      ENDIF
      IF(TZED.GT.0)C=C*SQRT(TPI)
      S=S*C
      SP=SP*C
C
      RETURN
C
  600 FORMAT(//10X,60('*')//10X,'SERIES IN COULS NOT CONVERGED'
     + /10X,' LL =',I3,',  EPS =',1PE15.5,',  RHO =',
     +  E15.5//10X,60('*')//)
  610 FORMAT(/5X,'SUBROUTINE COULS, LL = ',I2,',  EPS = ',
     +  1PE12.5,',  UM = ',E10.2)
  620 FORMAT(/5X,'SUBROUTINE COULS, LL = ',I2,',  EPS = ',
     +  1PE12.5,',  DM = ',E10.2)
      END
C***************************************************************
C
      SUBROUTINE DIAG(N,IUP,Z,D,E,MXMAT)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
C BADNELL & BURGESS  D.A.M.T.P. CAMBRIDGE
C
C DIAGONALIZATION OF REAL SYMMETRIC N-BY-N MATRIX Z.
C
C METHOD: HOUSEHOLDER REDUCTION TO TRI-DIAGONAL FORM AND SHIFTED
C         QL ALGORITHM TO DETERMINE THE E-VALUES AND E-VECTORS.
C
C BASED ON MARTIN, REINSCH & WILKINSON: NUM. MATH. 11, 181-95 (1968).
C
C INPUT REQUIRED. N, IUP AND Z. ONLY LOWER TRIANGLE OF Z NEED BE SUPPLIED.
C                          MATRIX Z OVERWRITTEN BY EIGENVECTORS OF Z.
C                 IUP=1/-1 ASC/DESCENDING SORT, 0 NO SORT.
C                 MXMAT, IS THE ROW DIMENSION OF Z IN THE CALLING ROUTINE.
C
C OUTPUT.         Z AND D, WHERE Z CONSISTS OF COLUMN EIGENVECTORS
C                          AND D CONSISTS OF CORRESPONDING EIGENVALUES.
C
C NOTE: E IS A WORKING ARRAY.
C
      PARAMETER (TOL = 1.0D-75)
      PARAMETER (EPS = 1.0D-15)
      PARAMETER (ZERO = 0.0D0)
      PARAMETER (ONE = 1.0D0)
      PARAMETER (JMAX = 30)
C
      DIMENSION D(N),E(N),Z(MXMAT,N)
C
C
      DO 1 I = 1,N
      D(I) = Z(N,I)
   1  CONTINUE
      IF (N.LE.1) GO TO 20
C
C HOUSEHOLDER REDUCTION TO TRI-DIAGONAL FORM
C
      DO 19 I = N,2,-1
      L = I - 1
      F = D(I-1)
      G = ZERO
      DO 5 K = 1,I-2
      G = G + D(K)*D(K)
  5   CONTINUE
      H = G + F*F
      IF (G.GT.TOL) GO TO 8
      E(I) = F
      H = ZERO
      DO 7 J = 1,L
      D(J) = Z(L,J)
      Z(I,J) = ZERO
      Z(J,I) = ZERO
  7   CONTINUE
      GO TO 18
  8   G = SQRT(H)
      IF (F.GE.ZERO) G = -G
      E(I) = G
      H = H - F*G
      D(L) = F - G
      DO 14 J = 1,L
      E(J) = ZERO
  14  CONTINUE
      DO 15 J = 1,L
      Z(J,I) = D(J)
      G = E(J) + Z(J,J)*D(J)
      DO 13 K = J+1,L
      G = G + Z(K,J)*D(K)
      E(K) = E(K) + Z(K,J)*D(J)
  13  CONTINUE
      E(J) = G
  15  CONTINUE
      F = ZERO
      DO 12 J = 1,L
      E(J) = E(J)/H
      F = F + E(J)*D(J)
  12  CONTINUE
      HH = F/(H+H)
      DO 11 J = 1,L
      E(J) = E(J) - HH*D(J)
  11  CONTINUE
      DO 17 J = 1,L
      F = D(J)
      G = E(J)
      DO 16 K = J,L
      Z(K,J) = Z(K,J) - F*E(K) - G*D(K)
  16  CONTINUE
      D(J) = Z(L,J)
      Z(I,J) = ZERO
  17  CONTINUE
  18  D(I) = H
  19  CONTINUE
C
C
C ACCUMULATE TRANSFORMATION MATRICES
C
      DO 28 I = 2,N
      L = I - 1
      Z(N,L) = Z(L,L)
      Z(L,L) = ONE
      H = D(I)
      IF (H.EQ.ZERO) GO TO 25
      DO 21 K = 1,L
      D(K) = Z(K,I)/H
  21  CONTINUE
      DO 24 J = 1,L
      G = ZERO
      DO 22 K = 1,L
      G = G + Z(K,I)*Z(K,J)
  22  CONTINUE
      DO 23 K = 1,L
      Z(K,J) = Z(K,J) - G*D(K)
  23  CONTINUE
  24  CONTINUE
  25  DO 27 J = 1,L
      Z(J,I) = ZERO
  27  CONTINUE
  28  CONTINUE
      DO 29 I = 1,N
      D(I) = Z(N,I)
      Z(N,I) = ZERO
  29  CONTINUE
  20  E(1) = ZERO
      Z(N,N) = ONE
C
C
C SHIFTED QL ALGORITHM TO DETERMINE E-VALUES & E-VECTORS
C
      DO 32 I = 2,N
      E(I-1) = E(I)
  32  CONTINUE
      E(N) = ZERO
      B = ZERO
      F = ZERO
      DO 54 L = 1,N
      J = 0
      H = EPS*(ABS(D(L))+ABS(E(L)))
      IF (B.LT.H) B = H
      DO 36 M = L,N
      IF (ABS(E(M)).LE.B) GO TO 37
  36  CONTINUE
  37  IF (M.EQ.L) GO TO 53
  38  IF (J.EQ.JMAX) GO TO 62
      J = J+ 1
      P = E(L) + E(L)
      G = D(L)
      H = D(L+1) - G
      IF (ABS(H).GE.ABS(E(L))) GO TO 43
      P = H/P
      R = SQRT(P*P+ONE)
      H = P + R
      IF (P.LT.ZERO) H = P - R
      D(L) = E(L)/H
      GO TO 44
  43  P = P/H
      R = SQRT(P*P+ONE)
      D(L) = E(L)*P/(R+ONE)
  44  H = G - D(L)
      DO 46 I = L+1,N
      D(I) = D(I) - H
  46  CONTINUE
      F = F + H
      P = D(M)
      C = ONE
      S = ZERO
      DO 52 I = M-1,L,-1
      G = C*E(I)
      H = C*P
      IF (ABS(P).LT.ABS(E(I))) GO TO 49
      C = E(I)/P
      R = SQRT(C*C+ONE)
      E(I+1) = S*P*R
      S = C/R
      C = ONE/R
      GO TO 50
  49  C = P/E(I)
      R = SQRT(C*C+ONE)
      E(I+1) = S*E(I)*R
      S = ONE/R
      C = C/R
  50  P = C*D(I) - S*G
      D(I+1) = H + S*(C*G+S*D(I))
      DO 51 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
  51  CONTINUE
  52  CONTINUE
      E(L) = S*P
      D(L) = C*P
      IF (ABS(E(L)).GT.B) GO TO 38
  53  D(L) = D(L) + F
  54  CONTINUE
C
      IF(IUP.EQ.0)RETURN
C
C BEGIN SORTING INTO ASCENDING E-VALUES
C
      DO 61 I = 1,N
      K = I
      P = D(I)
      DO 57 J = I+1,N
      IF (IUP.GT.0.AND.D(J).GT.P) GO TO 57
      IF (IUP.LT.0.AND.D(J).LT.P) GO TO 57
      K = J
      P = D(J)
  57  CONTINUE
      IF (K.EQ.I) GO TO 61
      D(K) = D(I)
      D(I) = P
      DO 60 J = 1,N
      P = Z(J,I)
      Z(J,I) = Z(J,K)
      Z(J,K) = P
  60  CONTINUE
  61  CONTINUE
C
      RETURN
C
C
  62  WRITE(6,100)
 100  FORMAT(' FAILED IN DIAG, TOO MANY ITERATIONS')
      RETURN
C
      END
C***********************************************************************
C
       SUBROUTINE DIPOL(JSW,N1,N2,E2,LMAX,CP,CM,JC)
       IMPLICIT REAL*8 (A-H,O-Z)
C
C  ALAN BURGESS DAMTP CAMBRIDGE
C
C  CALCULATES SQUARES OF HYDROGENIC DIPOLE LENGTH RADIAL MATRIX ELEMENTS
C  FOR BOUND-BOUND OR BOUND-FREE TRANSITIONS.
C
C  BOUND STATES ARE NORMALISED TO UNITY.
C  FREE STATES ARE NORMALISED TO ASYMPTOTIC AMPLITUDE K**(-0.5).
C
C  N.B. DIPOLE ACCELERATION MATRIX ELEMENT = (E12**2/4Z) * DIPOLE LENGTH
C  WHERE E12 = - N1**(-2) + N2**(-2)  FOR BOUND-BOUND
C            = - N1**(-2) + E2        FOR BOUND-FREE
C          Z = REDUCED CHARGE
C  INPUT
C   FOR BOUND-BOUND,SET JSW=NEGATIVE
C                     N1,N2=PRINCIPAL QUANTUM NUMBERS OF STATES
C                      LMAX=RANGE OF ANGULAR MOMENTUM QUANTUM NUMBERS
C   FOR BOUND-FREE, SET JSW=POSITIVE
C                       N1=BOUND STATE PRINCIPAL QUANTUM NUMBER
C                       E2=FREE STATE ENERGY IN RYDBERGS (=K**2)
C
C  OUTPUT
C   VECTOR CP(L),L=1,LMAX,CONTAINS SQUARED MATRIX ELEMENTS FOR ANGULAR
C                         MOMENTUM TRANSITIONS FROM L-1 TO L,
C   VECTOR CM(L),L=1,LMAX,CONTAINS SQUARED MATRIX ELEMENTS FOR ANGULAR
C                         MOMENTUM TRANSITIONS FROM L TO L-1,
C               IN BOTH CASES THE TRANSITION IS FROM LOWER TO HIGHER
C               ENERGY, INDEPENDANT OF THE SIGN OF N1-N2 FOR BOUND-BOUND
C               CASES. IF N1=N2 THEN CP(L)=CM(L).
C   VECTOR JC(L),L=1,LMAX WILL USUALLY BE ZERO AND MAY THEN BE IGNORED,
C               BUT FOR EXTREME INPUT VALUES THERE IS POSSIBILITY OF
C               OVER OR UNDERFLOW OF CP(L) OR CM(L),IN WHICH CASE THE
C               OUTPUT VALUES OF CP(L) AND CM(L) SHOULD BE MULTIPLIED
C               BY (1.0D10)**JC(L) TO OBTAIN TRUE VALUES.
C  FOR DOUBLE-PRECISION OPERATION,CHANGES ARE REQUIRED AT LINES NUMBER
C  38 40 41 42 43 44 45 46 47 48 49 50 51 124 126 137 140 156 157 160
       DIMENSION CP(LMAX),CM(LMAX),JC(LMAX)
       ZERO=0.0E0
       ONE=1.0E0
       PI=3.14159265359E0
       S1=1.0E10
       S2=1.0E-10
       TEST1=1.0E-20
       TEST2=1.0E20
       TEST3=0.044E0
       TEST4=0.1E0
       TEST5=300.0E0
       TEST6=1.0E-30
       TEST7=1.0E30
       N=N1
       E=E2
       IF (JSW.GT.0) GO TO 4
       EN2=N2
       N3=N2
       IF(N2-N1)2,59,3
    2  N=N2
       EN2=N1
       N3=N1
    3  E=-ONE/(EN2*EN2)
    4  EN=N
       ENN=EN*EN
       E1=-ONE/ENN
       JMAX=LMAX
       IF(N-LMAX)5,7,8
    5  L1=N+1
       DO 6 L=L1,LMAX
       CP(L)=ZERO
       CM(L)=ZERO
       JC(L)=0
    6  CONTINUE
    7  CP(N)=ONE
       CM(N)=ZERO
       JC(N)=0
       JMAX=N-1
    8  C1=ONE
       C2=ZERO
       JS=0
       L=N+1
    9  L=L-1
       IF (L.LE.1) GO TO 15
       EL=L
       ELL=EL*EL
       T1=ONE+ELL*E1
       T2=ONE+ELL*E
       T3=L+L-1
       T4=ONE/(T3+ONE)
       T5=(T3*T1*C2+T2*C1)*T4
       C1=(T1*C2+T3*T2*C1)*T4
       C2=T5
   11  IF (C1*C1.LE.TEST2) GO TO 13
       C1=S2*C1
       C2=S2*C2
       JS=JS+1
       GO TO 11
   13  IF (L.GT.LMAX+1) GOTO 9
       CP(L-1)=C1
       CM(L-1)=C2
       JC(L-1)=JS
       GO TO 9
   15  CONTINUE
       JS=0
       T=4
       T=ONE/(T*EN*ENN)
       IF (JSW.GT.0) GO TO 23
       ENN2=EN2*EN2
       T1=4
       T1=T1*ENN*ENN2/(ENN2-ENN)
       T1=T1*T1
       T=T*T1*T1/(EN2*ENN2)
       IF (N3.GT.30) GO TO 18
       T=T*((EN2-EN)/(EN2+EN))**(N3+N3)
       GO TO 34
   18  E21=E/E1
       IF (E21.GT.TEST4) GO TO 21
       T2=ZERO
       DO 20 J=1,11
       T3=2*(11-J)+1
       T2=ONE/T3+T2*E21
   20  CONTINUE
       T2=T2+T2
       GO TO 22
   21  T3=EN/EN2
       T2=LOG((ONE+T3)/(ONE-T3))/T3
   22  T2=T2+T2
       T1=T1*EXP(-T2)
       GO TO 34
   23  T1=4
       T1=T1*ENN/(ONE+ENN*E)
       T1=T1*T1
       T=T*T1*T1
       IF (E.GE.TEST3) GO TO 25
       T3=2
       T=T*(PI/T3)
       GO TO 29
   25  CONTINUE
       T4=SQRT(E)
       IF (T4.GT.TEST5) GO TO 27
       T3=(PI+PI)/T4
       T3=ONE-EXP(-T3)
       T3=ONE/T3
       GO TO 28
   27  T4=PI/T4
       T3=3
       T3=(ONE+T4+T4*T4/T3)/(T4+T4)
   28  T2=2
       T=T*(PI*T3/T2)
   29  T4=ENN*E
       IF (T4.GT.TEST4) GO TO 32
       T2=ZERO
       DO 31 J=1,11
       T3=2*(11-J)+1
       T2=ONE/T3-T2*T4
   31  CONTINUE
       GO TO 33
   32  T3=SQRT(T4)
       T2=ATAN(T3)/T3
   33  T2=T2+T2
       T2=T2+T2
       T1=T1*EXP(-T2)
   34  DO 39 J=1,N
       TJ=J+J
       T2=TJ*(TJ-ONE)
       T2=T2*T2
       T=T*T1/T2
   35  IF (T.GT.TEST1) GO TO 37
       T=T*S1
       JS=JS-1
       GO TO 35
   37  IF (T.LT.TEST2) GO TO 39
       T=T*S2
       JS=JS+1
       GO TO 37
   39  CONTINUE
       J=0
   40  J=J+1
       IF (J.GT.JMAX) GO TO 50
       TJ=J
       TJ=TJ*TJ
       T1=ONE+TJ*E1
       T2=ONE+TJ*E
       T3=CP(J)
       T3=T2*T*T3*T3
       T4=CM(J)
       T4=T1*T*T4*T4
       L1=JC(J)+JC(J)+JS
   42  IF(L1)43,47,45
   43  IF (T4.LE.TEST6) GO TO 47
       L1=L1+1
       T3=T3*S2
       T4=T4*S2
       GO TO 42
   45  IF (T3.GE.TEST7) GO TO 47
       L1=L1-1
       T3=T3*S1
       T4=T4*S1
       GO TO 42
   47  CP(J)=T3
       CM(J)=T4
       JC(J)=L1
       T=T*T1*T2
   48  IF (T.LE.TEST2) GO TO 40
       T=T*S2
       JS=JS+1
       GO TO 48
   50  IF (N.GT.LMAX) GO TO 58
       T2=ONE+ENN*E
       T3=CP(N)
       T3=T2*T*T3*T3
       L1=JC(N)+JC(N)+JS
   52  IF(L1)53,57,55
   53  IF (T3.LE.TEST6) GO TO 57
       L1=L1+1
       T3=T3*S2
       GO TO 52
   55  IF (T3.GE.TEST7) GO TO 57
       L1=L1-1
       T3=T3*S1
       GO TO 52
   57  CP(N)=T3
       JC(N)=L1
   58  RETURN
   59  JMAX=LMAX
       IF (N.GT.LMAX) GO TO 62
       DO 61 L=N,LMAX
       CP(L)=ZERO
       CM(L)=ZERO
       JC(L)=0
   61  CONTINUE
       JMAX=N-1
   62  T1=9
       T2=4
       T3=(T1/T2)
       T1=EN2*EN2
       T2=T1*T3
       DO 63 J=1,JMAX
       TJ=J
       JC(J)=0
       T=T2*(T1-TJ*TJ)
       CP(J)=T
       CM(J)=T
   63  CONTINUE
       RETURN
      END
C***************************************************************
C
      SUBROUTINE EPHASE
C
C EVALUATE EIGENPHASE SUM
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (MZKIL=  0)
C
      PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2)
C
      PARAMETER (ONE=1.0)
      PARAMETER (TZERO=0.0)
      PARAMETER (TWO=2.0)
      PARAMETER (FOUR=4.0)
C
      COMMON/CEN/ETOT,MXE,NWT,NZ
C  ***  NOTE CHANGE OF CC TO CCT IN /CHAN/ ***
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/COMEGA/OMEGA(MXTST),IE,NOMWRT
      COMMON/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF),
     X          ZA(MZCHF,MZCHF),ZB(MZCHF,MZCHF)
C
      DIMENSION RK2(MZCHF,MZCHF),DDD(MZCHF),EEE(MZCHF)
C
      DATA ICASE/0/
C
      IF(ICASE.EQ.0)THEN
        OPEN(UNIT=34,FILE='ESUM')
        ICASE=1
      ENDIF
C
      DO J=1,NCHOP
        DO I=1,NCHOP
          RK2(I,J)=DBLE(ZK(I,J))
        ENDDO
      ENDDO
C
      IUP=0
      CALL DIAG(NCHOP,IUP,RK2,DDD,EEE,MZCHF)
C
      SUM=TZERO
      DO I=1,NCHOP
        SUM=SUM+ATAN(DDD(I))
      ENDDO
      PI=FOUR*ATAN(ONE)
      EMIN=TZERO
      IF(LRGL2.GT.1)EMIN=-0.05
   99 CONTINUE
      IF(SUM.LT.EMIN)THEN
        SUM=SUM+PI
        GO TO 99
      ENDIF
      IF(SUM.GT.PI)THEN
        SUM=SUM-PI
        GO TO 99
      ENDIF
      IF(IE.EQ.1)WRITE(34,1000)NSPN2,LRGL2,NPTY2
      WRITE(34,1001)ETOT,SUM
C
 1000 FORMAT('#',I3,I4,I2)
 1001 FORMAT(1P2E16.8)
C
      RETURN
      END
C***********************************************************************
       REAL*8 FUNCTION F21(A,B,C,D,EPS,IFAIL)
       IMPLICIT REAL*8 (A-H,O-Z)
C
       IPRINT=IFAIL
       IFAIL=0
       T=(A*B*D)/C
       DD=1.0D0/(1.0D0-D)
       SUM=1.0D0+T
       TN1=0.0D0
       I=1
    3  AI=I
       T=T*(A+AI)*(B+AI)*D/((C+AI)*(1.0D0+AI))
       TN2=T*DD
       F21=SUM+TN2
       SUM=SUM+T
       AT=ABS(T+TN2-TN1)
       AS=ABS(F21)*EPS
       IF(AS-AT)1,2,2
    1  TN1=TN2
       I=I+1
       IF(I-300)3,3,4
    4  IF(IPRINT.GT.0)WRITE(6,100)
       IFAIL=3
  100  FORMAT(' FAILED TO CONVERGE IN F21')
    2  RETURN
      END
C
C**********************************************************
C
      REAL*8 FUNCTION FDIP(EK1,L1,EK2,L2,IFAIL)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
C ALAN BURGESS DEPT. OF APPLIED MATHS. AND THEORETICAL PHYSICS,CAMBRIDGE
C CALCULATES THE FUNCTION I(KAPPA1,L1,KAPPA2,L2,1) DEFINED IN PHIL.
C TRANS. ROY. SOC. A226,255,1970, WHERE EK1=KAPPA1**2 AND EK2=KAPPA2**2.
C IT IS SUITABLE FOR USE IN EQUATIONS (8),(9),(10) OR (11) OF
C J. PHYS. B. 7,L364,1974.
C NRB - IFAIL
      COMMON/NRBZED/TZED,LPRTSW
      DATA EPS/1.D-4/
C
      IF(TZED.EQ.0)THEN
        FDIP=FDIP0(EK1,L1,EK2,L2,EPS,IFAIL)
        RETURN
      ENDIF
C
      IPRINT=IFAIL
      IF(EK1+EK2-1.0D-40) 11,11,12
   11   FDIP=0.0D0
        IFAIL=1
        IF(IPRINT.GT.0)WRITE(6,100)IFAIL
        RETURN
   12 IF(EK1-EK2) 1,1,2
    1 EMIN=EK1
      EMAX=EK2
      GO TO 3
    2 EMIN=EK2
      EMAX=EK1
    3 T=EMIN/EMAX
      IF(T-0.02944D0) 4,4,5
    4 FDIP=FDIP1(EK1,L1,EK2,L2)
      GO TO 9
    5 IF(T-0.16667D0) 7,6,6
    6 FDIP=FDIP2(EK1,L1,EK2,L2)
      GO TO 9
    7 FDIP=FDIP1(EK1,L1,EK2,L2)
      IF(FDIP*FDIP-1.0D-40) 6,6,8
    8   IF(FDIP.LT.0.0.OR.FDIP.GT.1.)THEN
          IFAIL=3
          IF(IPRINT.GT.0)WRITE(6,100)IFAIL
          FDIP=0.0
          RETURN
        ENDIF
        FA=FDIPA(EK1,L1,EK2,L2)
        IFAIL=0
        IF(FA.EQ.0.0)THEN
          FA=FDIP0(EK1,L1,EK2,L2,EPS,IFAIL)
          IFAIL=-IFAIL
          IF(FA.EQ.0.0)RETURN
        ENDIF
        RAT=FDIP/FA
        IF(RAT.GT.10.)THEN
          IFAIL=4
          IF(IPRINT.GT.0)WRITE(6,100)IFAIL
          FDIP=0.0
        ENDIF
        RETURN
    9 IF(FDIP*FDIP-1.0D-40) 10,10,8
   10   IFAIL=2
        IF(IPRINT.GT.0)WRITE(6,100)IFAIL
        RETURN
  100 FORMAT('***FDIP FAILURE: IFAIL=',I2)
      END
C***********************************************************************
      REAL*8 FUNCTION FDIP0(EK1,L1,EK2,L2,EPS,IFAIL)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
C ALAN BURGESS,DEPT OF APPLIED MATHS. AND THEORETICAL PHYSICS,CAMBRIDGE
C CALCULATES THE FUNCTION I0(K1,L1,K2,L2,1) DEFINED IN PHIL. TRANS.
C ROY. SOC. A266,255,1970, WHERE EK1=K1*K1, EK2=K2*K2, AND THE RELATIVE
C ACCURACY IS APPROXIMATELY EPS.
C IT IS SUITABLE FOR USE IN EQUATIONS (13) ETC. OF J.PHYS.B. 7,L364,1974
C NRB - IFAIL
C
      IPRINT=IFAIL
      IFAIL=0
      IF(L1-L2)1,2,4
1     L=L1
      GO TO 5
2     IF(IPRINT.GT.0)WRITE(6,100)L1
      IFAIL=1
      FDIP0=0.0D0
3     RETURN
4     L=L2
5     EL=L
      FDIP0=0.5D0/(EL+1.0D0)
      IF(EK1-EK2)6,3,7
6     E=EK1/EK2
      P=L1-L
      GO TO 8
7     E=EK2/EK1
      P=L2-L
8     FDIP0=FDIP0*E**((EL+P+0.5D0)*0.5D0)
C TO OBTAIN THE FUNCTION EK1 OF M.J. SEATON, PROC. PHYS. SOC. A68,457,
C 1955, REMOVE THE 'C' ON THE NEXT LINE.
C     FDIP0=1.0D0
      IF(E -0.5D0)21,20,20
20    P1=P-0.5D0
      T=P1*(EL+1.0D0)*(E -1.0D0)
      I0=L+1
      H0=0.0D0
      DO 9 I=1,I0
      TI=I
      H0=H0+1.0D0/TI
9     CONTINUE
      X=1.0D0-E
      H=1.0D0-(P+P+H0+LOG(0.25D0*X))
      S=1.0D0+T*H
      A=EL+1.0D0
      B=P1
      C=1.0D0
      D=0.0D0
10    A=A+1.0D0
      B=B+1.0D0
      C=C+1.0D0
      D=D+1.0D0
      T=T*A*B*X/(C*D)
      H=H+P1/(D*B)+EL/(C*A)
      T1=T*H
      S=S+T1
      IF(ABS(T1)-EPS*ABS(S))13,11,11
11    IF(C-300.0D0)10,12,12
12    IF(IPRINT.GT.0)WRITE(6,101)
      IFAIL=2
13    FDIP0=FDIP0*S
      RETURN
21    A=EL+1.0D0
      B=P-0.5D0
      C=EL+P+1.5D0
      F=F21(A,B,C,E,EPS,IFAIL)
      L=L+1
      EL=L
      IF(P-0.5D0)23,23,24
23    C1=EL+EL+1.0D0
      GO TO 25
24    C1=1.0D0
25    DO 22 I=1,L
      AI=I
      AII=AI+AI
      C1=C1*AI*AI*4.0D0/(AII*(AII+1.0D0))
22    CONTINUE
      FDIP0=FDIP0*F*C1
      RETURN
100   FORMAT(' FAILED IN FDIP0, L1=L2=',I5)
101   FORMAT(' FAILED TO CONVERGE IN FDIP0')
      END
C***********************************************************************
       REAL*8 FUNCTION FDIP1(EK1,L1,EK2,L2)
C
       IMPLICIT REAL*8 (A-H,O-Z)
C
       IF(L1-L2)1,2,3
    1  L=L1
       A1=EK1
       A2=EK2
       GO TO 4
    2  FDIP1=0.0D0
       RETURN
    3  L=L2
       A1=EK2
       A2=EK1
    4  LP=L+1
       ELP=LP
       B1=SQRT(1.0D0+ELP*ELP*A2)*FMON1(EK1,EK2,L)
       B2=SQRT(1.0D0+ELP*ELP*A1)*FMON1(EK1,EK2,LP)
       IF(B1*B2-1.0D-40)5,5,6
    5  FDIP1=0.0D0
       RETURN
    6  FDIP1=(B1-B2)/ELP
       RETURN
      END
C***********************************************************************
       REAL*8 FUNCTION FDIP2(EK1,L1,EK2,L2)
C
       IMPLICIT REAL*8 (A-H,O-Z)
C
       WMAX=200.0D0
       ETA1=1.0D0/SQRT(EK1)
       ETA2=1.0D0/SQRT(EK2)
       W1=ETA2-ETA1
       PI=3.141592653589793D0
       A=ABS(W1)
       B=PI*A
       IF(B-0.01D0)1,1,2
    1  C=3.0D0/(3.0D0-B*(3.0D0-B*(2.0D0-B)))
       C=SQRT(C)
       GO TO 5
    2  IF(B-14.0D0)4,3,3
    3  C=SQRT(B+B)
       GO TO 5
    4  B=B+B
       C1=1.0D0-EXP(-B)
       C=SQRT(B/C1)
    5  C=0.5D0*C/SQRT(ETA1*ETA2)
       C2=ETA1+ETA2
       C1=4.0D0*ETA1*ETA2/(C2*C2)
       L=L1
       IF(L2-L1)6,6,7
    6  L=L2
       T1=ETA1
       ETA1=ETA2
       ETA2=T1
       W1=-W1
    7  C=C*C1**(L+1)
       U0=L+1
       U1=ETA1
       V0=U0
       V1=-ETA2
       W0=1.0D0
       X0=W1/(C2*C2)
       Y2=-ETA2-ETA2
       Y0=-U0*W1+Y2
       Y1=ETA2*W1
       T1=X0/(1.0D0+W1*W1)
       Z0=U0*T1
       Z1=U1*T1
       T=Z0-Z1*W1
       Z1=Z0*W1+Z1
       Z0=T
       Q0=-1.0D0+Z0*Y0-Z1*Y1
       Q1=Z0*Y1+Z1*Y0
       X=W1*X0
    8  U0=U0+1.0D0
       V0=V0+1.0D0
       W0=W0+1.0D0
       IF(W0-WMAX)21,21,20
   20  FDIP2=0.0D0
       RETURN
   21  CONTINUE
       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
       Q0=Q0+T0
       Q1=Q1+T1
       T1=T0*T0+T1*T1
       T0=Q0*Q0+Q1*Q1
       IF(T0-1.0D+24*T1)8,8,9
    9  J1=0
       J2=L+1
       P=ARGAM(J1,W1)+ARGAM(L,ETA1)-ARGAM(J2,ETA2)
       IW0=W0
       IF(A-1.0D-40)11,11,10
   10  P=P+W1*LOG(C2/A)
   11  P0=COS(P)
       P1=SIN(P)
       T=P0*Q0-P1*Q1
       Q1=P0*Q1+P1*Q0
       Q0=T
       FDIP2=C*Q1
       RETURN
      END
C
C***********************************************************************
C
      REAL*8 FUNCTION FDIPA(EK1,L1,EK2,L2)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C N.R. BADNELL
C ASYMPTOTIC EXPRESSION FOR I(KAPPA1,L1,KAPPA2,L2,1) BASED ON A40,1 OF BHT
C
      IF(EK1*EK2.GT.1.0D-50)THEN
      X1=1.0D0/SQRT(EK1)
      X2=1.0D0/SQRT(EK2)
      XP=ABS(X1-X2)
      IF(XP.GT.1.D2)GO TO 9
      PI=ACOS(-1.0D0)
      XP=EXP(0.5D0*PI*XP)
      IF(EK1-EK2)1,1,2
   1  E=EK1/EK2
      IF(L1-L2)3,3,4
   3  L=L1
      GO TO 7
   4  L=L2
      GO TO 8
   2  E=EK2/EK1
      IF(L1-L2)5,5,6
   5  L=L1
      GO TO 8
   6  L=L2
      GO TO 7
C A40
   7  TL=L
      T0=1.0D0-E
      IF(TL*T0.LT.E)GO TO 9
      T=PI*TL
      EE=SQRT(E)
      F0=SQRT(T*T0*EE)*EE**L
      TL=L+L+1
      FDIPA=F0*XP/TL
      RETURN
C A41
   8  T0=1.0D0-E
      TL=L
      IF(TL*T0.LT.E)GO TO 9
      T0=1.0D0/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*XP/(TL*TL2)
      RETURN
      ENDIF
   9  FDIPA=0.0D0
      RETURN
      END
C
C***************************************************************
C
      REAL*8 FUNCTION FKHI(E,L,AC)
C
C  CALCULATES REAL*4 PART OF PSI(L+1+I*GAM) - LN(GAM)
C  WHERE E = 1/(GAM**2).
C  THIS IS REQUIRED FOR CALCULATION OF SCRIPT G.
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
      PARAMETER (P0=ONE/252.)
      PARAMETER (P1=1.05)
      PARAMETER (P2=2.1)
C
      FKHI=TZERO
      IF(E.EQ.0)RETURN
C
      AC1=(20.*AC)**.333
C
      IF(E.GT.AC1)GOTO 100
C
      C=TZERO
      IF(L.EQ.0)GOTO 20
      A1=ONE
      A2=-E
      A3=E+E
      DO 10 I=1,L
      A2=A2+A3
      A1=A1+A2
      C=C+DBLE(I)/A1
   10 CONTINUE
   20 FKHI=E*((((P1*E+ONE)*E+P2)*E+21)*P0+C)
      RETURN
C
  100 AC1=ONE/SQRT(AC1)
      FL=DBLE(L+1)
      IF(FL.GT.AC1)GOTO 300
C
      N=AC1
      FL=N+1
      L1=L+1
      DO 210 I=L1,N
      FI=I
      FKHI=FKHI+FI/(ONE+E*FI*FI)
  210 CONTINUE
      FKHI=-FKHI*E
C
  300 X1=FL*E
      X=ONE+X1*FL
      ZE=DCMPLX(FL,ONE/SQRT(E))
      ZE=-ONE/(ZE*ZE)
      FKHI=FKHI+(LOG(X)-(X1/X))/TWO+DBLE((((P1*ZE+ONE)*ZE
     C +P2)*ZE+21)*ZE)*P0
C
      RETURN
      END
C***********************************************************************
       REAL*8 FUNCTION FMON1(EK1,EK2,L)
C
       IMPLICIT REAL*8 (A-H,O-Z)
C
       IF(EK1+EK2-1.0D-40)28,28,29
   28  FMON1=1.0D+50
       RETURN
   29  CONTINUE
       VMAX=200.0D0
       X1=SQRT(EK1)
       X2=SQRT(EK2)
       X3=X1+X2
       X4=X3*X3
       X5=X1*X2
       X6=X2-X1
       X7=4.0D0/X4
       PI=3.141592653589793D0
       IF(EK1-EK2)1,1,2
    1  ETA=1.0D0/X2
       GO TO 3
    2  ETA=1.0D0/X1
    3  G=0.5D0*PI*EXP(-PI*ETA)
       IF(G.EQ.0.0D0)GO TO 20           !NRB
       A1=1.0D0
       A2=1.0D0
       MG=0
       MA1=0
       MA2=0
       M=-1
    4  M=M+1
       EM=M
       T=EM+EM+1.0D0
       G=G*X7/(T*(T+1.0D0))
       EMM=EM*EM
       A1=A1*(1.0D0+EMM*EK1)
       A2=A2*(1.0D0+EMM*EK2)
   30  IF(G-0.015625D0) 31,32,32
   31  G=64.0D0*G
       MG=MG-1
       GO TO 30
   32  IF(G-64.0D0) 34,34,33
   33  G=0.015625D0*G
       MG=MG+1
       GO TO 32
   34  IF(A1-64.0D0) 36,36,35
   35  A1=0.015625D0*A1
       MA1=MA1+1
       GO TO 34
   36  IF(A2-64.0D0) 38,38,37
   37  A2=0.015625D0*A2
       MA2=MA2+1
       GO TO 36
   38  CONTINUE
       IF(M-L)4,5,5
    5  G=G*(T+1.0D0)
       IF(X1-300.0D0)7,6,6
    6  B=PI/X1
       A1=1.5D0*A1/(B*(3.0D0-B*(3.0D0-B*(2.0D0-B))))
       GO TO 9
    7  IF(X1-0.2D0)9,9,8
    8  B=-PI/X1
       A1=A1/(1.0D0-EXP(B+B))
    9  IF(X2-300.0D0)11,10,10
   10  B=PI/X2
       A2=1.5D0*A2/(B*(3.0D0-B*(3.0D0-B*(2.0D0-B))))
       GO TO 13
   11  IF(X2-0.2D0)13,13,12
   12  B=-PI/X2
       A2=A2/(1.0D0-EXP(B+B))
   13  G=G*SQRT(A1*A2)*(8.0D0)**(MG+MG+MA1+MA2)
       S0=1.0D0
       S1=0.0D0
       U=L
       V=0.0D0
       W=U+U+1.0D0
       T0=1.0D0
       T1=0.0D0
   14  U=U+1.0D0
       V=V+1.0D0
       W=W+1.0D0
       IF(V-VMAX)21,21,20
   20  FMON1=0.0D0
       RETURN
   21  CONTINUE
       U0=U*U*X5+1.0D0
       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=1.0D0/S
       TM=1.0D0/T
       IF(SM*TM.EQ.0.0D0)GO TO 20      !NRB
       IF(S-1.0D+24*T)14,15,15
   15  FMON1=G*SQRT(S)
       IV=V
       RETURN
      END
C*******************************************************************
C
      REAL*8 FUNCTION FWIDTH(NZA,NMIN,NMAX,ECH,LL)
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER (NVINT=50, ICMX=22)
      PARAMETER (ZERO=0.0, ONE=1.0, TWO=2.0, FOUR=4.0, TWELV=12.0)
      LOGICAL BJUMP
      DIMENSION NS(22),TCN(100)
      COMMON /DIP/ CP(100),CM(100),JDUM(100)
C
C EVALUATE FREE-BOUND (RR) ************* OF CONTINUUM ELECTRON,
C ECH=Z-SCALED CONTINUUM ENERGY (RY)
C LL=CONTINUUM ORBITAL ANGULAR MOMENTUM
C NMIN=LOWEST N-VALUE ACCESSIBLE
C NMAX= HIGHEST N-VALUE INCLUDED
C NZA=ION CHARGE.
C
      DATA NS/21,25,30,36,42,50,60,72,85,100,115,135,160,200
     X       ,250,300,375,450,550,675,825,1000/
C
      FWIDTH=ZERO
COLD      IF(NMIN.GT.NZA)RETURN
      NR1=MAX0(NMIN,LL)
      IF(NR1.GT.NMAX)RETURN
      IF(NR1.GT.NS(1))THEN
      IF(NR1.GT.100)RETURN
      WRITE(6,*)' **FWIDTH** NMIN=',NMIN,' > NSTART =',NS(1)
      STOP
      ENDIF
      LP=LL+1
      IF(LP.GT.100)THEN
      WRITE(6,*)' **FWIDTH** L =',LP,' > LDIM = 100'
      STOP
      ENDIF
      DZ=NZA*NZA
      N=NR1
      TC=ZERO
      IC=1
      BJUMP=.FALSE.
C
  10  TN=N*N
      DE=ONE/TN+ECH
      CALL DIPOL(1,N,0,ECH,LP,CP,CM,JDUM)
      TL=LL+LL
      TLP=LP+LP
      FSUM=TLP*CM(LP)*1.0D10**JDUM(LP)
      IF(LL.GT.0)FSUM=FSUM+TL*CP(LL)*1.0D10**JDUM(LL)
      FSUM=1.13953D-5*FSUM*DE**3*DZ     ! pi*a0**2*alpha**3/3 Mb
      IF(.NOT.BJUMP)THEN
      TC=TC+FSUM
      IF(N.EQ.NMAX)GO TO 70
      ENDIF
      TCN(IC)=FSUM
      N=N+1
      IF(N.LE.NS(1))GO TO 10
      IF(IC.EQ.ICMX)GO TO 12
      BJUMP=.TRUE.
      IC=IC+1
      N=NS(IC)
      GO TO 10
C
C
C     SUM HIGH N USING INTERPOLATION AND THEN SIMPSONS RULE
C
  12  DO 15 I=3,ICMX,2
      I0=I
      T1=NS(I-2)
      T2=NS(I-1)
      T3=NS(I)
      V1=T1**3
      V2=T2**3
      V3=T3**3
  20  N1=NS(I0-2)
      N2=NS(I0-1)
      TN1=N1*N1
      N1=N1+1
      DO 30 N=N1,N2
      TN=N
      S1=V1*(T2-TN)*(T3-TN)/((T2-T1)*(T3-T1))
      S2=V2*(T1-TN)*(T3-TN)/((T1-T2)*(T3-T2))
      S3=V3*(T1-TN)*(T2-TN)/((T1-T3)*(T2-T3))
      TN2=N*N
      TT=S1*TCN(I-2)+S2*TCN(I-1)+S3*TCN(I)
      TT=TT/(TN*TN2)
      TC=TC+TT
      IF(N.EQ.NMAX)GO TO 70
  30  CONTINUE
      I0=I0+1
      IF((I0-1).EQ.I)GO TO 20
      IC0=I
      IF((I+1).LT.ICMX.AND.N2.GT.NVINT)GO TO 40
  15  CONTINUE
      GO TO 70
C
  40  TC=TC-TCN(IC0)/TWO
      IC0=IC0+2
C
C SIMPSONS RULE
C
      DO 50 I=IC0,ICMX,2
      IF(NS(I-1).GT.NMAX)GO TO 70
      T1=NS(I-2)*NS(I-2)
      T3=NS(I)*NS(I)
      H=(T3-T1)/(T1*T3)
      H=H/TWELV
      T=NS(I-2)
      T1=T1*T
      T2=NS(I-1)**3
      T=NS(I)
      T3=T3*T
      TT=ZERO
      T=T1*TCN(I-2)+FOUR*T2*TCN(I-1)+T3*TCN(I)
      IF(I.EQ.ICMX)TT=TCN(ICMX)/TWO
      T=T*H+TT
      TC=TC+T
  50  CONTINUE
C
CTOM  70  FWIDTH=TC/(ECH*DZ)    ! Mb   THIS IS ACTUAL FWIDTH, DIVERGES AT E=0
  70  FWIDTH=TC                 ! Mb*E
C  CONVERT FROM CROSS SECTION IN MB*E(RYD) TO <S|V|S> IN Z-SCALED UNITS
      IF(ECH.GT.0)THEN
      FWD=FWIDTH/(ECH*DZ)
      ELSE
      FWD=FWIDTH*1.E+20
      ENDIF
c      WRITE(28,*)' FWIDTH(MB) = ',FWD
      PIA0SQ=87.97115
      FWIDTH=FWIDTH/PIA0SQ
      RETURN
      END
C***************************************************************
C
      SUBROUTINE INJWBK(E,L,J)
C
C  COMPUTES ARRAY D WHICH IS HELD IN COMMON/CJWBK/ AND
C  USED FOR CALCULATION OF JWBK FUNCTIONS.
CNRB
C  NEUTRAL CASE ADDED
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (MX15N=15*MZCHF)
C
      COMMON/CJWBK/D(MX15N)
      COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC
      COMMON/NRBZED/TZED,LPRTSW
C
      D(J+1)=E
C
      IF(TZED.EQ.0)THEN
        FK=SQRT(E)
        D(J+2)=FK
        IF(L.GT.0)THEN
          D(J+3)=1./FK
          C=DBLE(L*(L+1))
          D(J+4)=C
          SC=SQRT(C)
          D(J+5)=SC
          D(J+6)=(C+.125)/SC
          D(J+7)=E*C
          D(J+12)=6.*E*C
          D(J+14)=-C*C
          D(J+15)=-L*1.5707963
        ELSE
          D(J+4)=0.0
          D(J+15)=0.0
        ENDIF
        RETURN
      ENDIF
C
      IF(L.GT.0)GOTO 10
C
C  CASE OF L.EQ.0
      D(J+4)=0.
      IF(E.EQ.0)GOTO 30
C  CASE OF L.EQ.0 AND E.GT.0
      FK=SQRT(E)
      D(J+2)=FK
      D(J+3)=1./FK
      GOTO 30
C
   10 IF(E.GT.0)GOTO 20
C
C  CASE OF L.GT.0 AND E.EQ.0
      C=DBLE(L*(L+1))
      D(J+4)=C
      SC=SQRT(C)
      D(J+5)=SC
      D(J+6)=(C+.125)/SC
      D(J+13)=6.*C
      D(J+14)=-C*C
      GOTO 30
C
C  CASE OF L.GT.0 AND E.GT.0
   20 FK=SQRT(E)
      D(J+2)=FK
      D(J+3)=1./FK
      C=DBLE(L*(L+1))
      D(J+4)=C
      SC=SQRT(C)
      D(J+5)=SC
      D(J+6)=(C+.125)/SC
      A=1.+E*C
      D(J+7)=A
      A=3.*A
      D(J+8)=A-1.
      D(J+9)=A+1.
      D(J+10)=FK*C
      D(J+11)=-4.*E
      D(J+12)=-9.+2.*A
      D(J+13)=6.*C
      D(J+14)=-C*C
C
C  TERM IN ARG GAMMA ETC
   30 D(J+15)=ARGC(E,L,AC)
C
      RETURN
      END
C***************************************************************
C
      SUBROUTINE INTBUT(KK,XX,BUTTLE)
C
C DETRMINE BUTTLE CORRECTION FROM DARC
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      COMMON/DBUT/EBUTD(MZNRG,MZLP1),CBUTD(MZNRG,MZLP1),NBUTD(MZNRG)
     X           ,K2P(MZCHF)
C
C
      FX(X)=((X-X2)/(X1-X2))*((X-X3)/(X1-X3))*Y1+((X-X1)/(X2-X1))*
     X      ((X-X3)/(X2-X3))*Y2+((X-X1)/(X3-X1))*((X-X2)/(X3-X2))*Y3
C
      MM=NBUTD(KK)
C
      IF (MM.EQ.2) THEN
        X1=EBUTD(1,KK)
        X2=EBUTD(2,KK)
        Y1=CBUTD(1,KK)
        Y2=CBUTD(2,KK)
        BUTTLE=(XX-X2)/(X1-X2)*Y1+(XX-X1)/(X2-X1)*Y2
        RETURN
      ENDIF
C
      DO M=1,MM
        IF(XX.LT.EBUTD(M,KK))GO TO 10
      ENDDO
      II=MM
      GO TO 20
C
   10 CONTINUE
      II=M
   20 CONTINUE
C
      IF (II.EQ.1) THEN
        X1=EBUTD(1,KK)
        X2=EBUTD(2,KK)
        X3=EBUTD(3,KK)
        Y1=CBUTD(1,KK)
        Y2=CBUTD(2,KK)
        Y3=CBUTD(3,KK)
        BUTTLE=FX(XX)
        RETURN
      ENDIF
C
      IF (II.EQ.MM) THEN
        X1=EBUTD(MM-2,KK)
        X2=EBUTD(MM-1,KK)
        X3=EBUTD(MM  ,KK)
        Y1=CBUTD(MM-2,KK)
        Y2=CBUTD(MM-1,KK)
        Y3=CBUTD(MM  ,KK)
        BUTTLE=FX(XX)
        RETURN
      ENDIF
C
      X1=EBUTD(II-1,KK)
      X2=EBUTD(II  ,KK)
      X3=EBUTD(II+1,KK)
      Y1=CBUTD(II-1,KK)
      Y2=CBUTD(II  ,KK)
      Y3=CBUTD(II+1,KK)
      BUTTLE=FX(XX)
      RETURN
C
      END
C
C***************************************************************
C
      SUBROUTINE JWBK(R,J,S,SP,C,CP)
C
C  COMPUTES FUNCTIONS S AND C AND THEIR DERIVATIVES SP AND
C  CP USING IJWBK METHOD.
C  USES DATA IN ARRAY D WHICH IS HELD IN COMMON/CJWBK/
C  AND SHOULD HAVE BEEN COMPUTED IN SUBROUTINE INJWBK.
CNRB
C  NEUTRAL CASE ADDED
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (MX15N=15*MZCHF)
C
      COMMON/CJWBK/D(MX15N)
      COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC
      COMMON/NRBZED/TZED,LPRTSW
C
C
C
      E=D(J+1)
      C=D(J+4)
      X=1./R
C
      IF(TZED.EQ.0)THEN
        IF(C.EQ.0)THEN
          FK=D(J+2)
          WH=FK
          ET=1.0/SQRT(WH)
          ETP=0.
          P=FK*R
          ZET=FK
          GO TO 110
        ELSE
          XSQ=X*X
          W=E-C*XSQ
          A1=0.0625*(X/W)**3
          CC=A1*(D(J+14)*XSQ+D(J+12))*X
          BB=A1*(6.*D(J+14)*XSQ+4.*D(J+12))*X
          WH=SQRT(W)
          Z=R*WH
          ZSQ=Z*Z
          P=(ZSQ-0.125-.2083333*C/ZSQ)/Z+D(J+15)
          S=D(J+5)
          G=Z
          P=P+D(J+6)*ATAN2(S,G)
          GO TO 100
        ENDIF
      ENDIF
C
      IF(C.EQ.0)GOTO 30
      IF(E.EQ.0)GOTO 70
C
C  CASE OF C.GT.0 AND E.GT.0
      W=E+X*(2.-C*X)
      WH=SQRT(W)
      Z=R*WH
      FK=D(J+2)
      RK=R*FK
      RMC=R-C
      ALP=Z+RK
      CK=D(J+10)
C  COMPUTE PHASE
      P=Z+D(J+15)
C  LOG TERM
      B=FK*ALP
      IF(B.GT.ACJWBK)GOTO 10
      B=-B
      P=P+ALP*((((.2*B+.25)*B+.33333333)*B+.5)*B+1.)
      GOTO 20
   10 P=P+D(J+3)*LOG(1.+B)
C  ARCTAN TERM
   20 S=D(J+5)*(Z-FK*RMC)
      G=CK*Z+RMC
      P=P+D(J+6)*ATAN2(S,G)
C  CAP. PHI TERM
      P=P+((5.*RMC/(Z*Z))-(Z*D(J+9)+RK*D(J+8)+CK)/
     C (ALP*D(J+7)))/(24.*Z)
C  COMPUTE AMPLITUDE
      A1=.0625*(X/W)**3
      CC=A1*(((D(J+14)*X+D(J+13))*X+D(J+12))*X+D(J+11))
      BB=A1*(((6.*D(J+14)*X+5.*D(J+13))*X+4.*D(J+12))
     1 *X+3.*D(J+11))
      GOTO 100
C
   30 IF(E.EQ.0)GOTO 60
C
C  CASE OF C.EQ.0 AND E.GT.0
      W=2.*X+E
      WH=SQRT(W)
      Z=R*WH
      FK=D(J+2)
      RK=R*FK
      ALP=Z+RK
C  COMPUTE PHASE
      P=Z+D(J+15)
      B=FK*ALP
      IF(B.GT.ACJWBK)GOTO 40
      B=-B
      P=P+ALP*((((.2*B+.25)*B+.33333333)*B+.5)*B+1.)
      GOTO 50
   40 P=P+D(J+3)*LOG(1.+B)
   50 P=P+1/(4.*ALP)+(5.*R/(Z*Z)-2.*(Z+ALP)/ALP)/(24.*Z)
C  COMPUTE AMPLITUDE
      A1=.0625*(X/W)**3
      CC=A1*(-4.*E-3.*X)
      BB=-12.*A1*(E+X)
      GOTO 100
C
C  CASE OF C.EQ.0 AND E.EQ.0
   60 W=2.*X
      WH=SQRT(W)
      Z=R*WH
      P=2.*Z*(1.+.046875*X)+D(J+15)
      WMQ=1./SQRT(WH)
      ET=(1.+.0234375*X)*WMQ
      ZET=(1.-.046875*X)*WH
      ETP=.25*(1.-.0703125*X)*X*WMQ
      GOTO 110
C
C  CASE OF E.EQ.0 AND C.GT.0
   70 W=X*(2.-C*X)
      WH=SQRT(W)
      Z=R*WH
      RMC=R-C
C  COMPUTE PHASE
      P=2.*Z+D(J+15)
      S=D(J+5)*Z
      P=P+D(J+6)*ATAN2(S,RMC)
      P=P-(3.*R+C)/(24.*(RMC+R)*Z)
C  COMPUTE AMPLITUDE
      A1=.0625*(X/W)**3
      CC=((D(J+14)*X+D(J+13))*X-3.)*X*A1
      BB=((6.*D(J+14)*X+5*D(J+13))*X-12.)*X*A1
C
C  COMPLETE CALCULATION OF S,SP,C AND CP
 100  WMQ=1./SQRT(WH)
      ET=(1.-CC)*WMQ
      ETP=(.5*(X*X/W)*(TZED-C*X)*(1.-13.*CC)+X*BB)*WMQ
      ZET=(1.+2.*CC)*WH
  110 SI=SIN(P)
      CO=COS(P)
      S=ET*SI
      C=ET*CO
      SP=ETP*SI+C*ZET
      CP=ETP*CO-S*ZET
C
      RETURN
      END
C**********************************************************
C
      SUBROUTINE MESH
C
C  CALCULATES ENERGY MESH FOR CASE OF IMESH=2
C  OR IMESH=-S WHERE S=2*TOTAL SPIN +1
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,KAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENATK(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/CDEGEN/ENATR(MZTAR),NASTD,NASTR,NLEV(MZTAR),NCNATR(MZTAR)
     X,IWD(MZTAR),IWT
      COMMON/CEN/ETOT,MXE,NWT,NZ
      COMMON/CMESH/EMAX,EMIN,DEOPEN,DQN,QNMAX,EMESH(MZMSH),IMESH
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      DIMENSION ENAT(MZTAR)
C
C
C  PARAMETERS READ FOR IMESH=2
C  ***************************
C
C  DQN     INTERVAL FOR EFFECTIVE QUANTUM NUMBER
C
C  QNMAX   LARGEST ALLOWED VALUE OF EFFECTIVE QUANTUM NUMBER
C
C  EMIN    LOWEST VALUE OF ETOT
C
C  EMAX    HIGHEST VALUE OF ETOT
C
C  DEOPEN  INTERVAL IN ETOT FOR ALL CHANNELS OPEN
C
C  ALL ENERGIES ARE Z-SCALED AND RELATIVE TO GROUND ENERGY
C
C  IRDEC   RADIATIVE DECAYS INCLUDED FOR IRDEC>0
C
      WRITE(6,600)
      WRITE(6,605)DQN,QNMAX,EMIN,EMAX,DEOPEN
C
C  CASE OF IMESH =  -TOTAL SPIN  (ADDED 9.06.88)
C
C  NOTE CHANGES TO /CINPUT/
C       NAST REPLACED BY KAST
C       ENAT   ..     .. ENATK
C  FORM NEW VALUE NAST FOR USE ONLY BY SUBROUTINE MESH WHERE
C       NAST=NO. OF STATES WHICH CAN FORM CHANNELS FOR TOTAL
C            SPIN GIVEN BY ABS(IMESH)
C       ENAT=CORRESPONDING ARRAY OF TARGET ENERGIES
C  NOTE SPECIAL TREATMENT IF DEGENERATE LEVELS HAVE BEEN COMBINED
C  IN SUBROUTINE SCALE1
C  IF IMESH IS .GT. 0 NAST, ENAT COPIED FROM KAST, ENATK
C
      IF (IMESH .LT. 0)THEN
         ISP=ABS(IMESH)
         ISP1=ISP-1
         ISP2=ISP+1
         IMESH=2
         NAST=0
         IF (NASTD .EQ. 0)THEN
            DO 1   I=1,KAST
            ISATI=ISAT(I)
            IF (ISATI .GE. ISP1 .AND. ISATI .LE. ISP2) THEN
               NAST=NAST+1
               ENAT(NAST)=ENATK(I)
            END IF
    1       CONTINUE
         ELSE
            N2=0
            DO 2   ID=1,KAST
            N1=N2+1
            N2=NLEV(ID)+N1-1
            DO 3   IN=N1,N2
            ISATN=ISAT(IN)
            IF (ISATN .GE. ISP1 .AND. ISATN .LE. ISP2) THEN
               NAST=NAST+1
               ENAT(NAST)=ENATK(ID)
               GO TO 2
            END IF
    3       CONTINUE
    2       CONTINUE
         END IF
      ELSE
         NAST=KAST
         DO 4   I=1,KAST
         ENAT(I)=ENATK(I)
    4    CONTINUE
      END IF
C     WRITE(6,'('' NAST='',I4)') NAST
C     WRITE(6,'(1X,5F12.6)')(ENAT(I),I=1,NAST)
C
C  CASE OF EMIN.GE.ENAT(NAST)  (ADDED 9.12.87)
      IF(EMIN.GE.ENAT(NAST))THEN
            F=EMAX-EMIN
            IF(F.LT.0)THEN
                  IE=0
                  GOTO 400
            ENDIF
            J=1+F/DEOPEN
            F=F/DBLE(J)
            E=EMIN
            IE=1
            EMESH(IE)=E
            IF(IE+J.GT.MZMSH)GOTO 500
            DO 5 K=1,J
            IE=IE+1
            E=E+F
    5       EMESH(IE)=E
            GOTO 400
      ENDIF
C
C  INITIALISATIONS
      QNINT=1./DQN
      SE=QNMAX**(-2)
      E=MAX(EMIN,-SE)
C      E=MAX(EMIN,ENAT(1)-SE)            !ENAT(1) USUALLY ZERO....
      IE=0
      IF(EMAX.LT.E)GOTO 400
C
C  FIND NC1, LOWEST LEVEL ABOVE EMIN
      DO 10 N=1,NAST
      IF(EMIN.GE.ENAT(N))GOTO 10
      NC1=N
      GOTO 20
   10 CONTINUE
      IE=IE+1
      EMESH(IE)=EMIN
      WRITE(6,650)
      WRITE(6,640)IE,EMESH(IE)
      GOTO 300
   20 WRITE(6,610)NC1
C
C  FIND NC2, HIGHEST LEVEL BELOW EMAX
      DO 30 N=NAST,1,-1
      IF(ENAT(N).GT.EMAX)GOTO 30
      NC2=N
      GOTO 40
   30 CONTINUE
      GOTO 50
   40 WRITE(6,620)NC2
C
C     RPS-BRAKE - WE'93MAY2:
C     IF(IOPT1.LE.9) GO TO 50
      IF(ENAT(NC1)-SE.GE.EMIN) GO TO 50
      WRITE(6,605)
      EMIN=ENAT(NC1)+.000001
C
C   ENERGIES IN RANGE EMIN TO ENAT(NC2)
C  ************************************
C
   50 IF(IPRINT.GT.0)WRITE(6,625)
      EN=-1
      DO 160 N=NC1,NC2
      ENM=EN
      EN=ENAT(N)
      IF(EN.EQ.ENM)GOTO 160
C
C   RANGE UP TO (EN-SE)
      IF((EN-SE).GT.E)THEN
        F=1./SQRT(EN-E)
        D=.999*(QNMAX-F)
        J=2+D*QNINT
        D=D/DBLE(J-1)
        IF(IPRINT.GT.0)WRITE(6,660)
                    IF((IE+J).GT.MZMSH)GOTO 500
        DO 110 K=1,J
        IE=IE+1
        EMESH(IE)=EN-F**(-2)
        IF(IPRINT.GT.0)WRITE(6,630)IE,EMESH(IE),N,N,F
  110   F=F+D
        E=EN-QNMAX**(-2)
      ENDIF
C
C    RANGE UP TO EN
C...FIND NEXT HIGHER THRESHOLD
      DO 120 M=N+1,NAST
      IF(ENAT(M).NE.EN)THEN
C----
        MM=M
C----
        EM=ENAT(M)
        GOTO 140
      ENDIF
  120 CONTINUE
C... NO NEXT THRESHOLD, USE DEOPEN
  125 F=.999*(ENAT(N)-E)
      J=2+F/DEOPEN
      F=F/DBLE(J-1)
      IF(IPRINT.GT.0)WRITE(6,690)
                    IF((IE+J).GT.MZMSH)GOTO 500
      DO 130 K=1,J
      IE=IE+1
      EMESH(IE)=E
      IF(IPRINT.GT.0)WRITE(6,680)IE,E,N
  130 E=E+F
      E=ENAT(NAST)
      GOTO 300
C... USING NEXT HIGHER THRESHOLD
  140 F1=1./SQRT(EM-E)
      F2=1./SQRT(EM-EN)
      D=.999*(F2-F1)
C----
C  MODIFICATION FOR NEAR-DEGENERATE CHANNELS (KAB,JAN94)
      IF(F2.GT.QNMAX) THEN
        D=QNMAX-F1-DQN
        IF(D.LT.0.0) GO TO 155
      ENDIF
C----
      J=2+D*QNINT
      D=D/DBLE(J-1)
      F=F1
      IF(IPRINT.GT.0)WRITE(6,660)
                    IF((IE+J).GT.MZMSH)GOTO 500
      DO 150 K=1,J
      IE=IE+1
      EMESH(IE)=EM-F**(-2)
      IF(IPRINT.GT.0)WRITE(6,630)IE,EMESH(IE),N,M,F
  150 F=F+D
      IF(IPRINT.GT.0)WRITE(6,660)
      E=EN
C----
      IF(F2.LE.QNMAX) GO TO 160
      E=EM-QNMAX**(-2)
  155 MM=MM+1
      IF(MM.GT.NAST) GO TO 125
      EM=ENAT(MM)
      GO TO 140
C----
  160 CONTINUE
C
C
C  ENERGIES IN RANGE ENAT(NC2) TO EMAX
C  ***********************************
C
C  FIND NEXT HIGHER THRESHOLD
      DO 210 M=NC2+1,NAST
      IF(ENAT(M).NE.EN)THEN
C----
        MM=M
C----
        EM=ENAT(M)
        GOTO 220
      ENDIF
  210 CONTINUE
      GOTO 280
C
C  RANGE UP TO MIN(EMAX,(EM-SE))
  220 IF((EM-SE).GT.E)THEN
        IF((EM-SE).GT.EMAX)THEN
C...  CASE OF EMAX.LT.(EM-SE)
          F1=1./SQRT(EM-E)
          F2=1./SQRT(EM-EMAX)
          D=F2-F1
          J=2+D*QNINT
          D=D/DBLE(J-1)
          F=F1-D
          IF(IPRINT.GT.0)WRITE(6,660)
                    IF((IE+J).GT.MZMSH)GOTO 500
          DO 230 K=1,J
          F=F+D
          IE=IE+1
          EMESH(IE)=EM-F**(-2)
  230     IF(IPRINT.GT.0)WRITE(6,630)IE,EMESH(IE),N,M,F
          IF(IPRINT.GT.0)WRITE(6,660)
          GOTO 400
        ELSE
C... CASE OF EMAX.GT.(EM-SE)
          F=1./SQRT(EM-E)
          D=.999*(QNMAX-F)
          J=2+D*QNINT
          D=D/DBLE(J-1)
          F=F-D
          IF(IPRINT.GT.0)WRITE(6,660)
                    IF((IE+J).GT.MZMSH)GOTO 500
          DO 240 K=1,J
          IE=IE+1
          F=F+D
          EMESH(IE)=EM-F**(-2)
  240     IF(IPRINT.GT.0)WRITE(6,630)IE,EMESH(IE),N,M,F
          E=EM-QNMAX**(-2)
        ENDIF
      ENDIF
C
C  FIND NEXT HIGHER THRESHOLD
C
C----
      N=MM
C----
C      N=M
      EN=EM
      DO 250 M=N+1,NAST
      IF(ENAT(M).NE.EN)THEN
        EM=ENAT(M)
        MM=M
        GOTO 260
      ENDIF
  250 CONTINUE
      GOTO 280
  260 M=MM
      F1=1./SQRT(EM-E)
      F2=1./SQRT(EM-EMAX)
      D=F2-F1
C----
      IF(F2.GT.QNMAX) THEN
        D=QNMAX-F1-DQN
        IF(D.LT.0.0) GO TO 275
      ENDIF
C----
      J=2+D*QNINT
      D=D/DBLE(J-1)
      F=F1-D
      IF(IPRINT.GT.0)WRITE(6,660)
                    IF((IE+J).GT.MZMSH)GOTO 500
      DO 270 K=1,J
      F=F+D
      IE=IE+1
      EMESH(IE)=EM-F**(-2)
  270 IF(IPRINT.GT.0)WRITE(6,630)IE,EMESH(IE),N,M,F
      IF(IPRINT.GT.0)WRITE(6,660)
C      GOTO 400
C----
      IF(F2.LE.QNMAX) GO TO 400
      E=EM-QNMAX**(-2)
  275 MM=MM+1
      IF(MM.GT.NAST) GO TO 280
      EM=ENAT(MM)
      GO TO 260
C----
C
C
C  UP TO EMAX USING DEOPEN
  280 F=EMAX-E
      J=2+F/DEOPEN
      F=F/DBLE(J-1)
      E=E-F
      IF(IPRINT.GT.0)WRITE(6,690)
                    IF((IE+J).GT.MZMSH)GOTO 500
      DO 290 K=1,J
      E=E+F
      IE=IE+1
      EMESH(IE)=E
  290 IF(IPRINT.GT.0)WRITE(6,680)IE,E,N
      GOTO 400
C
C
C
C  ALL CHANNELS OPEN
C  *****************
C
  300 IF(IPRINT.GT.0)WRITE(6,650)
                    J=1
                    IF(IE+J.GT.MZMSH)GOTO 500
      IE=IE+1
      E=ENAT(NAST)
      EMESH(IE)=E
      IF(IPRINT.GT.0)WRITE(6,640)IE,E
      F=EMAX-E
      J=1+F/DEOPEN
      F=F/DBLE(J)
                    IF((IE+J).GT.MZMSH)GOTO 500
      DO 310 K=1,J
      E=E+F
      IE=IE+1
      EMESH(IE)=E
  310 IF(IPRINT.GT.0)WRITE(6,640)IE,E
C
C  TASK COMPLETED
C  **************
C
  400 MXE=IE
      WRITE(6,670)MXE
      RETURN
C
  500 WRITE(6,675)
      MXE=IE+J
      WRITE(6,670)MXE
      STOP
C
C  FORMATS
  600 FORMAT(//1X,70('*')//20X,'ENERGY MESH'/20X,11('*')/)
  605 FORMAT(//' DQN    = ',F10.6/' QNMAX  = ',F10.6/
     +  ' EMIN   = ',F10.6/' EMAX   = ',F10.6/' DEOPEN = ',F10.6//)
  610 FORMAT(' LOWEST LEVEL ABOVE EMIN,  NC1 = ',I3)
  620 FORMAT(' HIGHEST LEVEL BELOW EMAX, NC2 = ',I3)
  625 FORMAT(/' VALUES OF  -  IE, E = EMESH(IE), N = LOWEST'
     + ,' LEVEL ABOVE E,'/15X,'M = LEVEL USED FOR EFFECTIVE',
     +' QUANTUM NUMBER'/15X,'AND FNU = EFFECTIVE QUANTUM NUMBER'/
     + /3X,'IE',4X,'EMESH',17X,'N',4X,'M',4X,'FNU'/)
  630 FORMAT(I5,F12.6,10X,2I5,F12.6)
  640 FORMAT(I5,F12.6)
  650 FORMAT(/31X,'ALL OPEN'/)
  660 FORMAT()
  670 FORMAT(/' NUMBER OF ENERGIES, MXE = ',I5/)
  675 FORMAT(///10X,64('*')/10X,
     +'NUMBER OF ENERGIES EXCEEDS MAXIMUM OF MZMSH ALLOWED BY'
     +,' DIMENSIONS' /10X,64('*')//)
  680 FORMAT(I5,F12.6,10X,I5)
  690 FORMAT(/36X,'USING DEOPEN')
C
      END
C***************************************************************
C
      SUBROUTINE MQDTS
C
C NRB:
C  CALCULATION OF OMEGA FROM KHI-MX IN QDT, ALL CHANNELS OPEN.
C  OPTIONAL (TYPE-I) RADIATION DAMPING - BELL & SEATON OR HICKMAN-ROBICHEAUX.
C  DR N CUT-OFF AT NCUTOFF; EXCITATION IS THEN **UNDAMPED** ABOVE NCUTOFF.
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      LOGICAL QDT
C
      INCLUDE 'PARAM'
C
      PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2)
      PARAMETER (MNPEXT=MZMNP+MZCHF)
      PARAMETER (LWORK=MZCHF*MZCHF)
      PARAMETER (MWORK=MZCHF*MZCHF)
C
      PARAMETER (ZERO=(0.0,0.0))
      PARAMETER (ZONE=(1.0,0.0))
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
      PARAMETER (QUART=0.25)
      PARAMETER (BIG=150.0)
C
      CHARACTER ELAS*3
C
      COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC
      COMMON/CDEC/ARAD(MXTST),ARDEC(MZTAR),SLIN(MXTST),IRDEC,IEND
     X,IPAR(MZTAR),NEWAR
      COMMON/CEN/ETOT,MXE,NWT,NZ
C  ***  NOTE CHANGE OF CC TO CCT IN /CHAN/ ***
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/COMEGA/OMEGA(MXTST),IE,NOMWRT
      COMMON/CQDT/R2ST(MZCHF),QDT,NQ
      COMMON/NRBDR/PDR(MZCHF),OMEGDR(MZMET,MZMSH),NDRMET
      COMMON/NRBHYB/FNUHYB,NCHCL,ICHCL(MZCHF),NCHHYB,ICHHYB(MZCHF)
      COMMON/NRBKHI/ZKHICC(MZDEG,MZDEG),ZKHIOC(MZCHF,MZDEG),ZVAL(MZDEG)
CBL  X,ZVL(MZDEG,MZDEG),ZVR(MZDEG,MZDEG),RWORK(2*MZDEG)
      COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT
      COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN
      COMMON/NRBRCT/
     X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF)
     X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF)
     X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF)
     X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF)
     X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF)
     X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF)
     X,RMAT(MZCHF,MZCHF)
      COMMON/NRBSKP/ISKP(MZMSH),ISKP0,LINC,ELAS
      COMMON/NRBPH1/ZCOEF(MNPEXT,MZCHF),OMEGPR(MZMET,MZMSH),EPHMIN,
     1              EPHMAX,IPHOTO,NODAMP
      COMMON/NRBPH7/ZBB(MZDIP,MZCHF),ZDIP(MZDIP,MZCHF)
     X,ZD(MZCHF,MZCHF),ZE(MZCHF,MZCHF),ZF(MZCHF,MZCHF)
     X,IDEC(MZEPI*MZMET),JDEC(MZDEC),IPIV(MZCHF),NDEC0
      COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK)
      COMMON/TYPE/NTYP1,NTYP2I,NTYP2OF,NTYP2OR,NMIN
      COMMON/ZCOUL/ZFS(MZPTS,MZCHF),ZFSP(MZCHF),ZFC(MZPTS,MZCHF)
     1 ,ZFCP(MZCHF),ZFKNU(MZCHF)
      COMMON/AUGER/AAUGER(MZTAR),IAUGER
      COMMON/NRBZED/TZED,LPRTSW
C
      DIMENSION P(MZCHF,MZCHF),Q(MZCHF,MZCHF)
     X         ,POLD(MZCHF,MZCHF),QOLD(MZCHF,MZCHF)
      DIMENSION ZKHICO(MZDEG,MZCHF),ZKHI(MZCHF)
C
      EQUIVALENCE (P,CSP),(Q,CC),(POLD,DSP),(QOLD,DC)
      EQUIVALENCE (ZKHICO,ZKHIOC)
C
C
      IF(IOMSW.LT.0)THEN
        NCC=NCHCL
      ELSE
        NCC=NCHF-NCHOP
        DO N=1,NCC
          ICHCL(N)=NCHOP+N
        ENDDO
      ENDIF
C
      IF(NCC.GT.MZDEG)THEN
        WRITE(6,610)NCC
        STOP 'INCREASE MZDEG'
      ENDIF
C
      xeps=.75
      PI=ACOS(-ONE)
      TPI=TWO*PI
      CONST=TPI
      IF(TZED.GT.TZERO)CONST=TPI/DBLE((NZED-NELC)**2)
      IONE=1
      IF(ELAS.EQ.'YES')IONE=0
C
C INITIALIZE KHICC
C
      DO N2=1,NCC
        DO N1=1,NCC
          ZKHICC(N1,N2)=DCMPLX(P(ICHCL(N1),ICHCL(N2))
     X                        ,Q(ICHCL(N1),ICHCL(N2)))
        ENDDO
      ENDDO
C
C ZKHICC-ZFDEC
C
      ITARGN=0
      DO N=1,NCC
        NNN=ICHCL(N)
C
C RADIATIVE DECAYS; RECALCULATE ARDEC (DEPENDS ON ETOT) IF NECESS.
C
        IF(IRDEC*NEWAR.GT.0.AND..NOT.QDT
     X                     .AND.ITARG(NNN).NE.ITARGN)THEN
          ITARGN=ITARG(NNN)
          KVEC=((ITARG(NNN)-IONE)*(ITARG(NNN)-1-IONE))/2
          ARDEC(ITARG(NNN))=TZERO
          DO JLOOP=1,ITARG(NNN)-1
            KVEC=KVEC+1
            IF(ETOT-(ENAT(ITARG(NNN))-ENAT(JLOOP)).LE.ENAT(1))THEN
              ARDEC(ITARG(NNN))=ARDEC(ITARG(NNN))+ARAD(KVEC)
            ENDIF
          ENDDO
          ARDEC(ITARG(NNN))=ARDEC(ITARG(NNN))*CONST
        ENDIF
C
        IF(TZED.EQ.TZERO)THEN       !BETTER NOT TO ENTER IN FIRST PLACE
          ZFDEC=EXP(BIG)
        ELSE
          TPINU=FKNU(NNN)*TPI
          IF(IOMIT(NNN).LT.0)TPINU=-TPINU
        IF(IRDEC.EQ.0.OR.FKNU(NNN).GT.NCUTOFF
     x    .or. llch(nnn).gt.0.and.fknu(nnn).lt.llch(nnn)+xeps
     X    .OR.(NTYP1.EQ.0.AND.IAUGER.LE.0))THEN
C NONE
          ZFKNU(NNN)=FKNU(NNN)
          ZFDEC=EXP(DCMPLX(TZERO,-TPINU))
        ELSEIF(IRDEC.EQ.1)THEN
C BELL & SEATON
          TR=ONE/FKNU(NNN)**2
          TI=TZERO
          IF(NTYP1.GT.0)TI=-ARDEC(ITARG(NNN))/TPI
          IF(IAUGER.GT.0)TI=TI-AAUGER(ITARG(NNN))    !A.U. HERE
          ZFKNU(NNN)=DCMPLX(ONE,TZERO)/SQRT(DCMPLX(TR,TI))
          T=-TPI*TI*(FKNU(NNN)**3)/TWO
          T=MIN(T,BIG)
          FDEC=EXP(T)
          ZFDEC=FDEC*EXP(DCMPLX(TZERO,-TPINU))
        ELSEIF(IRDEC.EQ.2)THEN
C HICKMAN-ROBICHEAUX
          TR=ONE/FKNU(NNN)**2
          TI=TZERO
          IF(NTYP1.GT.0)TI=-ARDEC(ITARG(NNN))/TPI
          IF(IAUGER.GT.0)TI=TI-AAUGER(ITARG(NNN))    !A.U. HERE
          ZFKNU(NNN)=DCMPLX(ONE,TZERO)/SQRT(DCMPLX(TR,TI))
C         IF(IQDT.EQ.2)THEN
CK          Z=DCMPLX(PI,TZERO)
CK          ZFDEC=-TAN(Z*ZFKNU(NNN))
C         ELSE
            Z=DCMPLX(TZERO,-TPI)*ZFKNU(NNN)
            TR=DBLE(Z)
            TR=MIN(TR,BIG)
            TI=DIMAG(Z)
            Z=DCMPLX(TR,TI)
            IF(IOMIT(NNN).LT.0)Z=-Z       !??
            ZFDEC=EXP(Z)
C         ENDIF
        ENDIF
        ENDIF
C
        ZKHICC(N,N)=ZKHICC(N,N)-ZFDEC
      ENDDO
C
      DO N=1,NCC
        IF(IOMIT(ICHCL(N)).GT.0)ZKHICC(N,N)=ZONE
      ENDDO
C
C INITIALIZE KHICO
C
      DO N2=1,NCHOP
        DO N1=1,NCC
CK          IF(FKNU(ICHCL(N1)).LE.NCUTOFF)THEN
          ZKHICO(N1,N2)=DCMPLX(P(ICHCL(N1),N2),Q(ICHCL(N1),N2))
CK          ELSE
CK            ZKHICO(N1,N2)=TZERO
CK          ENDIF
        ENDDO
      ENDDO
C
CSTRTNBL
CNBL  CALL ZLUS(ZKHICC,MZDEG,NCC,WORK,IERR)
CNBL  IF (IERR.NE.0) THEN
CNBL    WRITE(6,600)
CNBL    STOP 'ERROR IN ZLUS'
CNBL  END IF
CNBL  CALL ZLUBS(ZKHICC,ZKHICO,MZDEG,NCHOP,IERR)
CNBL  IF (IERR.NE.0) THEN
CNBL    WRITE(6,601)
CNBL    STOP 'ERROR IN ZLUBS'
CNBL  END IF
CENDNBL
C
CSTRTBL
      CALL ZSYTRF('L',NCC,ZKHICC,MZDEG,IPIV,ZWORK,MWORK,INFO)
      IF (INFO.NE.0) THEN
         WRITE(6,602) INFO
         STOP 'ERROR IN BLAS ROUTINE ZSYTRF'
      ENDIF
      CALL ZSYTRS('L',NCC,NCHOP,ZKHICC,MZDEG,IPIV,ZKHICO,MZDEG,INFO)
      IF (INFO.NE.0) THEN
         WRITE(6,603) INFO
         STOP 'ERROR IN BLAS ROUTINE ZSYTRS'
      ENDIF
CENDBL
C
C
C CLOSE-OFF ALL OPEN CHANNELS IF THERE IS TO BE NO SUBSEQUENT CALL
C TO SQDT
C
      IF(.NOT.QDT)THEN
C
C INITIALIZE DR PROBABILITY
C
      DO I=1,NCHOP
        PDR(I)=ONE
      ENDDO
C
C FORM PHYSICAL S-MATRIX
C
      DO J=1,NCHOP
        DO I=1,J
          ZKHI(I)=DCMPLX(P(I,J),Q(I,J))
        ENDDO
        DO K=1,NCC
CK            IF(FKNU(ICHCL(K)).LE.NCUTOFF)
          DO I=1,J
            ZKHI(I)=ZKHI(I)-
     X              DCMPLX(P(I,ICHCL(K)),Q(I,ICHCL(K)))*ZKHICO(K,J)
          ENDDO
        ENDDO
        DO I=1,J
          PP=ZKHI(I)*CONJG(ZKHI(I))
          PDR(J)=PDR(J)-PP
          PDR(I)=PDR(I)-PP
          IF(I.EQ.J)THEN
            PDR(I)=PDR(I)+PP
            ZKHI(I)=ZKHI(I)-DCMPLX(ONE,TZERO)
          ENDIF
          RK(I,J)=ZKHI(I)*CONJG(ZKHI(I))
        ENDDO
      ENDDO
C
C SYMMETRIZE AND ADJUST WEIGHTING
C
      T=QUART*NWT
      DO J=1,NCHOP
        PDR(J)=PDR(J)*T
        DO I=1,J
          RK(I,J)=T*RK(I,J)
          RK(J,I)=RK(I,J)
        ENDDO
      ENDDO
C
C DETERMINE PHYSICAL DIPOLE MATRIX FOR PARTIAL PHOTORECOMBINATION/IONIZATION
C
      IF(NDEC0.GT.0)THEN
        IF(IPHOTO.GE.1000)CALL PIABSS
        IPHOTO0=MOD(IPHOTO,1000)
        IF(IPHOTO0.NE.0)THEN
          DO J=1,NCHOP
            DO K=1,NCC
              DO I=1,NDEC0
                ZDIP(I,J)=ZDIP(I,J)-ZDIP(I,ICHCL(K))*ZKHICO(K,J)
              ENDDO
            ENDDO
          ENDDO
        ENDIF
      ENDIF
C
C
      ELSE
C
C STORE ORIGINAL P,Q
C
      DO J=1,NCHF
        DO I=1,NCHF
          POLD(I,J)=P(I,J)
          QOLD(I,J)=Q(I,J)
        ENDDO
      ENDDO
C
C NOW JUST CONTRACT
C
      DO J=1,NCHOP
        DO I=1,J
          ZKHI(I)=DCMPLX(POLD(I,J),QOLD(I,J))
        ENDDO
        DO K=1,NCC
CK            IF(FKNU(NCHOP+K).LE.NCUTOFF)THEN
          DO I=1,J
            ZKHI(I)=ZKHI(I)-
     X           DCMPLX(POLD(I,ICHCL(K)),QOLD(I,ICHCL(K)))*ZKHICO(K,J)
          ENDDO
CK            ENDIF
        ENDDO
        DO I=1,J
          P(I,J)=DBLE(ZKHI(I))
          P(J,I)=P(I,J)
          Q(I,J)=DIMAG(ZKHI(I))
          Q(J,I)=Q(I,J)
        ENDDO
      ENDDO
C
      ENDIF
C
      RETURN
  600 FORMAT(' SR.MQDTS: ZLUS RETURNED WITH INFO =',I6)
  601 FORMAT(' SR.MQDTS: ZLUBS RETURNED WITH INFO =',I6)
  602 FORMAT(//10X,10('*'),' SR. MQDTS: ZSYTRF RETURNED WITH INFO =',I6)
  603 FORMAT(//10X,10('*'),' SR. MQDTS: ZSYTRS RETURNED WITH INFO =',I6)
  610 FORMAT(//10X,10('*'),' SR. MQDTS: NUMBER OF MQDT CLOSED',
     X ' CHANNELS, NCC = ',I4/20X,' LARGER THAN DIMENSION',
     X ' VALUE OF DEG = MZDEG'//)
      END
C***************************************************************
C
      SUBROUTINE NUMS(E,C,R1,HP,N1,N2,F,FP,FST)
C
C  NUMEROV INTEGRATION OF COULOMB FUNCTION F.
C  INTEGRATION FROM POINT N1 TO N2.
C  INTERVAL HP IS POSITIVE.
C  INPUT FUNCTIONS F,FP AT N1 WHERE FP IS R-DERIVATIVE.
C  OUTPUT FUNCTIONS F,FP AT N2  AND
C  INTERMEDIATE POINTS STORED IN FST(I) FOR I.LE. MZPTS
CNRB
C  NEUTRAL CASE ADDED
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
      PARAMETER (THREE=3.0)
      PARAMETER (FOUR=4.0)
      PARAMETER (SIX=6.0)
      PARAMETER (SEVEN=7.0)
      PARAMETER (TEN=10.0)
      PARAMETER (TWELVE=12.0)
      PARAMETER (P1=ONE/30.)
      PARAMETER (P2=ONE/40.)
      PARAMETER (P3=SEVEN/15.)
      PARAMETER (P4=TWO/15.)
      PARAMETER (P5=ONE/360.)
      PARAMETER (P6=ONE/20.)
      PARAMETER (P7=ONE/120.)
      PARAMETER (P8=ONE/TWELVE)
C
      COMMON/NRBZED/TZED,LPRTSW
      DIMENSION FST(MZPTS)
C
      V(X)=EQ+X*(Q2*TZED-X*CQ)
C
      N21=N2-N1
C
      F1=F
      F1P=FP
      IF(N1.LE.MZPTS)FST(N1)=F1
      IF(N21.EQ.0)RETURN
C
      IP=IABS(N21)
      INC=N21/IP
      H=HP*INC
      K=N1
      IP=IP-1
C
C  FUNCTIONS AT K=(N1+INC)
C
      Q=H*H
      EQ=E*Q
      Q2=TWO*Q
      CQ=C*Q
C
      X1=ONE/R1
      CX=C*X1
      HX=H*X1
      A1=-TWO*HX*HX*H
      U1P=A1*(ONE*tzed-CX)
      A1=-A1*HX
      U1PP=A1*(TWO*tzed-THREE*CX)
      A1=-A1*HX*SIX
      U1PPP=A1*(ONE*tzed-TWO*CX)
      U1=V(X1)
C
      R2=R1+H
      X2=ONE/R2
      U2=V(X2)
C
      A2=ONE+U2*P1
      B1=ONE+U1*(P2*U1-P3)-P4*U1P-P2*U1PP
     1 +P5*(FOUR*U1*U1P-U1PPP)
      C1=H*(ONE+U1*(P5*U1-P4)
     1 -P6*U1P-P7*U1PP)
C
      F2=(B1*F1+C1*F1P)/A2
      K=K+INC
      IF(K.LE.MZPTS)FST(K)=F2
C
C
      U3=U2
      U2=U1
      F3=F2
      F2=F1
      X3=X2
      IF(IP.EQ.0)GOTO 20
C
C  CONTINUE INTEGRATION
C
      EQ=EQ*P8
      Q2=Q2*P8
      CQ=CQ*P8
      U2=U2*P8
      U3=U3*P8
      R3=R2
C
      DO M=1,IP
        U1=U2
        U2=U3
        F1=F2
        F2=F3
        R3=R3+H
        X3=ONE/R3
        U3=V(X3)
        D3=ONE/(ONE+U3)
        D2=(TWO-TEN*U2)*D3
        D1=(ONE+U1)*D3
        F3=D2*F2-D1*F1
        K=K+INC
        IF(K.LE.MZPTS)FST(K)=F3
      ENDDO
C
      U2=TWELVE*U2
      U3=TWELVE*U3
      EQ=TWELVE*EQ
      Q2=TWELVE*Q2
      CQ=TWELVE*CQ
C
C  CALCULATE FINAL DERIVATIVE
C
   20 H=-H
      CX=C*X3
      HX=H*X3
      A1=-TWO*HX*HX*H
      U3P=A1*(tzed*ONE-CX)
      A1=-A1*HX
      U3PP=A1*(tzed*TWO-THREE*CX)
      A1=-A1*HX*SIX
      U3PPP=A1*(tzed*ONE-TWO*CX)
      A2=ONE+U2*P1
      B3=ONE+U3*(P2*U3-P3)-P4*U3P-P2*U3PP
     1 +P5*(FOUR*U3*U3P-U3PPP)
      C3=H*(ONE+U3*(P5*U3-P4)-P6*U3P
     1 -P7*U3PP)
      F3P=(A2*F2-B3*F3)/C3
C
      F=F3
      FP=F3P
C
      RETURN
      END
C***************************************************************
C
      SUBROUTINE NUMSC(E,C,R1,HP,N1,N2,SP,CP,I)
C
C NRB:
C  NUMEROV INTEGRATION OF COULOMB FUNCTIONS S AND C.
C  INTEGRATION FROM POINT N1 TO N2.
C  INTERVAL HP IS POSITIVE.
C  I/O FUNCTIONS IN ARRAYS FS,FC
C  I/O DERIVATIVES IN SP,CP (NOT IN ARRAYS)
CNRB
C  NEUTRAL CASE ADDED
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
      PARAMETER (THREE=3.0)
      PARAMETER (FOUR=4.0)
      PARAMETER (SIX=6.0)
      PARAMETER (SEVEN=7.0)
      PARAMETER (TEN=10.0)
      PARAMETER (TWELVE=12.0)
      PARAMETER (P1=ONE/30.)
      PARAMETER (P2=ONE/40.)
      PARAMETER (P3=SEVEN/15.)
      PARAMETER (P4=TWO/15.)
      PARAMETER (P5=ONE/360.)
      PARAMETER (P6=ONE/20.)
      PARAMETER (P7=ONE/120.)
      PARAMETER (P8=ONE/TWELVE)
C
      COMMON/COULSC/FS(MZPTS,MZCHF),FSP(MZCHF),FC(MZPTS,MZCHF)
     1 ,FCP(MZCHF)
      COMMON/NRBZED/TZED,LPRTSW
C
      V(X)=EQ+X*(Q2*TZED-X*CQ)
C
      N21=N2-N1
C
      IF(N21.EQ.0)RETURN
C
      IP=IABS(N21)
      INC=N21/IP
      H=HP*INC
      K=N1
      IP=IP-1
      K0=MIN(K,MZPTS)
C
      F1=FS(K0,I)
      F1P=SP
      G1=FC(K0,I)
      G1P=CP
C
C  FUNCTIONS AT K=(N1+INC)
C
      Q=H*H
      EQ=E*Q
      Q2=TWO*Q
      CQ=C*Q
C
      X1=ONE/R1
      CX=C*X1
      HX=H*X1
      A1=-TWO*HX*HX*H
      U1P=A1*(ONE*tzed-CX)
      A1=-A1*HX
      U1PP=A1*(TWO*tzed-THREE*CX)
      A1=-A1*HX*SIX
      U1PPP=A1*(ONE*tzed-TWO*CX)
      U1=V(X1)
C
      R2=R1+H
      X2=ONE/R2
      U2=V(X2)
C
      A2=ONE+U2*P1
      B1=ONE+U1*(P2*U1-P3)-P4*U1P-P2*U1PP
     1 +P5*(FOUR*U1*U1P-U1PPP)
      C1=H*(ONE+U1*(P5*U1-P4)
     1 -P6*U1P-P7*U1PP)
C
      F2=(B1*F1+C1*F1P)/A2
      G2=(B1*G1+C1*G1P)/A2
      K=K+INC
      IF(K.LE.MZPTS)THEN
        FS(K,I)=F2
        FC(K,I)=G2
      ENDIF
C
      U3=U2
      U2=U1
      F3=F2
      F2=F1
      G3=G2
      G2=G1
      X3=X2
      IF(IP.EQ.0)GOTO 20
C
C  CONTINUE INTEGRATION
C
      EQ=EQ*P8
      Q2=Q2*P8
      CQ=CQ*P8
      U2=U2*P8
      U3=U3*P8
      R3=R2
C
      DO M=1,IP
        U1=U2
        U2=U3
        F1=F2
        F2=F3
        G1=G2
        G2=G3
        R3=R3+H
        X3=ONE/R3
        U3=V(X3)
        D3=ONE/(ONE+U3)
        D2=(TWO-TEN*U2)*D3
        D1=(ONE+U1)*D3
        F3=D2*F2-D1*F1
        G3=D2*G2-D1*G1
        K=K+INC
        IF(K.LE.MZPTS)THEN
          FS(K,I)=F3
          FC(K,I)=G3
        ENDIF
      ENDDO
C
      U2=TWELVE*U2
      U3=TWELVE*U3
      EQ=TWELVE*EQ
      Q2=TWELVE*Q2
      CQ=TWELVE*CQ
C
C  CALCULATE FINAL DERIVATIVE
C
   20 H=-H
      CX=C*X3
      HX=H*X3
      A1=-TWO*HX*HX*H
      U3P=A1*(ONE*tzed-CX)
      A1=-A1*HX
      U3PP=A1*(TWO*tzed-THREE*CX)
      A1=-A1*HX*SIX
      U3PPP=A1*(ONE*tzed-TWO*CX)
      A2=ONE+U2*P1
      B3=ONE+U3*(P2*U3-P3)-P4*U3P-P2*U3PP
     1 +P5*(FOUR*U3*U3P-U3PPP)
      C3=H*(ONE+U3*(P5*U3-P4)-P6*U3P
     1 -P7*U3PP)
      F3P=(A2*F2-B3*F3)/C3
      G3P=(A2*G2-B3*G3)/C3
C
      SP=F3P
      CP=G3P
C
      RETURN
      END
C***************************************************************
C
      SUBROUTINE NUMT(E,C,R1,HP,N1,N2,I)
C
C  NUMEROV INTEGRATION OF COULOMB FUNCTIONS.
C  THE INTERVAL HP IS POSITIVE.
C  INTEGRATION FROM TABULAR POINT N1 TO TABULAR POINT N2.
C  FUNCTIONS THETA,THETP STORED IN ARRAYS FS,FSP
C  FUNCTIONS THETAD,THETADP STORED IN ARRAYS FC,FCP
C  STARTS WITH FUNCTIONS AND DERIVATIVES AT N1 STORED IN FS, FSP, FC, FCP
C  CALCULATES FUNCTIONS AT ALL POINTS TO N2 AND THE DERIVATIVE AT THE
C  POINT N2.
C NRB:
C  MINOR MODS FOR MQDT OPERATION.
C  NEUTRAL CASE ADDED
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
      PARAMETER (THREE=3.0)
      PARAMETER (FOUR=4.0)
      PARAMETER (SIX=6.0)
      PARAMETER (SEVEN=7.0)
      PARAMETER (TEN=10.0)
      PARAMETER (TWELVE=12.0)
      PARAMETER (P1=ONE/30.)
      PARAMETER (P2=ONE/40.)
      PARAMETER (P3=SEVEN/15.)
      PARAMETER (P4=TWO/15.)
      PARAMETER (P5=ONE/360.)
      PARAMETER (P6=ONE/20.)
      PARAMETER (P7=ONE/120.)
      PARAMETER (P8=ONE/TWELVE)
C
      COMMON/COULSC/FS(MZPTS,MZCHF),FSP(MZCHF),FC(MZPTS,MZCHF)
     1 ,FCP(MZCHF)
      COMMON/CTHET/BB(MZCHF,MZTET),BG(MZCHF,MZTET),MSUM(MZCHF)
      COMMON/NRBDD2/FSP2(MZCHF),FCP2(MZCHF),IFDD2
      COMMON/NRBZED/TZED,LPRTSW
C
      V(X)=EQ+X*(Q2*TZED-X*CQ)
C
      N21=ABS(N2)-N1
C
C  RENORMALISE FOR CASE OF N2.EQ.N1
C
      IF(N21.NE.0)GOTO 5
      W=FS(N1,I)*FCP(I)-FSP(I)*FC(N1,I)
      IF(W.le.tzero)then
        if(w.lt.tzero)then
          w1=tzero
        else
          RETURN
        endif
      else
        W1=ONE/SQRT(W)
      endif
      FS(N1,I)=FS(N1,I)*W1
      FC(N1,I)=FC(N1,I)*W1
      FSP(I)=FSP(I)*W1
      FCP(I)=FCP(I)*W1
      FSP2(I)=FSP(I)
      FCP2(I)=FCP(I)
      BB(I,2)=BB(I,2)*W1
      NM=MSUM(I)
      DO M=3,NM
        BB(I,M)=BB(I,M)*W1
        BG(I,M)=BG(I,M)*W1
      ENDDO
      RETURN
C
C  INTEGRATIONS FOR N2.NE.N1
C
   5  IP=IABS(N21)
      IS=N21/IP
      H=HP*IS
      K=N1
      IP=IP-1
C
      F1=FS(N1,I)
      F1P=FSP(I)
      G1=FC(N1,I)
      G1P=FCP(I)
C
C  FUNCTIONS AT K=(N1+IS)
C
      Q=H*H
      EQ=E*Q
      Q2=TWO*Q
      CQ=C*Q
C
C      Q=0.0          !FOR XI SOLUTION
C
      X1=ONE/R1
      CX=C*X1
      HX=H*X1
      A1=-TWO*HX*HX*H
      U1P=A1*(ONE*tzed-CX)
      A1=-A1*HX
      U1PP=A1*(TWO*tzed-THREE*CX)
      A1=-A1*HX*SIX
      U1PPP=A1*(ONE*tzed-TWO*CX)
      U1=V(X1)
C
      R2=R1+H
      X2=ONE/R2
      U2=V(X2)
C
      A2=ONE+U2*P1
      B1=ONE+U1*(P2*U1-P3)-P4*U1P-P2*U1PP
     1 +P5*(FOUR*U1*U1P-U1PPP)
      C1=H*(ONE+U1*(P5*U1-P4)
     1 -P6*U1P-P7*U1PP)
      B2=P1*Q
      D1=Q*(-P3+P2*U1+P5*U1P)    !FOR XI DELETE P2*U1
      E1=H*Q*(-P4+P5*U1)
C
      F2=(B1*F1+C1*F1P)/A2
      G2=(B1*G1+C1*G1P+D1*F1+E1*F1P-B2*F2)/A2
      K=K+IS
      FS(K,I)=F2
      FC(K,I)=G2
C
C
      U3=U2
      U2=U1
      F3=F2
      F2=F1
      G3=G2
      G2=G1
      X3=X2
      IF(IP.EQ.0)GOTO 20
C
C  CONTINUE INTEGRATION
C
      EQ=EQ*P8
      Q2=Q2*P8
      CQ=CQ*P8
      U2=U2*P8
      U3=U3*P8
      Q=Q*P8
      R3=R2
C
      DO M=1,IP
        U1=U2
        U2=U3
        F1=F2
        F2=F3
        G1=G2
        G2=G3
        R3=R3+H
        X3=ONE/R3
        U3=V(X3)
        D3=ONE/(ONE+U3)
        D2=(TWO-TEN*U2)*D3
        D1=(ONE+U1)*D3
        F3=D2*F2-D1*F1
        G3=D2*G2-D1*G1-Q*D3*(F3+TEN*F2+F1)
        K=K+IS
        FC(K,I)=G3
        FS(K,I)=F3
      ENDDO
C
      U2=TWELVE*U2
      U3=TWELVE*U3
      EQ=TWELVE*EQ
      Q2=TWELVE*Q2
      CQ=TWELVE*CQ
      Q=TWELVE*Q
C
C  CALCULATE FINAL DERIVATIVE
C
   20 H=-H
      CX=C*X3
      HX=H*X3
      A1=-TWO*HX*HX*H
      U3P=A1*(ONE*tzed-CX)
      A1=-A1*HX
      U3PP=A1*(TWO*tzed-THREE*CX)
      A1=-A1*HX*SIX
      U3PPP=A1*(ONE*tzed-TWO*CX)
      A2=ONE+U2*P1
      B3=ONE+U3*(P2*U3-P3)-P4*U3P-P2*U3PP
     1 +P5*(FOUR*U3*U3P-U3PPP)
      C3=H*(ONE+U3*(P5*U3-P4)-P6*U3P
     1 -P7*U3PP)
      B2=P1*Q
      D3=Q*(-P3+P2*U3+P5*U3P)     !FOR XI DELETE P2*U3
      E3=H*Q*(-P4+P5*U3)
      F3P=(A2*F2-B3*F3)/C3
      G3P=(A2*G2-B3*G3+B2*F2-D3*F3-E3*F3P)/C3
C
C  RE-NORMALISE CLOSED-CHANNEL FUNCTIONS
C
      IF(N1.GT.ABS(N2))THEN
        AMAX=ONE/MAX(ABS(F3),ABS(G3),ABS(F3P),ABS(G3P))
        AF3=F3*AMAX
        AG3=G3*AMAX
        AF3P=F3P*AMAX
        AG3P=G3P*AMAX
        W1=AF3*AG3P-AF3P*AG3
        if(w1.le.tzero)then
          w1=tzero
        else
          W1=AMAX/SQRT(W1)
        endif
        FSP2(I)=FSP(I)*W1
        FCP2(I)=FCP(I)*W1
        FSP(I)=F3P*W1
        FCP(I)=G3P*W1
      ELSE
        FSP2(I)=F3P
        FCP2(I)=G3P
        RETURN
      ENDIF
      IPMX=IP+2
      IF(N2.LT.0)IPMX=MZPTS
      DO J=1,IPMX
        FS(J,I)=FS(J,I)*W1
        FC(J,I)=FC(J,I)*W1
      ENDDO
C
C  RE-NORMALISE COEFFICIENTS
C
      BB(I,2)=BB(I,2)*W1
      NM=MSUM(I)
      DO M=3,NM
        BB(I,M)=BB(I,M)*W1
        BG(I,M)=BG(I,M)*W1
      ENDDO
C
      RETURN
      END
C***************************************************************
C
      SUBROUTINE OCINT(IOMTT,NCHOP)
C
C
C  OPEN-CLOSED:
C  CALCULATES S INTEGRALS USING LAGUERRE QUADRATURE
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      LOGICAL QDT
C
      INCLUDE 'PARAM'
C
      COMMON/CALP/ASS(MZCHF,MZCHF),ASC(MZCHF,MZCHF),ACS(MZCHF,MZCHF)
     1 ,ACC(MZCHF,MZCHF)
      COMMON/CPOT/BW(MZCHF,MZCHF),LAMP(MZCHF,MZCHF)
      COMMON/CBLK/XLAG(30),WLAG(30),XLEG(15),WLEG(15)
      COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF)
     X  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHPP,NCHPP1
      COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC
      COMMON/CQDT/R2ST(MZCHF),QDT,NQ
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/NRBLMX/LMX
C
      DIMENSION ZAI(30),ZPI(30),ZTAJ(30),ZTDAJ(30),ZTPJ(30),ZR(30)
     X,IOMTT(MZCHF)
C
C
      NCHOP1=NCHOP+1
C
      X=RTWO
      B=SQRT(2.*X)
      ZB=(0.,1.)/B
      DO I=1,NCHOP
        IF(IOMTT(I).EQ.0)THEN
        DO J=NCHOP1,NCHF
          IF(IOMTT(J).EQ.0)THEN
          LIJ=LAMP(J,I)
          IF(LIJ.NE.1.AND.LIJ.LE.LMX+1) THEN
            BIJ=BW(J,I)
            NLAG=2*LIJ+LACC
            NLAG=MIN(NLAG,10)
            ZFK=DCMPLX(FKNU(I),1./FKNU(J))
            ZG=.5*ZFK*B
C
            ZA1=1./ZG
            ZA2=1.+ZG
            ZA2=ZA2*ZA2
            ZA3=ZB*ZG
C
            NS=NLAG/2
            M=NS*(NS-1)
            N1=M+1
            N2=M+NLAG
            NP = 0
            DO N=N1,N2
              NP = NP + 1
              U=XLAG(N)
              ZET=ZA1*(SQRT(ZA2+ZA3*U)-1.)
              ZMUM=-.5*ZET/(ZB*(1.+ZET*ZG))
              ZET=ZET*ZET
              ZR(NP)=ZET*X
            ENDDO
            CALL ZPHIN(I,ZR,N1,N2,ZAI,ZPI)
            CALL ZTHETAS(J,ZA1,ZA2,ZA3,ZB,ZG,N1,N2,ZTAJ,ZTDAJ,ZTPJ)
C
            ZS3=0.
            ZSD3=0.
            NP = 0
            DO N=N1,N2
              NP = NP + 1
              U=XLAG(N)
              ZET=ZA1*(SQRT(ZA2+ZA3*U)-1.)
              ZMUM=-.5*ZET/(ZB*(1.+ZET*ZG))
              ZB1=(ZR(NP)**(-LIJ))*WLAG(N)*ZMUM*
     X          EXP((0.,1.)*ZPI(NP)+ZTPJ(NP)+U)*ZAI(NP)
              ZS3=ZS3+ZB1*ZTAJ(NP)
              ZSD3=ZSD3+ZB1*ZTDAJ(NP)
            ENDDO
            ZS3=ZS3*BIJ
            ZSD3=ZSD3*BIJ
            ACC(J,I)=ACC(J,I)+DBLE(ZSD3)
            ACS(J,I)=ACS(J,I)+DIMAG(ZSD3)
            ASC(J,I)=ASC(J,I)+DBLE(ZS3)
            ASS(J,I)=ASS(J,I)+DIMAG(ZS3)
          ENDIF
          ENDIF
        ENDDO
        ENDIF
      ENDDO
      RETURN
      END
C***************************************************************
C
      SUBROUTINE OMEG(IE,EMESH,MXE,ENAT,NAST,OMEGA,NOMWRT,IONE)
C
C   USE MEMORY FOR SUMMING OMEGA, WITH OVERFLOW ONTO DISK
C   (ADAPTED BY NRB, FROM KAB, FOR ELASTIC TRANSITIONS
C    AND USE OF NOMT=ABS(NOMWRT) TO REDUCE I/O)
C   IE = 0 TO INITIALIZE
C   IE .GT.0 TO RETRIEVE OMEGA FOR ENERGY IE
C   IF NOMWRT .LT. 0 THEN RECOVER -NOMWRT NON-ZERO OMEGAS FOR
C                    FINAL WRITE RUNNING DOWN THE COLUMNS
C   IF NOMWRT .GT. 0 THEN RECOVER NOMWRT OMEGAS (INC ZEROES) FOR
C                    FINAL WRITE RUNNING ALONG THE ROWS
C          (EXC ZEROES CAN BE IMPLEMENTED BY SWITCHING JJJJ BELOW)
C   EMESH(MXE)  = ENERGY MESH
C   ENAT(NAST)  = EXCITATION THRESHOLDS: NEEDED TO MINIMISE STORAGE
C   OMEGA(NOMT)= RETURNS OMEGA MATRIX AS AN ARRAY
C   /MEMORY/ STORAGE IN OMEM(MXOM)
C   MPOS(IE)    = LAST POSITION OCCUPIED IN OMEM AT ENERGY IE, OR
C   IF MPOS.LT.0 = -RECORD NUMBER ON DA SCRATCH FILE
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (TZERO=0.0)
C
      PARAMETER (MZKIL=  0)
C
      PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2)
      PARAMETER (MXOM=MZMEG*1000000+MZKIL*1000)
C
      COMMON/MEMORY/OMEM(MXOM+1),MPOS(0:MZMSH),ITMAX,JTMAX
      COMMON/NRBTOP/ITST(MXTST),JTST(MXTST),KTST(MZTAR,MZTAR)
     X             ,OMST(MXTST),ITOP
C
      DIMENSION EMESH(MXE),ENAT(NAST),OMEGA(MXTST)
C
      NOMT=ABS(NOMWRT)
      N=0
      IF(NOMWRT.GT.0)THEN
        DO I=1,NAST
          DO J=I+IONE,NAST
            N=N+1
            OMEGA(N)=TZERO
          ENDDO
          IF(N.GE.NOMT)GO TO 20
        ENDDO
        I=NAST
      ENDIF
      IF(NOMWRT.LT.0)THEN
        DO J=1+IONE,NAST
          DO I=1,J-IONE
            N=N+1
            OMEGA(N)=TZERO
          ENDDO
          IF(N.GE.NOMT)GO TO 20
        ENDDO
        J=NAST
      ENDIF
C
C   INITIALISE
C
   20 IF(IE.EQ.0) THEN
        IF(NOMWRT.GT.0)THEN
          ITMAX=I
          JTMAX=NAST
        ELSE
          ITMAX=NAST
          JTMAX=J
        ENDIF
        MPOS(0)=0
        NPOS=0
        NREC=0
        NST=1
        DO I=1,MXE
    4     IF(NST.LE.NAST)THEN
            IF(EMESH(I).GE.ENAT(NST)) THEN
              NP=MIN(NST,ITMAX,JTMAX)
              NTRAN=(NP*(NP+1-2*IONE))/2
              IF(NST.GT.ITMAX)NTRAN=NTRAN+(NST-ITMAX)*ITMAX
              NST=NST+1
              GO TO 4
            ENDIF
          ENDIF
          NPOS=NPOS+NTRAN
          IF(NPOS.LE.MXOM) THEN
            MPOS(I)=NPOS
          ELSE
            NREC=NREC+1
            MPOS(I)=-NREC
          ENDIF
        ENDDO
C
        MMM=MIN(NPOS,MXOM)
        DO N=1,MMM
          OMEM(N)=TZERO
        ENDDO
C
        IF(NREC.GT.0) THEN
          MMEG=NPOS/1000000
          MMEG=MMEG+1
          NPOS=MXOM
          WRITE(6,100)MMEG
          NLEN=MIN(NOMT,(NAST*(NAST+1-2*IONE))/2)
          OPEN(1,STATUS='SCRATCH',ACCESS='DIRECT',RECL=MZREC*NLEN,
     X         FORM='UNFORMATTED')
          DO MREC=1,NREC
            CALL OMWRIT(OMEGA,NLEN,MREC)
          ENDDO
        ENDIF
C
        WRITE(6,101)MXOM,NPOS
C
      ELSE
C
C   FINALLY, RETRIEVE AND RETURN OMEGA
C
        IF(MPOS(IE).EQ.0) THEN
          DO N=1,NOMT
            OMEGA(N)=TZERO
          ENDDO
          GO TO 25
        ENDIF
C
        JJJJ=NAST                !INC ZEROES NOMWRT.GT.0
C        JJJJ=JTMAX               !EXC ZEROES NOMWRT.GT.0
C
        IF(MPOS(IE).GT.0) THEN
          M=MPOS(IE-1)
          K=0
          DO JT=1+IONE,JJJJ
            IP=MIN(JT-IONE,ITMAX)
            DO IT=1,IP
              M=M+1
              IF(NOMWRT.GT.0)THEN
                K=JT+1-IONE+(JJJJ+1-IONE)*(IT-1)-(IT*(IT+1))/2
              ELSE
                K=K+1
              ENDIF
              OMEGA(K)=OMEM(M)
            ENDDO
            IF(M.GE.MPOS(IE)) GO TO 25
          ENDDO
        ELSE
          MREC=-MPOS(IE)
          CALL OMREAD(OMEGA,NOMT,MREC)
          IF(NOMWRT.GT.0)THEN
            DO I=1,NOMT
              OMST(I)=OMEGA(I)
            ENDDO
            M=0
            DO JT=1+IONE,JJJJ
              IP=MIN(JT-IONE,ITMAX)
              DO IT=1,IP
                M=M+1
                K=JT+1-IONE+(JJJJ+1-IONE)*(IT-1)-(IT*(IT+1))/2
                OMEGA(K)=OMST(M)
              ENDDO
              IF(M.GE.NOMT) GO TO 25
            ENDDO
          ENDIF
        ENDIF
      ENDIF
C
C
   25 RETURN
C
  100     FORMAT(//' ****OPENING SCRATCH FILE, COULD AVOID'
     X    ,' BY INCREASING MZMEG TO:',I4//)
  101   FORMAT(//' MXOM =', I9,'  USED =',I9//)
      END
C
C************************************************************************
      SUBROUTINE OMREAD(OMEGA,NOMT,IE)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION OMEGA(NOMT)
C
      READ(1,REC=IE)OMEGA
C
      RETURN
      END
C************************************************************************
      SUBROUTINE OMWRIT(OMEGA,NOMT,IE)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION OMEGA(NOMT)
C
      WRITE(1,REC=IE)OMEGA
C
      RETURN
      END
C***************************************************************
C
      SUBROUTINE OOINT(IOMTT,NCHOP)
C
C
C OPEN-OPEN:
C  CALCULATES P AND Q INTEGRALS USING LAGUERRE AND/OR LEGENDRE QUADRATURE
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      LOGICAL QDT
C
      INCLUDE 'PARAM'
C
      COMMON/CALP/ASS(MZCHF,MZCHF),ASC(MZCHF,MZCHF),ACS(MZCHF,MZCHF)
     1 ,ACC(MZCHF,MZCHF)
      COMMON/CPOT/BW(MZCHF,MZCHF),LAMP(MZCHF,MZCHF)
      COMMON/CBLK/XLAG(30),WLAG(30),XLEG(15),WLEG(15)
      COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF)
     X  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHPP,NCHPP1
      COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC
      COMMON/CQDT/R2ST(MZCHF),QDT,NQ
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/NRBLMX/LMX
C
      DIMENSION ZAI(30),ZPI(30),ZAJ(30),ZPJ(30),ZR(30)
      DIMENSION ZAI1(30),ZPI1(30),ZAJ1(30),ZPJ1(30),ZR1(30)
      DIMENSION ZAI2(30),ZPI2(30),ZAJ2(30),ZPJ2(30),ZR2(30)
      DIMENSION IOMTT(MZCHF)
C
C
      NCHOP1=NCHOP+1
C
      X=RTWO
      B=SQRT(8.*X)
      ZB=(0.,1.)/B
      DO I=1,NCHOP
        IF(IOMTT(I).EQ.0)THEN
        DO J=I,NCHOP
          IF(IOMTT(J).EQ.0)THEN
          LIJ=LAMP(J,I)
          IF(LIJ.NE.1.AND.LIJ.LE.LMX+1) THEN
            NLAG=2*LIJ+LACC
            NLAG=MIN(NLAG,10)
            BIJ=BW(J,I)
            NS=NLAG/2
            M=NS*(NS-1)
            N1=M+1
            N2=M+NLAG
C
            FK=FKNU(I)+FKNU(J)
            G=FK*.125*B
            IF(FK.GT.0)THEN
              GM=1./G
              G2=1.+G
              G2=G2*G2
            ENDIF
            NP = 0
            DO N=N1,N2
              NP = NP + 1
              U=XLAG(N)
              A1=FK*U
              IF(A1.LE.ACZP)THEN
                ZET=1.+.5*ZB*U
              ELSE
                ZET=(SQRT(G2+ZB*G*U)-1.)*GM
              ENDIF
              ZMU=-8.*ZB*(G+1./ZET)
              ZET=ZET*ZET
              ZR(NP)=ZET*X
            ENDDO
            CALL ZPHIN(I,ZR,N1,N2,ZAI,ZPI)
            CALL ZPHIN(J,ZR,N1,N2,ZAJ,ZPJ)
            NP = 0
            ZP3= 0.
            DO N=N1,N2
              NP = NP + 1
              U=XLAG(N)
              A1=FK*U
              IF(A1.LE.ACZP)THEN
                ZET=1.+.5*ZB*U
              ELSE
                ZET=(SQRT(G2+ZB*G*U)-1.)*GM
              ENDIF
              ZMU=-8.*ZB*(G+1./ZET)
              ZP3=ZP3+ZAI(NP)*ZAJ(NP)*
     X          EXP((0.,1.)*(ZPI(NP)+ZPJ(NP))+U)*
     X          (ZR(NP)**(-LIJ))*WLAG(N)/ZMU
            ENDDO
            ZP3 = ZP3*BIJ
            ALP=RTWO*(FKNU(I)-FKNU(J))
            IF(ALP.GE.2.) THEN
              FK=FKNU(I)-FKNU(J)
              ZMUM=(0.,1.)/FK
C
              NP = 0
C
              DO N=N1,N2
                NP = NP + 1
                U=XLAG(N)
                ZR(NP)=X+U*ZMUM
              ENDDO
              CALL ZPHIN(I,ZR,N1,N2,ZAI,ZPI)
              CALL ZPHIN(J,ZR,N1,N2,ZAJ,ZPJ)
              ZQ3=0.
              NP = 0
              DO N=N1,N2
                NP = NP + 1
                U=XLAG(N)
                ZQ3=ZQ3+ZAI(NP)*ZAJ(NP)*
     X            EXP((0.,1.)*(ZPI(NP)-ZPJ(NP))+U)*
     X            (ZR(NP)**(-LIJ))*WLAG(N)
              ENDDO
              ZQ3=ZQ3*ZMUM*BIJ
            ELSE
              FK=FKNU(I)-FKNU(J)
              IF(FK.EQ.0.)THEN
                ZA=1.
              ELSE
                ZA=(0.,1.)/(1.+FK*X)
              ENDIF
C
              NS=NLAG/2
              J1=(NS*(NS-1))/2
              J2=J1+NS
              J1=J1+1
              JP = 0
              DO JJ=J1,J2
                JP = JP + 1
                V=XLEG(JJ)
                ZR1(JP)=X*(1.+ZA*(1.-V)/(1.+V))
                ZR2(JP)=X*(1.+ZA*(1.+V)/(1.-V))
              ENDDO
              CALL ZPHIN(I,ZR1,J1,J2,ZAI1,ZPI1)
              CALL ZPHIN(J,ZR1,J1,J2,ZAJ1,ZPJ1)
              CALL ZPHIN(I,ZR2,J1,J2,ZAI2,ZPI2)
              CALL ZPHIN(J,ZR2,J1,J2,ZAJ2,ZPJ2)
C
              ZQ3=0.
              JP = 0
              DO JJ=J1,J2
                JP = JP + 1
                V=XLEG(JJ)
                ZF=ZAI1(JP)*ZAJ1(JP)*
     X            EXP((0.,1.)*(ZPI1(JP)-ZPJ1(JP)))*
     X            (ZR1(JP)**(-LIJ))/(1.+V)**2
                ZF=ZF+ZAI2(JP)*ZAJ2(JP)*
     X            EXP((0.,1.)*(ZPI2(JP)-ZPJ2(JP)))*
     X            (ZR2(JP)**(-LIJ))/(1.-V)**2
                ZQ3=ZQ3+ZF*WLEG(JJ)
              ENDDO
              ZQ3=2.*X*ZA*ZQ3*BIJ
            ENDIF
            ASS(J,I)=ASS(J,I)+.5*DBLE(ZQ3-ZP3)
            ACS(J,I)=ACS(J,I)+.5*DIMAG(ZP3+ZQ3)
            ASC(J,I)=ASC(J,I)+.5*DIMAG(ZP3-ZQ3)
            ACC(J,I)=ACC(J,I)+.5*DBLE(ZP3+ZQ3)
          ENDIF
          ENDIF
        ENDDO
        ENDIF
      ENDDO
C
      RETURN
      END
C***************************************************************
C
      SUBROUTINE OUTJJ(IOPT1,LRGLAM,MXE)
C
C    TO SUPPLY NON-K-MATRIX DATA FOR JAJOM ON UNITS 22,23 (FORMATTED).
C
C    IOPT1=0 FOR INITIALISATION, FOR EACH S L PI SYMMETRY
C        =10 FOR JAJOM WITH ALGEBRAIC RECOUPLING WITHOUT,(WITH TOP-UP)
C        =12 FOR JAJOM WITH TERM COUPLING (COUPLING COEFFS READ IN STGF)
C    LRGLAM .GT. 0 FOR TOP-UP
C    MXE = TOTAL NUMBER OF ENERGIES, HELD IN /CMESH/
C    /CINPUT/ CONTAINS BASIC COLLISION DATA.
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2)
C
      PARAMETER(JOUT=22,IOJM=5,NOX=0,IFACT=60,NTC=MZTAR*MZTAR)
C
      CHARACTER*1 PARITY(0:1),LSPECT(0:6)
C
      COMMON/CDEC/ARAD(MXTST),ARDEC(MZTAR),SLIN(MXTST),IRDEC,IEND
     X           ,IPAR(MZTAR),NEWAR
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/CMESH/EMAX,EMIN,DEOPEN,DQN,QNMAX,EMESH(MZMSH),IMESH
C
      DIMENSION ILT(MZSLP),IST(MZSLP)
      DIMENSION FJ(MZLP1)
CTCC      DIMENSION IDF(NTC),ITF(NTC),FCF(NTC)
C
      DATA LSPECT/'S','P','D','F','G','H','I'/, PARITY/'e','o'/
      DATA J2F,N2F/2*0/
      DATA ISLM/0/, KCOUNT/0/
C
      SAVE ISLM,KCOUNT,ILT,IST
C
      AZ=MAX(NZED-NELC,1)
      AZAZ=AZ*AZ
C
C  INITIALIZE ...
C  ISLM = COUNTER ON ILT,IST SYMMETRIES
C  KCOUNT = COUNTER ON MATRIX ELEMENTS OUTPUT ON UNIT 11
C  IPAR(NAST) = TARGET PARITIES
C
      IF(IOPT1.EQ.0) THEN
        DO 1 I=1,ISLM
          IF(LRGL2.EQ.ILT(I).AND.NSPN2.EQ.IST(I)) GO TO 2
    1   CONTINUE
        ISLM=ISLM+1
        ILT(ISLM)=LRGL2
        IST(ISLM)=NSPN2
    2   N=1
        NCHOP=0
        D=0.0
        IF(IMESH.EQ.2) D=1./QNMAX**2
        DO 5 I=1,MXE
    4     IF(EMESH(I).GT.ENAT(N)-D.AND.N.LT.NAST) THEN
            N=N+1
            NCHOP=NCHOP+NCONAT(N)
            NUM=NCHOP*(NCHOP+1)
            GO TO 4
          ENDIF
          KCOUNT=KCOUNT+NUM
    5   CONTINUE
        RETURN
      ENDIF
C
C    OPEN UNITS JOUT(=22),23,25
C
      IF(MXE.EQ.0.OR.ISLM.EQ.0.OR.KCOUNT.EQ.0) GO TO 42
C
      OPEN(JOUT,FILE='JJDAT',STATUS='UNKNOWN')
      REWIND(JOUT)
C
CSPEC NOT NEEDED BY CURRENT IP JAJOM AND THIS STGF
CSPEC      OPEN(23,FILE='JOMSPECS',STATUS='UNKNOWN')
CSPEC      REWIND(23)
C
CTCC READ DIRECTLY FROM TCC.DAT IN JAJOM
CTCC      OPEN(25,FILE='TCC.DAT',STATUS='UNKNOWN')
CTCC      REWIND(25)
C
C    FIND NAOP = NUMBER OF STATES ENERGETICALLY ALLOWED;
C         MNSPN,MXSPN = MINIMUM,MAXIMUM TARGET STATE 2S+1;
C         JCHAN= NUMBER OF CHANNELS IN INTERMEDIATE COUPLING.
C
      JCHAN=0
      NAOP=0
      MNSPN=999
      MXSPN=0
      DELE=0.
      IF (IMESH.EQ.2) DELE=1/(QNMAX*QNMAX)
      DO 9 I=1,NAST
       IF(EMESH(MXE).LT.ENAT(I)-DELE) GO TO 6
       NAOP=I
       MNSPN=MIN(MNSPN,ISAT(I))
       MXSPN=MAX(MXSPN,ISAT(I))
       K=2*LAT(I)+1
       JHIGH=K+ISAT(I)-1
       JLOW=ABS(K-ISAT(I))+1
    9  JCHAN=JCHAN + ((JHIGH+JLOW)/2) * (1+(JHIGH-JLOW)/2)
C
C    WRITE OUT JAJOM INPUT
C    CARDS A1-A2
C
    6 IF(NAOP.EQ.0) GO TO 42
      IREFL=1
      ITOP=0
      IF(LRGLAM.GT.0) ITOP=1
      MAT=2
      IONQ=NZED-NELC
      IPART=0
      K=NAOP
      IF(IRDEC.GT.0) K=1
      DO 7 I=1,K
    7  ARDEC(I)=0.0
      WRITE(JOUT,'(2X,I2,2I3,10I5)')
     *      NZED,NELC,NAOP,IREFL,8,7,ITOP,MAT,IONQ,IPART,IRDEC,IMESH
      DO 8 I=1,NAOP
       K=ISAT(I)
       IF(IPAR(I).EQ.1) K=-K
    8  WRITE(JOUT,1002) I, K,LAT(I),ENAT(I)*AZAZ,
     *       ISAT(I),LSPECT(LAT(I)),PARITY(IPAR(I)),ARDEC(I)
C
C    CARDS B1-B4
C
      WRITE(JOUT,1004) IMESH,DEOPEN,QNMAX,DQN,'CHI',IOPT1,
     *LRANG2,ISLM,NOX,(I,I=0,LRANG2-1)
      WRITE(JOUT,'(18I4)') (IST(I),ILT(I),I=1,ISLM)
C
C    CARDS C1-C4
C
      WRITE(JOUT,2003) NZED,NELC,RA,LAMAX,KCOUNT,
     *      MXE,MXE
      IF(IMESH.EQ.1)THEN
        DE=EMESH(2)-EMESH(1)
        WRITE(JOUT,2004)1,EMESH(1)*AZAZ,0,DE*AZAZ
      ELSE
        WRITE(JOUT,2004)(K,EMESH(K)*AZAZ,K=1,MXE)
      ENDIF
      WRITE(JOUT,2005) EMESH(MXE)*AZAZ
C
C    FIND ALLOWED TOTAL J VALUES (FJ(JJFSL))
C
      JJFSL=0
      J2=MOD(MNSPN,2)
   22 IZ=MNSPN
      IF(IZ.EQ.2) IZ=0
   23 L2=ABS(J2-IZ)
   24 DO 25 I=1,ISLM
      IF(IZ.EQ.IST(I)-1 .AND.L2.EQ.2*ILT(I)) GO TO 26
   25 CONTINUE
      GO TO 27
   26 L2=L2+2
      IF(L2.LE.J2+IZ) GO TO 24
      IZ=IZ+2
      IF(IZ.LE.MXSPN) GO TO 23
      JJFSL=JJFSL+1
      FJ(JJFSL)=0.5*J2
      J2=J2+2
      GO TO 22
C
C    CARDS E1-E2
C
   27 IFIT=JJFSL+1
      JPUN=NAOP+1
      WRITE(JOUT,'(5H F.S.,2I5,I3)') JJFSL,IFIT,JPUN
      IF(JJFSL.EQ.0) THEN
      WRITE(6,*)' NO J VALUES -- SYMMETRIES SLPI INCOMPLETE'
      GO TO 41
      ENDIF
      WRITE(JOUT,'(7X,13F5.1)') (FJ(J),J=1,JJFSL)
C
CTCC    CARDS F1-F2: TERM COUPLING COEFFICIENTS TO BE READ BY JAJOM
C       ELSE LET JAJOM READ DIRECTLY FROM TCC.DAT FILE.
C
       WRITE(6,*)
C      BUT SKIP TERM LIST
CTCC       READ(25,*,END=32) NTER
CTCC       IF(NTER.GT.0) READ(25,'(I4)') (K,I=1,NTER)
CTCC   31   READ(25,1106)J2F,N2F
CTCC   32   CONTINUE
C
        WRITE(JOUT,1106) J2F,N2F
C
CTCC        IF (N2F.EQ.0) GO TO 33
CTCC        READ(25,1107) (ITF(I),IDF(I),FCF(I),I=1,N2F)
CTCC        WRITE(JOUT,1107) (ITF(I),IDF(I),FCF(I),I=1,N2F)
CTCC        WRITE(6,1108)N2F,J2F
CTCC        GO TO 31
CTCC   33 CONTINUE
C
      WRITE(JOUT,1106) NOX,NOX
   41 WRITE(JOUT,'("ENDDATA")')
C
C     FINALISE OUTPUT TO JAJOM, WRITE PROCESSOR DATA FOR JAJOM ONTO 23
CSPEC ONLY NEEDED BY JAJOM NOT SETUP TO READ CHI-MX FROM IP STGF
C
CSPEC      NEST=MIN(1+(KCOUNT-1)/1000,9999)
CSPEC      WRITE(23,1313) NEST,MXE,JCHAN,NAOP,IOJM,IFACT,NAST
CSPEC      WRITE(6,1313) NEST,MXE,JCHAN,NAOP,IOJM,IFACT,NAST
C     NOTE PARAMETRICALLY FIXED IOJM AND IFACT.
C
   42 WRITE(6,1099) MXE,NAOP,ISLM,KCOUNT,'CHI',JCHAN
      CLOSE(JOUT)
C
CSPEC      CLOSE(23)
CTCC      CLOSE(25)
C
      RETURN
C
 1002 FORMAT(3I4,F20.8,I3,2A1,1P,E16.6)
 1004 FORMAT(' IMESH=',I2,' DE=',F8.6,' QNMAX=',F7.3,' DQN=',F8.6,1X,
     *A3,'-MTRX OPT=',I2/3I5/(20I3))
 1099 FORMAT(/I9,' ENERGIES',I6,' STATES',I6,' SL-SYMMETRIES'/I9,1X,
     * A3,'-MATRIX ELEMENTS (TOTAL)',I8,' PAIR-COUPLING CHANNELS'/)
 1106 FORMAT(7X,I3,I5)
CTCC 1107 FORMAT(5(I3,I2,F9.6))
CTCC 1108 FORMAT(I5,' TERM COUPLING COEFFICIENTS PASSED ON FOR 2J =',I3)
CSPEC 1313 FORMAT('   11   12   13   -1'/6I5,'    R  CDC',I5,' JOMSPECS')
 2003 FORMAT(' Z=',I2,' N=',I2,' RA=',F8.4,' LAMAX=',I2,' COUNT=',I8/
     *  2I5)
 2004 FORMAT(4(I5,F13.7))
 2005 FORMAT(1PE13.6,'EEEE')
      END
C***************************************************************
C
      SUBROUTINE PETFSC
C
C NRB;
C PERTURB S AND C WHERE F=S+C*K
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (ZONE=(1.0,0.0))
      PARAMETER (TZERO=0.0)
C
      COMMON/CALP/ASS(MZCHF,MZCHF),ASC(MZCHF,MZCHF),ACS(MZCHF,MZCHF)
     1 ,ACC(MZCHF,MZCHF)
C  ***  NOTE CHANGE OF CC TO CCT IN /CHAN/ ***
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
CSTGF      COMMON/NRBHYB/FNUHYB,NCHCL,ICHCL(MZCHF),NCHHYB,ICHHYB(MZCHF)
      COMMON/NRBRCT/
     X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF)
     X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF)
     X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF)
     X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF)
     X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF)
     X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF)
     X,RMAT(MZCHF,MZCHF)
      COMMON/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF),
     X          ZA(MZCHF,MZCHF),ZB(MZCHF,MZCHF)
      COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN
      COMMON/NRBSCL/ZFSCL(MZCHF),FSCL(MZCHF)
      COMMON/NRBZED/TZED,LPRTSW
C
C
C  CALCULATE PERTURBED FUNCTIONS (NCHOP=NCHF WHEN IQDT.GT.0)
C
C     OPEN-OPEN
C
        DO J=1,NCHOP
          DO I=1,NCHOP
            CS(I,J)=S(I)*ACS(I,J)-C(I)*ASS(I,J)
            CSP(I,J)=SP(I)*ACS(I,J)-CP(I)*ASS(I,J)
            CC(I,J)=S(I)*ACC(I,J)-C(I)*ASC(I,J)
            CCP(I,J)=SP(I)*ACC(I,J)-CP(I)*ASC(I,J)
CSTGF            CSPP(I,J)=SPP(I)*ACS(I,J)-CPP(I)*ASS(I,J)
CSTGF            CCPP(I,J)=SPP(I)*ACC(I,J)-CPP(I)*ASC(I,J)
CSTGF            DS(I,J)=CS(I,J)
CSTGF            DC(I,J)=CC(I,J)
CSTGF            DSP(I,J)=CSP(I,J)
CSTGF            DCP(I,J)=CCP(I,J)
          ENDDO
        ENDDO
        DO I=1,NCHOP
          CS(I,I)=CS(I,I)+S(I)
          CSP(I,I)=CSP(I,I)+SP(I)
          CC(I,I)=CC(I,I)+C(I)
          CCP(I,I)=CCP(I,I)+CP(I)
CSTGF          CSPP(I,I)=CSPP(I,I)+SPP(I)
CSTGF          CCPP(I,I)=CCPP(I,I)+CPP(I)
        ENDDO
C
C ENERGY SCALE CASE NEUTRAL MQDT
C
        IF(TZED.EQ.TZERO.AND.IQDT.GT.0)THEN
          DO J=1,NCHOP
            DO I=1,NCHOP
              CS(I,J)=CS(I,J)/FSCL(J)
              CSP(I,J)=CSP(I,J)/FSCL(J)
              CC(I,J)=CC(I,J)*FSCL(J)
              CCP(I,J)=CCP(I,J)*FSCL(J)
            ENDDO
          ENDDO
        ENDIF
C
        IF(NCHOP.EQ.NCHF)GOTO 270      !IQDT=1,2
C
C     CLOSED-OPEN
C
        DO J=1,NCHOP
          DO I=NCHOP1,NCHF
            CS(I,J)=C(I)*ASS(I,J)-S(I)*ACS(I,J)
            CSP(I,J)=CP(I)*ASS(I,J)-SP(I)*ACS(I,J)
            CC(I,J)=C(I)*ASC(I,J)-S(I)*ACC(I,J)
            CCP(I,J)=CP(I)*ASC(I,J)-SP(I)*ACC(I,J)
            CSPP(I,J)=CPP(I)*ASS(I,J)-SPP(I)*ACS(I,J)
            CCPP(I,J)=CPP(I)*ASC(I,J)-SPP(I)*ACC(I,J)
            DS(I,J)=CS(I,J)
            DC(I,J)=CC(I,J)
            DSP(I,J)=CSP(I,J)
            DCP(I,J)=CCP(I,J)
          ENDDO
        ENDDO
C
C     OPEN-CLOSED
C
        DO J=NCHOP1,NCHF
          DO I=1,NCHOP
            CC(I,J)=S(I)*ACS(I,J)-C(I)*ASS(I,J)
            CCP(I,J)=SP(I)*ACS(I,J)-CP(I)*ASS(I,J)
            CCPP(I,J)=SPP(I)*ACS(I,J)-CPP(I)*ASS(I,J)
            DC(I,J)=CC(I,J)
            DCP(I,J)=CCP(I,J)
          ENDDO
        ENDDO
C
C     CLOSED-CLOSED
C
        DO J=NCHOP1,NCHF
          DO I=NCHOP1,NCHF
            CC(I,J)=C(I)*ASS(I,J)-S(I)*ACS(I,J)
            CCP(I,J)=CP(I)*ASS(I,J)-SP(I)*ACS(I,J)
            CCPP(I,J)=CPP(I)*ASS(I,J)-SPP(I)*ACS(I,J)
            DC(I,J)=CC(I,J)
            DCP(I,J)=CCP(I,J)
          ENDDO
        ENDDO
        DO I=NCHOP1,NCHF
          CC(I,I)=CC(I,I)+S(I)
          CCP(I,I)=CCP(I,I)+SP(I)
        ENDDO
C
  270   CONTINUE
CSTGF        IF(NCHHYB.GT.0)THEN  !SEE ZPETFSC
CSTGF          DO N=1,NCHHYB
CSTGF            I=ICHHYB(N)
CSTGF            CC(I,I)=S(I)          !SINCE ALPHA=0
CSTGF            CCP(I,I)=SP(I)
CSTGF            CS(I,I)=TZERO
CSTGF            CSP(I,I)=TZERO
CSTGF          ENDDO
CSTGF        ENDIF
C
C  CALCULATE MATRICES A AND B
C
        DO J=1,NCHF
          DO I=1,NCHF
            ZA(I,J)=CC(I,J)
          ENDDO
CSTRTNBL
CNBL    DO K=1,NCHF
CNBL      DO I=1,NCHF
CNBL        ZA(I,J)=ZA(I,J)-ZR(I,K)*CCP(K,J)
CNBL      ENDDO
CNBL    ENDDO
CENDNBL
        ENDDO
        DO J=1,NCHOP
          DO I=1,NCHF
            ZB(I,J)=CS(I,J)
          ENDDO
CSTRTNBL
CNBL    DO K=1,NCHF
CNBL      DO I=1,NCHF
CNBL        ZB(I,J)=ZB(I,J)-ZR(I,K)*CSP(K,J)
CNBL      ENDDO
CNBL    ENDDO
CENDNBL
        ENDDO
CSTRTBL
        DO J=1,NCHF
          DO I=1,NCHF
            ZK(I,J)=CCP(I,J)
          ENDDO
        ENDDO
C
        CALL ZGEMM('N','N',NCHF,NCHF,NCHF,-ZONE,ZR,MZCHF,ZK,MZCHF,
     X    ZONE,ZA,MZCHF)
C
        DO J=1,NCHOP
          DO I=1,NCHF
            ZK(I,J)=CSP(I,J)
          ENDDO
        ENDDO
C
        CALL ZGEMM('N','N',NCHF,NCHOP,NCHF,-ZONE,ZR,MZCHF,ZK,MZCHF,
     X    ZONE,ZB,MZCHF)
CENDBL
C
        RETURN
        END
C***************************************************************
C
      SUBROUTINE PETKMX
C
C NRB:
C EVALUATE PERTURBATION TO K-MATRIX (K->K+Y, Y=-<F|V|F>) SO (UNDAMPED)
C S-MATRIX IS UNITARY, IMPORTANT FOR DR.
C (INCLUDES KB'S REWRITE OF DO LOOPS)
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (LWORK=MZCHF*MZCHF)
      PARAMETER (MWORK=MZCHF*MZCHF)
      PARAMETER (TWO=2.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TZERO=0.0)
C
      COMMON/CALP/ASS(MZCHF,MZCHF),ASC(MZCHF,MZCHF),ACS(MZCHF,MZCHF)
     1 ,ACC(MZCHF,MZCHF)
C  ***  NOTE CHANGE OF CC TO CCT IN /CHAN/ ***
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/NRBRCT/
     X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF)
     X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF)
     X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF)
     X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF)
     X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF)
     X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF)
     X,RMAT(MZCHF,MZCHF)
      COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK)
      COMMON/NRBZED/TZED,LPRTSW
C
      DIMENSION TEMP3(MZCHF,MZCHF),TEMP4(MZCHF,MZCHF)
      DIMENSION Y(MZCHF,MZCHF),IPIV(MZCHF)
C
      EQUIVALENCE (Y,RMAT),(TEMP4,DCP)
      EQUIVALENCE (WORK,TEMP3)
C
C
C  Y=-(F/V/F), F HAS K-MATRIX NORMALISATION,
C    V IS PERTURBATION POTENTIAL
C
CSTRTNBL
CNBL  DO J=1,NCHOP
CNBL    DO I=1,NCHOP
CNBL      Y(I,J)=TZERO
CNBL    ENDDO
CNBL    DO K=1,NCHOP
CNBL      DO I=1,NCHOP
CNBL        Y(I,J)=Y(I,J)+ACC(I,K)*RK(K,J)
CNBL      ENDDO
CNBL    ENDDO
CNBL  ENDDO
CENDNBL
C
CSTRTBL
      CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,ACC,MZCHF,RK,MZCHF,
     X  TZERO,Y,MZCHF)
CENDBL
C
      DO J=1,NCHOP
        DO I=1,NCHOP
          ACC(I,J)=Y(I,J)
          Y(I,J)=ASS(I,J)
        ENDDO
      ENDDO
C
CSTRTNBL
CNBL  DO J=1,NCHOP
CNBL    DO K=1,NCHOP
CNBL      DO I=1,J
CNBL        Y(I,J)=Y(I,J)+RK(I,K)*ACS(K,J)
CNBL      ENDDO
CNBL    ENDDO
CNBL  ENDDO
CNBL  DO J=1,NCHOP
CNBL    DO K=1,NCHOP
CNBL      DO I=1,J
CNBL        Y(I,J)=Y(I,J)+ASC(I,K)*RK(K,J)
CNBL      ENDDO
CNBL    ENDDO
CNBL  ENDDO
CNBL  DO J=1,NCHOP
CNBL    DO K=1,NCHOP
CNBL      DO I=1,J
CNBL        Y(I,J)=Y(I,J)+RK(I,K)*ACC(K,J)
CNBL      ENDDO
CNBL    ENDDO
CNBL  ENDDO
CENDNBL
C
CSTRTBL (DSYMM A LITTLE SLOWER, SO IF NOT USING SYMM MEMORY ELSEWISE)
      CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,RK,MZCHF,ACS,MZCHF,
     X  ONE,Y,MZCHF)
      CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,ASC,MZCHF,RK,MZCHF,
     X  ONE,Y,MZCHF)
      CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,RK,MZCHF,ACC,MZCHF,
     X  ONE,Y,MZCHF)
CENDBL
C
C TEST
      IF(IPERT.LE.-22)THEN
        ISIGN=1
        IF(TZED.GT.0)ISIGN=-1
        DO J=1,NCHOP
          DO I=1,J
            Y(J,I)=Y(I,J)
          ENDDO
        ENDDO
        DO J=1,NCHOP
          DO I=1,NCHOP
            TEMP3(I,J)=-ISIGN*(ACS(I,J)+ACC(I,J))
          ENDDO
        ENDDO
        DO I=1,NCHOP
          TEMP3(I,I)=ONE+TEMP3(I,I)
        ENDDO
        IF(TZED.EQ.0)CALL VERT(TEMP3,MZCHF,NCHOP,IPIV,IERR)
        DO J=1,NCHOP
          DO I=1,NCHOP
            TEMP4(I,J)=TZERO
          ENDDO
          DO K=1,NCHOP
            DO I=1,NCHOP
              TEMP4(I,J)=TEMP4(I,J)+Y(I,K)*TEMP3(K,J)
            ENDDO
          ENDDO
        ENDDO
        DO J=1,NCHOP
          DO I=1,J
            Y(I,J)=(TEMP4(I,J)+TEMP4(J,I))/TWO
            Y(J,I)=Y(I,J)                   !FOR DGEMM AND NO FINAL SYMM
          ENDDO
        ENDDO
      ENDIF
C END TEST
C
      IF(NCHOP.LT.NCHF)THEN
C
CSTRTNBL
CNBL    DO J=1,NCHOP
CNBL      DO K=NCHOP1,NCHF
CNBL        TEMPA=RK(K,J)        !=RK(J,K)
CNBL        TEMPB=ASS(K,J)       !=ASS(J,K)
CNBL        DO I=1,J
CNBL          Y(I,J)=Y(I,J)+ASS(I,K)*TEMPA+RK(I,K)*TEMPB
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CENDNBL
C
CSTRTBL
        K1=NCHF-NCHOP1+1
        CALL DGEMM('N','T',NCHOP,NCHOP,K1,ONE,RK(1,NCHOP1),MZCHF
     X             ,ASS(1,NCHOP1),MZCHF,ONE,Y,MZCHF)
        CALL DGEMM('N','T',NCHOP,NCHOP,K1,ONE,ASS(1,NCHOP1),MZCHF
     X             ,RK(1,NCHOP1),MZCHF,ONE,Y,MZCHF)
CENDBL
C
C
CSTRTNBL
CNBL   DO J=1,NCHOP
CNBL     DO I=1,NCHOP
CNBL       TEMP3(I,J)=TZERO
CNBL     ENDDO
CNBL     DO K=NCHOP1,NCHF
CNBL       TEMPA=RK(K,J)
CNBL       DO I=1,NCHOP
CNBL         TEMP3(I,J)=TEMP3(I,J)+ACS(I,K)*TEMPA
CNBL       ENDDO
CNBL     ENDDO
CNBL   ENDDO
CENDNBL
C
CSTRTBL
        CALL DGEMM('N','T',NCHOP,NCHOP,K1,ONE,ACS(1,NCHOP1),MZCHF
     X             ,RK(1,NCHOP1),MZCHF,TZERO,TEMP3,MZCHF)
CENDBL
C
C
CSTRTNBL
CNBL    DO J=1,NCHOP
CNBL      DO K=1,NCHOP
CNBL        TEMPB=TEMP3(K,J)
CNBL        DO I=1,J
CNBL          Y(I,J)=Y(I,J)+RK(I,K)*TEMPB
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CENDNBL
C
CSTRTBL
        CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,RK,MZCHF
     X             ,TEMP3,MZCHF,ONE,Y,MZCHF)
CENDBL
C
C
CSTRTNBL
CNBL    DO J=1,NCHOP
CNBL      DO I=1,NCHOP
CNBL        TEMP3(I,J)=TZERO
CNBL      ENDDO
CNBL      DO K=NCHOP1,NCHF
CNBL        TEMPB=ASC(K,J)      !=ACS(J,K)
CNBL        DO I=1,NCHOP
CNBL          TEMP3(I,J)=TEMP3(I,J)+RK(I,K)*TEMPB
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CENDNBL
C
CSTRTBL
        CALL DGEMM('N','T',NCHOP,NCHOP,K1,ONE,RK(1,NCHOP1),MZCHF
     X             ,ACS(1,NCHOP1),MZCHF,TZERO,TEMP3,MZCHF)
CENDBL
C
C
CSTRTNBL
CNBL    DO J=1,NCHOP
CNBL      DO K=1,NCHOP
CNBL        TEMPA=RK(K,J)
CNBL        DO I=1,J
CNBL          Y(I,J)=Y(I,J)+TEMP3(I,K)*TEMPA
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CENDNBL
C
CSTRTBL
        CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,TEMP3,MZCHF
     X             ,RK,MZCHF,ONE,Y,MZCHF)
CENDBL
C
C
CSTRTNBL
CNBL    DO L=NCHOP1,NCHF
CNBL      DO I=1,NCHOP
CNBL        TEMP3(I,L)=TZERO
CNBL      ENDDO
CNBL      DO K=NCHOP1,NCHF
CNBL        TEMPB=ASS(K,L)
CNBL        DO I=1,NCHOP
CNBL          TEMP3(I,L)=TEMP3(I,L)+RK(I,K)*TEMPB
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CNBL    DO J=1,NCHOP
CNBL      DO K=NCHOP1,NCHF
CNBL        TEMPB=RK(K,J)
CNBL        DO I=1,J
CNBL          Y(I,J)=Y(I,J)+TEMP3(I,K)*TEMPB
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CENDNBL
C
CSTRTBL
        L1=0
        DO L=NCHOP1,NCHF
          L1=L1+1
          K1=0
          DO K=NCHOP1,NCHF
            K1=K1+1
            TEMP4(L1,K1)=ASS(K,L)
          ENDDO
        ENDDO
        CALL DGEMM('N','N',NCHOP,K1,L1,ONE,RK(1,NCHOP1),MZCHF
     X             ,TEMP4,MZCHF,TZERO,TEMP3,MZCHF)
        CALL DGEMM('N','T',NCHOP,NCHOP,K1,ONE,TEMP3,MZCHF
     X             ,RK(1,NCHOP1),MZCHF,ONE,Y,MZCHF)
CENDBL
C
      ENDIF
C
CSTRTNBL
CNBL  DO J=1,NCHOP
CNBL    DO I=1,J
CNBL      Y(J,I)=Y(I,J)
CNBL    ENDDO
CNBL  ENDDO
CENDNBL
C
      RETURN
      END
C***************************************************************
C
      SUBROUTINE PETTMX
C
C NRB:
C HAVING EVALUATED K-MATRIX PERTURBATION (Y) VIA CALL TO PETKMX,
C NOW NEGLECT Y**2 AND K**N*Y**M (N+M>2) TERMS, WHICH REDUCES TO A
C PERTURBATION OF THE T-MATRIX. THE S-MATRIX IS NOT UNITARY SO DO
C **NOT** USE FOR DR. I DON'T SEE WHY ANYONE WOULD WANT TO USE THIS......
C (INCLUDES KB'S REWRITE OF DO LOOPS)
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (LWORK=MZCHF*MZCHF)
      PARAMETER (MWORK=MZCHF*MZCHF)
C
      PARAMETER (ONE=1.0)
      PARAMETER (RMONE=-1.0)
      PARAMETER (TZERO=0.0)
C
      COMMON/CALP/ASS(MZCHF,MZCHF),ASC(MZCHF,MZCHF),ACS(MZCHF,MZCHF)
     1 ,ACC(MZCHF,MZCHF)
C  ***  NOTE CHANGE OF CC TO CCT IN /CHAN/ ***
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/NRBRCT/
     X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF)
     X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF)
     X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF)
     X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF)
     X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF)
     X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF)
     X,RMAT(MZCHF,MZCHF)
      COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK)
C
      DIMENSION TEMP3(MZCHF,MZCHF)
      DIMENSION Y(MZCHF,MZCHF),P(MZCHF,MZCHF),Q(MZCHF,MZCHF)
     X         ,D(MZCHF,MZCHF)
      DIMENSION IPIV(MZDEC)
C
      EQUIVALENCE (Y,RMAT),(P,CSP),(Q,CC),(D,CCP)
      EQUIVALENCE (WORK,TEMP3)
C
C
C PERTURB (IN EFFECT) T-MATRIX.
C
C  B=Y-RK*Y*RK
CSTRTNBL
CNBL    DO J=1,NCHOP
CNBL      DO I=1,NCHOP
CNBL        D(I,J)=TZERO
CNBL      ENDDO
CNBL      DO K=1,NCHOP
CNBL        DO I=1,NCHOP
CNBL          D(I,J)=D(I,J)+Y(I,K)*RK(K,J)
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CENDNBL
C
CSTRTBL
        CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,Y,MZCHF,RK,MZCHF,
     X             TZERO,D,MZCHF)
CENDBL
C
C
CSTRTNBL
CNBL    DO J=1,NCHOP
CNBL      DO I=1,J
CNBL        B(I,J)=Y(I,J)
CNBL      ENDDO
CNBL      DO K=1,NCHOP
CNBL        DO I=1,J
CNBL          B(I,J)=B(I,J)-RK(I,K)*D(K,J)
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CNBL    DO J=1,NCHOP
CNBL      DO I=1,J
CNBL        B(J,I)=B(I,J)
CNBL      ENDDO
CNBL    ENDDO
CENDNBL
C
CSTRTBL
        DO J=1,NCHOP
          DO I=1,NCHOP
            B(I,J)=Y(I,J)
          ENDDO
        ENDDO
        CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,RMONE,RK,MZCHF,D,MZCHF,
     X             ONE,B,MZCHF)
CENDBL
C
C  D=Y*RK+RK*Y
CSTRTNBL
CNBL    DO J=1,NCHOP
CNBL      DO K=1,NCHOP
CNBL        DO I=1,J
CNBL          D(I,J)=D(I,J)+RK(I,K)*Y(K,J)
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CNBL    DO J=1,NCHOP
CNBL      DO I=1,J
CNBL        D(J,I)=D(I,J)
CNBL      ENDDO
CNBL    ENDDO
CENDNBL
C
CSTRTBL
        CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,RK,MZCHF,Y,MZCHF,
     X             ONE,D,MZCHF)
CENDBL
C
C  A=(1+RK**2)**(-1)
C
CSTRTNBL
CNBL  DO J=1,NCHOP
CNBL    DO I=1,J
CNBL      A(I,J)=TZERO
CNBL    ENDDO
CNBL    DO K=1,NCHOP
CNBL      DO I=1,J
CNBL        A(I,J)=A(I,J)+RK(I,K)*RK(K,J)
CNBL      ENDDO
CNBL    ENDDO
CNBL  ENDDO
CNBL  DO J=1,NCHOP
CNBL    DO I=1,J
CNBL      A(J,I)=A(I,J)
CNBL    ENDDO
CNBL  ENDDO
CENDNBL
C
CSTRTBL
      CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,RK,MZCHF,RK,MZCHF,
     X           TZERO,A,MZCHF)
CENDBL
C
      DO I=1,NCHOP
        A(I,I)=A(I,I)+ONE
      ENDDO
C
CSTRTNBL
CNBL  CALL VERTS(A,MZCHF,NCHOP,WORK,IERR)
CNBL  IF (IERR.NE.0) THEN
CNBL    WRITE(6,100)
CNBL    STOP 'STOP BECAUSE NO INVERSE FOUND IN SR.PETTMX'
CNBL  END IF
CENDNBL
C
CSTRTBL
      CALL DSYTRF('L',NCHOP,A,MZCHF,IPIV,WORK,LWORK,INFO)
      IF (INFO.NE.0) THEN
         WRITE(6,602) INFO
         STOP 'FAILURE IN BLAS ROUTINE DSYTRF'
      ENDIF
      CALL DSYTRI('L',NCHOP,A,MZCHF,IPIV,WORK,INFO)
      IF (INFO.NE.0) THEN
         WRITE(6,603) INFO
         STOP 'FAILURE IN BLAS ROUTINE DSYTRI'
      ENDIF
CENDBL
C
      DO J=1,NCHOP
        DO I=J,NCHOP
          A(J,I)=A(I,J)
        ENDDO
      ENDDO
C
C  P=P+A*B*A, Q=Q+A*D*A
CSTRTNBL
CNBL    DO J=1,NCHOP
CNBL      DO I=1,NCHOP
CNBL        TEMP3(I,J)=TZERO
CNBL      ENDDO
CNBL      DO K=1,NCHOP
CNBL        DO I=1,NCHOP
CNBL          TEMP3(I,J)=TEMP3(I,J)+B(I,K)*A(K,J)
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CNBL    DO J=1,NCHOP
CNBL      DO K=1,NCHOP
CNBL        DO I=1,J
CNBL          P(I,J)=P(I,J)+A(I,K)*TEMP3(K,J)
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CNBL    DO J=1,NCHOP
CNBL      DO I=1,J
CNBL        P(J,I)=P(I,J)
CNBL      ENDDO
CNBL    ENDDO
C
CNBL    DO J=1,NCHOP
CNBL      DO I=1,NCHOP
CNBL        TEMP3(I,J)=TZERO
CNBL      ENDDO
CNBL      DO K=1,NCHOP
CNBL        DO I=1,NCHOP
CNBL          TEMP3(I,J)=TEMP3(I,J)+D(I,K)*A(K,J)
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CNBL    DO J=1,NCHOP
CNBL      DO K=1,NCHOP
CNBL        DO I=1,J
CNBL          Q(I,J)=Q(I,J)+A(I,K)*TEMP3(K,J)
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CNBL    DO J=1,NCHOP
CNBL      DO I=1,J
CNBL        Q(J,I)=Q(I,J)
CNBL      ENDDO
CNBL    ENDDO
CENDNBL
C
CSTRTBL
        CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,B,MZCHF,A,MZCHF,
     X             TZERO,TEMP3,MZCHF)
        CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,A,MZCHF,TEMP3,MZCHF,
     X             ONE,P,MZCHF)
        CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,D,MZCHF,A,MZCHF,
     X             TZERO,TEMP3,MZCHF)
        CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,A,MZCHF,TEMP3,MZCHF,
     X             ONE,Q,MZCHF)
CENDBL
C
C
      RETURN
CN100   FORMAT(' THE MATRIX: 1 + K^2 HAS NO INVERSE IN SUBROUTINE '
CN   1  ,'PETTMX - MUST STOP')
  602 FORMAT(//10X,10('*'),' SR.PETTMX: DSYTRF RETURNED WITH INFO =',I2)
  603 FORMAT(//10X,10('*'),' SR.PETTMX: DSYTRI RETURNED WITH INFO =',I2)
      END
C************************************************************************
C
C THIS ROUTINE STILL NEEDS A BLAS VERSION, AS INDICATED BELOW
C
C************************************************************************
C
      SUBROUTINE PHOTO1
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
C TWG & NRB:
C     DAMPED PARTIAL PHOTOIONIZATION/RECOMBINATION
C
      INCLUDE 'PARAM'
C
      PARAMETER (MNPEXT=MZMNP+MZCHF)
CBL   PARAMETER (LWORK=MZCHF*MZCHF)
CBL   PARAMETER (MWORK=MZCHF*MZCHF)
      PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2)
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
      PARAMETER (ZERO=(0.0,0.0))
      PARAMETER (ZI=(0.0,1.0))
      PARAMETER (ZI2=ZI/TWO)
C
      COMMON/CEN/ETOT,MXE,NWT,NZ
C  ***  NOTE CHANGE OF CC TO CCT IN /CHAN/ ***
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/NRBDR/PDR(MZCHF),OMEGDR(MZMET,MZMSH),NDRMET
      COMMON/NRBGAM/ZGAM(MZCHF),GAM(MZCHF)
      COMMON/NRBHYB/FNUHYB,NCHCL,ICHCL(MZCHF),NCHHYB,ICHHYB(MZCHF)
      COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT
      COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN
      COMMON/NRBRCT/
     X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF)
     X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF)
     X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF)
     X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF)
     X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF)
     X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF)
     X,RMAT(MZCHF,MZCHF)
      COMMON/NRBPH1/ZCOEF(MNPEXT,MZCHF),OMEGPR(MZMET,MZMSH),EPHMIN,
     1              EPHMAX,IPHOTO,NODAMP
      COMMON/NRBPH2/ZS(MZCHF),ZSP(MZCHF),ZC(MZCHF),ZCP(MZCHF)
      COMMON/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF),
     X          ZA(MZCHF,MZCHF),ZB(MZCHF,MZCHF)
      COMMON/NRBPH5/ZCS(MZCHF,MZCHF),ZCSP(MZCHF,MZCHF),ZCC(MZCHF,MZCHF)
     1 ,ZCCP(MZCHF,MZCHF)
      COMMON/NRBPH6/EPI(MZMSH,MZEPI,MZMET),XPI(MZMSH,0:MZPHT,MZEPI
     X,MZMET),EBB(MZEPI,MZMET),XPITOT(MZMSH,MZEPI,MZMET),NPISYM,NPIEB
      COMMON/NRBPH7/ZBB(MZDIP,MZCHF),ZDIP(MZDIP,MZCHF)
     X,ZD(MZCHF,MZCHF),ZE(MZCHF,MZCHF),ZF(MZCHF,MZCHF)
     X,IDEC(MZEPI*MZMET),JDEC(MZDEC),IPIV(MZCHF),NDEC0
      COMMON/AUGER/AAUGER(MZTAR),IAUGER
      COMMON/BDSYM/ISB(MZSLP),ILB(MZSLP),IPB(MZSLP),NFILEB,
     1             ISDL(MZSLP),ILDL(MZSLP),IPDL(MZSLP),NFILED,
     2             ISDR(MZSLP),ILDR(MZSLP),IPDR(MZSLP),
     3             NFBD,NFB(3),NFD(3),MXEB(3)
      COMMON/GAUGE/IGAUGE
      COMMON/RADDEC/EDEC(MZDEC),DDEC(MNPEXT,MZDEC),NDEC
      COMMON/TYPE/NTYP1,NTYP2I,NTYP2OF,NTYP2OR,NMIN
      COMMON/ZCOUL/ZFS(MZPTS,MZCHF),ZFSP(MZCHF),ZFC(MZPTS,MZCHF)
     1 ,ZFCP(MZCHF),ZFKNU(MZCHF)
CBL   COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK)
      COMMON/NRBZED/TZED,LPRTSW
C
C
C NOTE: TO GET CROSS SECTIONS SIGPR INSTEAD OF OMEGAS OMEGPR UNCOMMENT
C       THE "CP" LINES. SIGPR CAN EITHER BE FED OUT INSTEAD OF OMEGPR
C       IN /PHOTO1/ (AND THE PRINTOUT ADJUSTED IN MAIN) OR THE COMMON
C       BLOCK CAN BE EXTENDED THROUGHOUT THE CODE.
C
      IF(NCHOP*NDEC.EQ.0)RETURN
C
      NZA=NZED-NELC
      NZA=MAX(NZA,1)
C
C    MAKE DIPOLE MATRIX
C
      DO J=1,NCHF
        DO I=1,NDEC0
          ZBB(I,J)=ZERO
        ENDDO
      ENDDO
      DO J=1,NCHF
        DO I=1,NDEC0
          DO K=1,MNP2
            ZBB(I,J)=ZBB(I,J)+DDEC(K,IDEC(I))*ZCOEF(K,J)  !USE ZDOT DDEC->ZWORK
          ENDDO                                           !SINCE NDEC0 IS SMALL
        ENDDO
      ENDDO
C
C ZERO-OUT ZBB
C
      DO J=1,NCHF
        IF(IOMIT(J).GT.0)THEN
          DO I=1,NDEC0
            ZBB(I,J)=ZERO
          ENDDO
        ENDIF
      ENDDO
C
C     CONSTRUCT FINAL DERIVATIVE
C
      IF(IPERT.EQ.0)THEN
        DO J=1,NCHOP
          DO I=1,NCHOP
            ZA(I,J)=CP(I)*ZK(I,J)
          ENDDO
          ZA(J,J)=ZA(J,J)+SP(J)
        ENDDO
        DO J=1,NCHOP
          DO I=NCHOP1,NCHF            !NCHOP1=NCHF+1 WHEN IQDT.GT.0
            ZA(I,J)=(ZSP(I)+ZGAM(I)*ZCP(I))*ZK(I,J)
          ENDDO
        ENDDO
        IF(NCHHYB.GT.0)THEN
          DO J=1,NCHOP
            DO N=1,NCHHYB
              I=ICHHYB(N)
              ZA(I,J)=(ZSP(I)+ZI2*GAM(I)*ZCP(I))*ZK(I,J)
            ENDDO
          ENDDO
        ENDIF
      ELSEIF(IPERT.GT.0)THEN
        IF(IQDT.EQ.0.OR.IOMSW.LT.0)THEN !IOMSW.LT.0 FOR HYBRID, SEE ZPETFSC
          DO J=1,NCHOP
            DO I=1,NCHF
              ZA(I,J)=ZCSP(I,J)
            ENDDO
            DO K=1,NCHF
              DO I=1,NCHF
                ZA(I,J)=ZA(I,J)+ZCCP(I,K)*ZK(K,J)           !USE ZGEMM
              ENDDO
            ENDDO
          ENDDO
        ELSE
          DO J=1,NCHOP
            DO I=1,NCHF
              ZA(I,J)=CSP(I,J)
            ENDDO
            DO K=1,NCHF
              DO I=1,NCHF
                ZA(I,J)=ZA(I,J)+CCP(I,K)*ZK(K,J)   !USE ZGEMM CCP->ZWORK
              ENDDO
            ENDDO
          ENDDO
        ENDIF
      ELSE
        WRITE(6,*)'***SR.PHOTO: PERTURBATION REQUIRES POSITIVE IPERT'
        WRITE(6,*)'SWITCH IPERT=0 OR FORCE POSITIVE IPERT'
        STOP '***SR.PHOTO: PERTURBATION REQUIRES POSITIVE IPERT'
      ENDIF
C
C     NORMALISE FINAL WAVEFUNCTION (TO K-MX)
C
      DO J=1,NCHOP
        DO I=1,NDEC0
          ZDIP(I,J)=ZERO
        ENDDO
        DO K=1,NCHF
          DO I=1,NDEC0
            ZDIP(I,J)=ZDIP(I,J)+ZBB(I,K)*ZA(K,J)            !USE ZGEMM
          ENDDO
        ENDDO
        DO I=1,NDEC0
          ZDIP(I,J)=ZDIP(I,J)/NZA
        ENDDO
      ENDDO
C
      IF(IPRINT.GT.0)THEN
        WRITE(6,707)ETOT,(I,I=1,NDEC0)
        WRITE(6,*)
        DO I=1,NDEC0
          WRITE(6,710)I,(DBLE(ZDIP(I,J)),J=1,NCHOP)
        ENDDO
        IF(IPRINT.GT.1)THEN
          WRITE(6,*)
          DO I=1,NDEC0
            WRITE(6,710)I,(DIMAG(ZDIP(I,J)),J=1,NCHOP)
          ENDDO
        ENDIF
      ENDIF
C
C
      RETURN
  707 FORMAT(/'   DIPOLE MATRIX FOR ETOT = ',F10.6//
     1  (I9,6I11))
  710 FORMAT(I3,1P7E11.3/(3X,7E11.3))
      END
C************************************************************************

      SUBROUTINE PHOTO2
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
C TWG & NRB:
C     DAMPED PARTIAL PHOTOIONIZATION/RECOMBINATION
C
      INCLUDE 'PARAM'
C
      PARAMETER (MNPEXT=MZMNP+MZCHF)
      PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2)
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
      PARAMETER (ZERO=(0.0,0.0))
      PARAMETER (ZI=(0.0,1.0))
C
      COMMON/CEN/ETOT,MXE,NWT,NZ
C  ***  NOTE CHANGE OF CC TO CCT IN /CHAN/ ***
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/COMEGA/OMEGA(MXTST),IE,NOMWRT
      COMMON/NRBDR/PDR(MZCHF),OMEGDR(MZMET,MZMSH),NDRMET
      COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT
      COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN
      COMMON/NRBRCT/
     X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF)
     X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF)
     X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF)
     X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF)
     X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF)
     X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF)
     X,RMAT(MZCHF,MZCHF)
      COMMON/NRBPH1/ZCOEF(MNPEXT,MZCHF),OMEGPR(MZMET,MZMSH),EPHMIN,
     1              EPHMAX,IPHOTO,NODAMP
      COMMON/NRBPH2/ZS(MZCHF),ZSP(MZCHF),ZC(MZCHF),ZCP(MZCHF)
      COMMON/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF),
     X          ZA(MZCHF,MZCHF),ZB(MZCHF,MZCHF)
      COMMON/NRBPH5/ZCS(MZCHF,MZCHF),ZCSP(MZCHF,MZCHF),ZCC(MZCHF,MZCHF)
     1 ,ZCCP(MZCHF,MZCHF)
      COMMON/NRBPH6/EPI(MZMSH,MZEPI,MZMET),XPI(MZMSH,0:MZPHT,MZEPI
     X,MZMET),EBB(MZEPI,MZMET),XPITOT(MZMSH,MZEPI,MZMET),NPISYM,NPIEB
      COMMON/NRBPH7/ZBB(MZDIP,MZCHF),ZDIP(MZDIP,MZCHF)
     X,ZD(MZCHF,MZCHF),ZE(MZCHF,MZCHF),ZF(MZCHF,MZCHF)
     X,IDEC(MZEPI*MZMET),JDEC(MZDEC),IPIV(MZCHF),NDEC0
      COMMON/AUGER/AAUGER(MZTAR),IAUGER
      COMMON/BDSYM/ISB(MZSLP),ILB(MZSLP),IPB(MZSLP),NFILEB,
     1             ISDL(MZSLP),ILDL(MZSLP),IPDL(MZSLP),NFILED,
     2             ISDR(MZSLP),ILDR(MZSLP),IPDR(MZSLP),
     3             NFBD,NFB(3),NFD(3),MXEB(3)
      COMMON/GAUGE/IGAUGE
      COMMON/RADDEC/EDEC(MZDEC),DDEC(MNPEXT,MZDEC),NDEC
      COMMON/TYPE/NTYP1,NTYP2I,NTYP2OF,NTYP2OR,NMIN
      COMMON/ZCOUL/ZFS(MZPTS,MZCHF),ZFSP(MZCHF),ZFC(MZPTS,MZCHF)
     1 ,ZFCP(MZCHF),ZFKNU(MZCHF)
      COMMON/NRBZED/TZED,LPRTSW
C
      DIMENSION POLD(MZCHF,MZCHF),QOLD(MZCHF,MZCHF)
C
      EQUIVALENCE (POLD,DSP),(QOLD,DC)
C
C
C NOTE: TO GET CROSS SECTIONS SIGPR INSTEAD OF OMEGAS OMEGPR UNCOMMENT
C       THE "CP" LINES. SIGPR CAN EITHER BE FED OUT INSTEAD OF OMEGPR
C       IN /PHOTO1/ (AND THE PRINTOUT ADJUSTED IN MAIN) OR THE COMMON
C       BLOCK CAN BE EXTENDED THROUGHOUT THE CODE.
C
      IF(NCHOP.EQ.0)RETURN
C
      PI=ACOS(-ONE)
      NZA=NZED-NELC
      NZA=MAX(NZA,1)
      NZA2=NZA*NZA
      HNZA2=NZA2/TWO
C
C     COMPUTE PARTIAL PHOTORECOMBINATION CROSS SECTION FOR IPHOTO<0
C
      IF(IPHOTO.LT.0)THEN
C
        JTT=MIN(NDRMET,ITARG(NCHOP))
        J2=0
        DO JT=1,JTT
          IF(NCONAT(JT).GT.0)THEN
            CROSO=TZERO
            J1=J2+1
            J2=J2+NCONAT(JT)
            DO J=J1,J2
              DO I=1,NDEC        !=NDEC0
C COULD ALSO SELECT BY PHOTON ENERGY (EAU) OR ELECTRON ENERGY (ERY)
C               ERY=(ETOT-ENAT(JT))*NZA2
                IF(EDEC(I).GE.EPHMIN.AND.EDEC(I).LE.EPHMAX)THEN
                  EAU=(ETOT-EDEC(I))*HNZA2
                  SUM=ZDIP(I,J)*CONJG(ZDIP(I,J))
                  SUM=SUM*EAU
                  IF(IGAUGE.EQ.0)SUM=SUM*EAU**2
                  CROSO=CROSO+SUM
                ENDIF
              ENDDO
            ENDDO
C
C     DIVIDE BY K**2
C
CP          CROSS=CROSO/((ETOT-ENAT(JT))*NZA2)
C
C     NEED A FACTOR OF ( 8*pi*alpha**3*a0**2 ) / 3 IN MBARNS
C     NOTE THIS HAS AN EXTRA 2/PI FACTOR WHICH SHOULD BE IN THE WAVEFUNCTION,
C     BUT IS NOT, FOR CONTINUA NORMALIZED TO THE DELTA FUNCTION
C
CP          CROSS=CROSS*(9.116251E-05)
C
C FACTOR 8*alpha**3/3 FOR OMEGA
            CROSO=CROSO*1.03625E-06
C
C   NEED A FACTOR OF GF/(GI*(2L+1) )
C
            IF(NSPN2.EQ.0)THEN
              GFGI=ONE
              CROSO=CROSO*GFGI
CP            GFGI=GFGI/DBLE(LAT(JT)+1)
CP            CROSS=CROSS*GFGI
            ELSE
              GFGI=NSPN2
              CROSO=CROSO*GFGI
CP            GFGI=GFGI/DBLE(ISAT(JT)*(2*LAT(JT)+1))
CP            CROSS=CROSS*GFGI
            ENDIF
C
CP          SIGPR(JT,IE)=SIGPR(JT,IE)+CROSS
            OMEGPR(JT,IE)=OMEGPR(JT,IE)+CROSO
          ENDIF
        ENDDO
C
      ENDIF
C
C
C  COMPUTE PARTIAL PHOTOIONIZATION CROSS SECTION FOR IPHOTO>0
C
C
      IPHOTO0=MOD(IPHOTO,1000)
      IF(IPHOTO0.GT.0)THEN
C
C     LOOP OVER INITIAL SYMMETRIES
C
        ND=0
        DO N=1,NFBD
          IB=NFB(N)
          IF(IB.LE.NPISYM)THEN
C
C           LOOP OVER INITIAL ENERGIES
C
            IE1MX=MIN(NPIEB,MXEB(N))
            DO IE1=1,IE1MX
              ND=ND+1
              JD=JDEC(ND)
              EBB(IE1,IB)=EDEC(ND)*NZA2
              ERY=(ETOT-EDEC(ND))*NZA2          !PHOTON ENERGY
              EAU=ERY/TWO
              EPI(IE,IE1,IB)=ERY
C
C     NEED A FACTOR OF ( 8*A0**2 ) / (2L+1)*C   IN MBARNS
c     THIS HAS AN EXTRA 2/PI FACTOR MISSING FROM THE WAVEFUNCTION
C     ALSO, ASSUMES THE GROUND STATE IS IN THE FIRST DECAY SYMMETRY
C
              IF(NSPN2.EQ.0)THEN
                FACT=1.710360/DBLE(ILB(IB)+1)
              ELSE
                FACT=1.710360/DBLE(2*ILB(IB)+1)
              ENDIF
C
              TE=FACT/EAU
              IF(IGAUGE.EQ.0)TE=TE*EAU**2
C
              IMAX=MIN(IPHOTO0,ITARG(NCHOP))
              JMIN=1
              DO I=1,IMAX
                SUM=TZERO
                JMAX=JMIN+NCONAT(I)-1
                DO J=JMIN,JMAX
                  SUM=SUM+ZDIP(JD,J)*CONJG(ZDIP(JD,J))
                ENDDO
                SUM=SUM*TE
                IF(I.LE.MZPHT)XPI(IE,I,IE1,IB)=XPI(IE,I,IE1,IB)+SUM
                XPI(IE,0,IE1,IB)=XPI(IE,0,IE1,IB)+SUM
                JMIN=JMAX+1
              ENDDO
            ENDDO
            ND=ND+MXEB(N)-IE1MX
          ELSE
            ND=ND+MXEB(N)
          ENDIF
        ENDDO
C
      ENDIF
C
C
      RETURN
      END
C************************************************************************

      SUBROUTINE PIABSK
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
C TWG & NRB:
C     DAMPED TOTAL PHOTOABSORPTION
C
      INCLUDE 'PARAM'
C
      PARAMETER (MNPEXT=MZMNP+MZCHF)
      PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2)
      PARAMETER (LWORK=MZCHF*MZCHF)
      PARAMETER (MWORK=MZCHF*MZCHF)
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
      PARAMETER (ZERO=(0.0,0.0))
      PARAMETER (ZONE=(1.0,0.0))
      PARAMETER (ZI=(0.0,1.0))
C
      COMMON/CEN/ETOT,MXE,NWT,NZ
C  ***  NOTE CHANGE OF CC TO CCT IN /CHAN/ ***
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/COMEGA/OMEGA(MXTST),IE,NOMWRT
      COMMON/NRBDR/PDR(MZCHF),OMEGDR(MZMET,MZMSH),NDRMET
      COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT
      COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN
      COMMON/NRBRCT/
     X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF)
     X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF)
     X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF)
     X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF)
     X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF)
     X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF)
     X,RMAT(MZCHF,MZCHF)
      COMMON/NRBPH1/ZCOEF(MNPEXT,MZCHF),OMEGPR(MZMET,MZMSH),EPHMIN,
     1              EPHMAX,IPHOTO,NODAMP
      COMMON/NRBPH2/ZS(MZCHF),ZSP(MZCHF),ZC(MZCHF),ZCP(MZCHF)
      COMMON/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF),
     X          ZA(MZCHF,MZCHF),ZB(MZCHF,MZCHF)
      COMMON/NRBPH5/ZCS(MZCHF,MZCHF),ZCSP(MZCHF,MZCHF),ZCC(MZCHF,MZCHF)
     1 ,ZCCP(MZCHF,MZCHF)
      COMMON/NRBPH6/EPI(MZMSH,MZEPI,MZMET),XPI(MZMSH,0:MZPHT,MZEPI
     X,MZMET),EBB(MZEPI,MZMET),XPITOT(MZMSH,MZEPI,MZMET),NPISYM,NPIEB
      COMMON/NRBPH7/ZBB(MZDIP,MZCHF),ZDIP(MZDIP,MZCHF)
     X,ZD(MZCHF,MZCHF),ZE(MZCHF,MZCHF),ZF(MZCHF,MZCHF)
     X,IDEC(MZEPI*MZMET),JDEC(MZDEC),IPIV(MZCHF),NDEC0
      COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK)
      COMMON/AUGER/AAUGER(MZTAR),IAUGER
      COMMON/BDSYM/ISB(MZSLP),ILB(MZSLP),IPB(MZSLP),NFILEB,
     1             ISDL(MZSLP),ILDL(MZSLP),IPDL(MZSLP),NFILED,
     2             ISDR(MZSLP),ILDR(MZSLP),IPDR(MZSLP),
     3             NFBD,NFB(3),NFD(3),MXEB(3)
      COMMON/GAUGE/IGAUGE
      COMMON/RADDEC/EDEC(MZDEC),DDEC(MNPEXT,MZDEC),NDEC
      COMMON/TYPE/NTYP1,NTYP2I,NTYP2OF,NTYP2OR,NMIN
      COMMON/ZCOUL/ZFS(MZPTS,MZCHF),ZFSP(MZCHF),ZFC(MZPTS,MZCHF)
     1 ,ZFCP(MZCHF),ZFKNU(MZCHF)
C
      DIMENSION P(MZCHF,MZCHF),Q(MZCHF,MZCHF)
C
      EQUIVALENCE (P,CSP),(Q,CC)
C
C
      IF(NCHOP.EQ.0)RETURN
C
      PI=ACOS(-ONE)
      NZA=NZED-NELC
      NZA2=NZA*NZA
C
C     MAKE ( 1 +/- iK )**(-1)
C
        DO J=1,NCHF
          DO I=1,NCHF
            Z=DCMPLX(P(I,J),Q(I,J))
            ZB(I,J)=-ZI*Z
            ZA(I,J)=ZI*Z
          ENDDO
          ZB(J,J)=ZB(J,J)+ONE
          ZA(J,J)=ZA(J,J)+ONE
        ENDDO
C
CSTRTNBL
CNBL    CALL ZVERTS(ZA,MZCHF,NCHF,ZWORK,IERR)
CNBL    IF (IERR.NE.0) THEN
CNBL      WRITE(6,600)
CNBL      STOP 'STOP BECAUSE NO INVERSE FOUND IN SR.PIABSK'
CNBL    END IF
CENDNBL
CSTRTBL
        CALL ZSYTRF('L',NCHF,ZA,MZCHF,IPIV,ZWORK,MWORK,INFO)
        IF (INFO.NE.0) THEN
           WRITE(6,602) INFO
           STOP 'FAILURE IN BLAS ROUTINE ZSYTRF'
        ENDIF
        CALL ZSYTRI('L',NCHF,ZA,MZCHF,IPIV,ZWORK,INFO)
        IF (INFO.NE.0) THEN
           WRITE(6,603) INFO
           STOP 'FAILURE IN BLAS ROUTINE ZSYTRI'
        ENDIF
CENDBL
C
        DO J=1,NCHF
          DO I=J,NCHF
            ZA(J,I)=ZA(I,J)
          ENDDO
        ENDDO
C
C     MAKE S**-1 = (1-iK)*(1+iK)**(-1)
C
CSTRTNBL
CNBL    DO J=1,NCHF
CNBL      DO I=1,J
CNBL        ZE(I,J)=ZERO
CNBL      ENDDO
CNBL      DO K=1,NCHF
CNBL        DO I=1,J
CNBL          ZE(I,J)=ZE(I,J)+ZB(I,K)*ZA(K,J)
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CNBL    DO J=1,NCHF
CNBL      DO I=1,J
CNBL        ZE(J,I)=ZE(I,J)
CNBL      ENDDO
CNBL    ENDDO
CENDNBL
C
CSTRTBL
        CALL ZGEMM('N','N',NCHF,NCHF,NCHF,ZONE,
     X             ZB,MZCHF,ZA,MZCHF,ZERO,ZE,MZCHF)
CENDBL
C
CSTRTNBL
CNBL    CALL ZVERTS(ZB,MZCHF,NCHF,ZWORK,IERR)
CNBL    IF (IERR.NE.0) THEN
CNBL      WRITE(6,600)
CNBL      STOP 'STOP BECAUSE NO INVERSE FOUND IN SR.PIABSK'
CNBL    END IF
CENDNBL
C
CSTRTBL
        CALL ZSYTRF('L',NCHF,ZB,MZCHF,IPIV,ZWORK,MWORK,INFO)
        IF (INFO.NE.0) THEN
           WRITE(6,602) INFO
           STOP 'FAILURE IN BLAS ROUTINE ZSYTRF'
        ENDIF
        CALL ZSYTRI('L',NCHF,ZB,MZCHF,IPIV,ZWORK,INFO)
        IF (INFO.NE.0) THEN
           WRITE(6,603) INFO
           STOP 'FAILURE IN BLAS ROUTINE ZSYTRI'
        ENDIF
CENDBL
C
        DO J=1,NCHF
          DO I=J,NCHF
            ZB(J,I)=ZB(I,J)
          ENDDO
        ENDDO
C
C     MAKE ( S**(-1) +/- exp(2*pi*i*nu) )
C
        DO J=1,NCHF
          DO I=1,NCHF
            ZF(I,J)=ZE(I,J)
            ZD(I,J)=ZE(I,J)
          ENDDO
        ENDDO
        DO I=NCHOP+1,NCHF
          ZT=TWO*PI*ZI*ZFKNU(I)
          IF(IOMIT(I).LT.0)ZT=-ZT
          ZFACT=EXP(ZT)
          ZF(I,I)=ZF(I,I)+ZFACT
          ZD(I,I)=ZD(I,I)-ZFACT
        ENDDO
C
CSTRTNBL
CNBL    CALL ZVERTS(ZD,MZCHF,NCHF,ZWORK,IERR)
CNBL    IF (IERR.NE.0) THEN
CNBL      WRITE(6,600)
CNBL      STOP 'STOP BECAUSE NO INVERSE FOUND IN SR.PIABSK'
CNBL    END IF
CENDNBL
CSTRTBL
        CALL ZSYTRF('L',NCHF,ZD,MZCHF,IPIV,ZWORK,MWORK,INFO)
        IF (INFO.NE.0) THEN
           WRITE(6,602) INFO
           STOP 'FAILURE IN BLAS ROUTINE ZSYTRF'
        ENDIF
        CALL ZSYTRI('L',NCHF,ZD,MZCHF,IPIV,ZWORK,INFO)
        IF (INFO.NE.0) THEN
           WRITE(6,603) INFO
           STOP 'FAILURE IN BLAS ROUTINE ZSYTRI'
        ENDIF
CENDBL
C
        DO J=1,NCHF
          DO I=J,NCHF
            ZD(J,I)=ZD(I,J)
          ENDDO
        ENDDO
C
C     MULTIPLY THEM ALL TOGETHER ( A*D*F*B)
C
CSTRTNBL
CNBL    DO J=1,NCHF
CNBL      DO I=1,NCHF
CNBL        ZE(I,J)=ZERO
CNBL      ENDDO
CNBL      DO K=1,NCHF
CNBL        DO I=1,NCHF
CNBL          ZE(I,J)=ZE(I,J)+ZA(I,K)*ZD(K,J)
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CENDNBL
C
CSTRTBL
        CALL ZGEMM('N','N',NCHF,NCHF,NCHF,ZONE,
     X             ZA,MZCHF,ZD,MZCHF,ZERO,ZE,MZCHF)
CENDBL
C
CSTRTNBL
CNBL    DO J=1,NCHF
CNBL      DO I=1,NCHF
CNBL        ZD(I,J)=ZERO
CNBL      ENDDO
CNBL      DO K=1,NCHF
CNBL        DO I=1,NCHF
CNBL          ZD(I,J)=ZD(I,J)+ZE(I,K)*ZF(K,J)
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CENDNBL
C
CSTRTBL
        CALL ZGEMM('N','N',NCHF,NCHF,NCHF,ZONE,
     X             ZE,MZCHF,ZF,MZCHF,ZERO,ZD,MZCHF)
CENDBL
C
CSTRTNBL
CNBL    DO J=1,NCHF
CNBL      DO I=1,NCHF
CNBL        ZA(I,J)=ZERO
CNBL      ENDDO
CNBL      DO K=1,NCHF
CNBL        DO I=1,NCHF
CNBL          ZA(I,J)=ZA(I,J)+ZD(I,K)*ZB(K,J)
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CENDNBL
C
CSTRTBL
        CALL ZGEMM('N','N',NCHF,NCHF,NCHF,ZONE,
     X             ZD,MZCHF,ZB,MZCHF,ZERO,ZA,MZCHF)
CENDBL
C
C     MULTIPLY DIP = DBLE(DT*A*D)
C
        IF(IPRINT.GT.2)THEN
          WRITE(6,707)ETOT,(J,J=1,NCHF)
          WRITE(6,*)
          DO I=1,NCHF
            WRITE(6,710)I,(DBLE(ZA(I,J)),J=1,NCHF)
          ENDDO
          WRITE(6,*)
          DO I=1,NCHF
            WRITE(6,710)I,(DIMAG(ZA(I,J)),J=1,NCHF)
          ENDDO
        ENDIF
C
C     LOOP OVER INITIAL SYMMETRIES
C
        ND=0
        DO N=1,NFBD
          IB=NFB(N)
          IF(IB.LE.NPISYM)THEN
C
C           LOOP OVER INITIAL ENERGIES
C
            IE1MX=MIN(NPIEB,MXEB(N))
            DO IE1=1,IE1MX
              ND=ND+1
              JD=JDEC(ND)
              EBB(IE1,IB)=EDEC(ND)*NZA2
              ERY=(ETOT-EDEC(ND))*NZA2          !PHOTON ENERGY
              EAU=ERY/TWO
              EPI(IE,IE1,IB)=ERY
C
C     NEED A FACTOR OF ( 8*pi*alpha*a0**2 ) / (2L+1)   IN MBARNS
c     THIS HAS AN EXTRA 2/pi FACTOR MISSING FROM THE WAVEFUNCTION
c     since the code uses continuum normalization with Wronskian
c     W(C,S) = 1.0, not the 2/pi required for energy-normalized
c     continuum orbitals.
C     ALSO, ASSUMES THE GROUND STATE IS IN THE FIRST DECAY SYMMETRY
C
              IF(NSPN2.EQ.0)THEN
                FACT=1.71193D0/DBLE(ILB(IB)+1)
              ELSE
                FACT=1.71193D0/DBLE(2*ILB(IB)+1)
              ENDIF
C
              DIP=TZERO
              DO J=1,NCHF
                DO I=1,NCHF
                  DIP=DIP+DBLE(ZDIP(JD,I)*ZA(I,J)*ZDIP(JD,J))
                ENDDO
              ENDDO
              DIP=DIP/EAU
              IF(IGAUGE.EQ.0)DIP=DIP*EAU**2
              XPITOT(IE,IE1,IB)=XPITOT(IE,IE1,IB)+DIP*FACT
            ENDDO
            ND=ND+MXEB(N)-IE1MX
          ELSE
            ND=ND+MXEB(N)
          ENDIF
        ENDDO
C
C
      RETURN
CN600 FORMAT(' SR.PIABSK: MATRIX HAS NO INVERSE IN ZVERTS')
  602 FORMAT(//10X,10('*'),' SR.PIABSK: ZSYTRF RETURNED WITH INFO =',I6)
  603 FORMAT(//10X,10('*'),' SR.PIABSK: ZSYTRI RETURNED WITH INFO =',I6)
  707 FORMAT(/' SR.PIABSK:  ZA MATRIX FOR ETOT = ',F10.6//
     1  (I9,6I11))
  710 FORMAT(I3,1P7E11.3/(3X,7E11.3))
      END
C************************************************************************

      SUBROUTINE PIABSS
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
C TWG & NRB:
C     DAMPED TOTAL PHOTOABSORPTION
C
      INCLUDE 'PARAM'
C
      PARAMETER (MNPEXT=MZMNP+MZCHF)
      PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2)
      PARAMETER (LWORK=MZCHF*MZCHF)
      PARAMETER (MWORK=MZCHF*MZCHF)
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
      PARAMETER (ZERO=(0.0,0.0))
      PARAMETER (ZONE=(1.0,0.0))
      PARAMETER (ZI=(0.0,1.0))
C
      COMMON/CEN/ETOT,MXE,NWT,NZ
C  ***  NOTE CHANGE OF CC TO CCT IN /CHAN/ ***
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/COMEGA/OMEGA(MXTST),IE,NOMWRT
      COMMON/NRBDR/PDR(MZCHF),OMEGDR(MZMET,MZMSH),NDRMET
      COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT
      COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN
      COMMON/NRBRCT/
     X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF)
     X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF)
     X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF)
     X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF)
     X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF)
     X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF)
     X,RMAT(MZCHF,MZCHF)
      COMMON/NRBPH1/ZCOEF(MNPEXT,MZCHF),OMEGPR(MZMET,MZMSH),EPHMIN,
     1              EPHMAX,IPHOTO,NODAMP
      COMMON/NRBPH2/ZS(MZCHF),ZSP(MZCHF),ZC(MZCHF),ZCP(MZCHF)
      COMMON/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF),
     X          ZA(MZCHF,MZCHF),ZB(MZCHF,MZCHF)
      COMMON/NRBPH5/ZCS(MZCHF,MZCHF),ZCSP(MZCHF,MZCHF),ZCC(MZCHF,MZCHF)
     1 ,ZCCP(MZCHF,MZCHF)
      COMMON/NRBPH6/EPI(MZMSH,MZEPI,MZMET),XPI(MZMSH,0:MZPHT,MZEPI
     X,MZMET),EBB(MZEPI,MZMET),XPITOT(MZMSH,MZEPI,MZMET),NPISYM,NPIEB
      COMMON/NRBPH7/ZBB(MZDIP,MZCHF),ZDIP(MZDIP,MZCHF)
     X,ZD(MZCHF,MZCHF),ZE(MZCHF,MZCHF),ZF(MZCHF,MZCHF)
     X,IDEC(MZEPI*MZMET),JDEC(MZDEC),IPIV(MZCHF),NDEC0
      COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK)
      COMMON/AUGER/AAUGER(MZTAR),IAUGER
      COMMON/BDSYM/ISB(MZSLP),ILB(MZSLP),IPB(MZSLP),NFILEB,
     1             ISDL(MZSLP),ILDL(MZSLP),IPDL(MZSLP),NFILED,
     2             ISDR(MZSLP),ILDR(MZSLP),IPDR(MZSLP),
     3             NFBD,NFB(3),NFD(3),MXEB(3)
      COMMON/GAUGE/IGAUGE
      COMMON/RADDEC/EDEC(MZDEC),DDEC(MNPEXT,MZDEC),NDEC
      COMMON/TYPE/NTYP1,NTYP2I,NTYP2OF,NTYP2OR,NMIN
      COMMON/ZCOUL/ZFS(MZPTS,MZCHF),ZFSP(MZCHF),ZFC(MZPTS,MZCHF)
     1 ,ZFCP(MZCHF),ZFKNU(MZCHF)
C
      DIMENSION P(MZCHF,MZCHF),Q(MZCHF,MZCHF)
C
      EQUIVALENCE (P,CSP),(Q,CC)
C
C
      IF(NCHOP.EQ.0)RETURN
C
      PI=ACOS(-ONE)
      NZA=NZED-NELC
      NZA2=NZA*NZA
C
C     MAKE -S**(-1)
C
        DO J=1,NCHF
          DO I=1,NCHF
            ZA(I,J)=-DCMPLX(P(I,J),Q(I,J))
          ENDDO
        ENDDO
C
CSTRTNBL
CNBL    CALL ZVERTS(ZA,MZCHF,NCHF,ZWORK,IERR)
CNBL    IF (IERR.NE.0) THEN
CNBL      WRITE(6,600)
CNBL      STOP 'STOP BECAUSE NO INVERSE FOUND IN SR.PIABSS'
CNBL    END IF
CENDNBL
CSTRTBL
        CALL ZSYTRF('L',NCHF,ZA,MZCHF,IPIV,ZWORK,MWORK,INFO)
        IF (INFO.NE.0) THEN
           WRITE(6,602) INFO
           STOP 'FAILURE IN BLAS ROUTINE ZSYTRF'
        ENDIF
        CALL ZSYTRI('L',NCHF,ZA,MZCHF,IPIV,ZWORK,INFO)
        IF (INFO.NE.0) THEN
           WRITE(6,603) INFO
           STOP 'FAILURE IN BLAS ROUTINE ZSYTRI'
        ENDIF
CENDBL
C
        DO J=1,NCHF
          DO I=J,NCHF
            ZA(J,I)=ZA(I,J)
          ENDDO
        ENDDO
C
C     MAKE ( S**(-1) +/- exp(2*pi*i*nu) )
C
        DO J=1,NCHF
          DO I=1,NCHF
            ZF(I,J)=-ZA(I,J)
            ZD(I,J)=-ZA(I,J)
          ENDDO
        ENDDO
        DO I=NCHOP+1,NCHF
          ZT=TWO*PI*ZI*ZFKNU(I)
          IF(IOMIT(I).LT.0)ZT=-ZT
          ZFACT=EXP(ZT)
          ZF(I,I)=ZF(I,I)+ZFACT
          ZD(I,I)=ZD(I,I)-ZFACT
        ENDDO
C
CSTRTNBL
CNBL    CALL ZVERTS(ZD,MZCHF,NCHF,ZWORK,IERR)
CNBL    IF (IERR.NE.0) THEN
CNBL      WRITE(6,600)
CNBL      STOP 'STOP BECAUSE NO INVERSE FOUND IN SR.PIABSK'
CNBL    END IF
CENDNBL
CSTRTBL
        CALL ZSYTRF('L',NCHF,ZD,MZCHF,IPIV,ZWORK,MWORK,INFO)
        IF (INFO.NE.0) THEN
           WRITE(6,602) INFO
           STOP 'FAILURE IN BLAS ROUTINE ZSYTRF'
        ENDIF
        CALL ZSYTRI('L',NCHF,ZD,MZCHF,IPIV,ZWORK,INFO)
        IF (INFO.NE.0) THEN
           WRITE(6,603) INFO
           STOP 'FAILURE IN BLAS ROUTINE ZSYTRI'
        ENDIF
CENDBL
C
        DO J=1,NCHF
          DO I=J,NCHF
            ZD(J,I)=ZD(I,J)
          ENDDO
        ENDDO
C
C     MULTIPLY THEM ALL TOGETHER ( A*D*F)
C
CSTRTNBL
CNBL    DO J=1,NCHF
CNBL      DO I=1,NCHF
CNBL        ZE(I,J)=ZERO
CNBL      ENDDO
CNBL      DO K=1,NCHF
CNBL        DO I=1,NCHF
CNBL          ZE(I,J)=ZE(I,J)+ZA(I,K)*ZD(K,J)
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CENDNBL
C
CSTRTBL
        CALL ZGEMM('N','N',NCHF,NCHF,NCHF,ZONE,
     X             ZA,MZCHF,ZD,MZCHF,ZERO,ZE,MZCHF)
CENDBL
C
CSTRTNBL
CNBL    DO J=1,NCHF
CNBL      DO I=1,NCHF
CNBL        ZA(I,J)=ZERO
CNBL      ENDDO
CNBL      DO K=1,NCHF
CNBL        DO I=1,NCHF
CNBL          ZA(I,J)=ZA(I,J)+ZE(I,K)*ZF(K,J)
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CENDNBL
C
CSTRTBL
        CALL ZGEMM('N','N',NCHF,NCHF,NCHF,ZONE,
     X             ZE,MZCHF,ZF,MZCHF,ZERO,ZA,MZCHF)
CENDBL
C
C     MULTIPLY DIP = DBLE(DT*A*D)
C
        IF(IPRINT.GT.2)THEN
          WRITE(6,707)ETOT,(J,J=1,NCHF)
          WRITE(6,*)
          DO I=1,NCHF
            WRITE(6,710)I,(DBLE(ZA(I,J)),J=1,NCHF)
          ENDDO
          WRITE(6,*)
          DO I=1,NCHF
            WRITE(6,710)I,(DIMAG(ZA(I,J)),J=1,NCHF)
          ENDDO
        ENDIF
C
C     LOOP OVER INITIAL SYMMETRIES
C
        ND=0
        DO N=1,NFBD
          IB=NFB(N)
          IF(IB.LE.NPISYM)THEN
C
C           LOOP OVER INITIAL ENERGIES
C
            IE1MX=MIN(NPIEB,MXEB(N))
            DO IE1=1,IE1MX
              ND=ND+1
              JD=JDEC(ND)
              EBB(IE1,IB)=EDEC(ND)*NZA2
              ERY=(ETOT-EDEC(ND))*NZA2          !PHOTON ENERGY
              EAU=ERY/TWO
              EPI(IE,IE1,IB)=ERY
C
C     NEED A FACTOR OF ( 8*pi*alpha*a0**2 ) / (2L+1)   IN MBARNS
c     THIS HAS AN EXTRA 2/pi FACTOR MISSING FROM THE WAVEFUNCTION
c     since the code uses continuum normalization with Wronskian
c     W(C,S) = 1.0, not the 2/pi required for energy-normalized
c     continuum orbitals.
C     ALSO, ASSUMES THE GROUND STATE IS IN THE FIRST DECAY SYMMETRY
C
              IF(NSPN2.EQ.0)THEN
                FACT=1.71193D0/DBLE(ILB(IB)+1)
              ELSE
                FACT=1.71193D0/DBLE(2*ILB(IB)+1)
              ENDIF
C
              DIP=TZERO
              DO J=1,NCHF
                DO I=1,NCHF
                  DIP=DIP+DBLE(ZDIP(JD,I)*ZA(I,J)*ZDIP(JD,J))
                ENDDO
              ENDDO
              DIP=DIP/EAU
              IF(IGAUGE.EQ.0)DIP=DIP*EAU**2
              XPITOT(IE,IE1,IB)=XPITOT(IE,IE1,IB)+DIP*FACT
            ENDDO
            ND=ND+MXEB(N)-IE1MX
          ELSE
            ND=ND+MXEB(N)
          ENDIF
        ENDDO
C
C
      RETURN
CN600 FORMAT(' SR.PIABSS: MATRIX HAS NO INVERSE IN ZVERTS')
  602 FORMAT(//10X,10('*'),' SR.PIABSS: ZSYTRF RETURNED WITH INFO =',I6)
  603 FORMAT(//10X,10('*'),' SR.PIABSS: ZSYTRI RETURNED WITH INFO =',I6)
  707 FORMAT(/' SR.PIABSS:  ZA MATRIX FOR ETOT = ',F10.6//
     1  (I9,6I11))
  710 FORMAT(I3,1P7E11.3/(3X,7E11.3))
      END
C***************************************************************
C
      SUBROUTINE POINTS(IOPT1,QJUMP)
C
C  CALCULATES CHANNELS ENERGIES, NUMBER OF OPEN CHANNELS
C  AND TABULAR POINTS.
C NRB:
C SUBSTANTIALLY REVISED FOR MQDT
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (TINY=-1.D-6)
      PARAMETER (XEPS=0.1D0)
      PARAMETER (TZERO=0.0D0)
      PARAMETER (ONE=1.0)
      PARAMETER (ALF=ONE/137.036)
C
      LOGICAL QDT,WARN,QJUMP
C
      COMMON/CQDT/R2ST(MZCHF),QDT,NQ
      COMMON/CMESH/EMAX,EMIN,DEOPEN,DQN,QNMAX,EMESH(MZMSH),IMESH
      COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC
      COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2
      COMMON/CPTOLD/RTWOO,KP2O
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CEN/ETOT,MXE,NWT,NZ
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/CWARN/WARN
      COMMON/NRBHYB/FNUHYB,NCHCL,ICHCL(MZCHF),NCHHYB,ICHHYB(MZCHF)
      COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT
      COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN
      COMMON/NRBSCL/ZFSCL(MZCHF),FSCL(MZCHF)
      COMMON/NRBZED/TZED,LPRTSW
C
C
      DIMENSION TEMPH(MZCHF)
C
C
      KP0=1
      QDT=.FALSE.
      IQ=0
      AZ=MAX(NZED-NELC,1)
C
C  FOR IRAD.GT.0, HOLD OLD KP2, RTWO AND H
C
      IF(IRAD.GT.0)THEN
        KP2OLD=KP2
        RTWOLD=RTWO
        HOLD=H
      ENDIF
C
C  CHANNEL ENERGIES EPS AND NUMBER OF OPEN CHANNELS NCHOP
C
      NCHOP=0
      NCHCL=0
      NCHHYB=0
      DO I=1,NCHF
        IF(.NOT.QJUMP)IOMIT(I)=0
        E=ETOT-ECH(I)
        IF(IWORD.NE.1)THEN
          T=ALF*E*AZ/2
          E=E-T*T
        ENDIF
        IF(E.GT.TINY.AND.E.LT.0.)E=TZERO
        IF(TZED.EQ.TZERO)THEN
          IF(E.LE.-TINY.AND.E.GE.0)E=TZERO
          IF(E.EQ.TZERO)IOMIT(I)=1
        ENDIF
        IF(E.GE.TZERO)THEN
          IF(IOPT1.GE.10)THEN
            QDT=IMESH.EQ.2
            NQ=NCHOP+1
          ENDIF
          NCHOP=NCHOP+1
          FKNU(I)=SQRT(E)
          FSCL(I)=SQRT(FKNU(I))*FKNU(I)**LLCH(I)
          ZFSCL(I)=ONE
        ELSE
          FKNU(I)=SQRT(-E)
          FSCL(I)=SQRT(FKNU(I))*FKNU(I)**LLCH(I)
          FKNU(I)=ONE/SQRT(-E)
          ZFSCL(I)=ONE
          IF(IOMSW.LT.0)THEN           !SYNC. WITH SR.SC FOR HYBRID/DROP
            IF(FKNU(I).LT.FNUHYB                            )THEN
C                               .or.FKNU(I).LT.LLCH(I)+XEPS
              NCHHYB=NCHHYB+1
              ICHHYB(NCHHYB)=I
            ELSE
              NCHCL=NCHCL+1
              ICHCL(NCHCL)=I
            ENDIF
          ENDIF
        ENDIF
        EPS(I)=E
      ENDDO
C
      NCHOP1=NCHOP+1
C
C  SET QDT FOR CASE OF QNMAX.GT.0
C
      NQ=NCHOP
      IF((QNMAX.GT.TZERO.OR.IQDT.LT.0).AND.NCHOP.LT.NCHF)THEN
        DO I=NCHOP1,NCHF
          IF(ABS(ECH(I)-ECH(NCHOP1)).GT.ABS(TINY))GO TO 121
          IF(IQDT.LT.0)NQ=I
          FL5=DBLE(LLCH(I))+.5D0
          IF(QNMAX.GT.TZERO.AND.FKNU(I)+0.00002D0.GT.MAX(QNMAX,FL5))THEN
            QDT=.TRUE.
            NQ=I
          ELSE
            IF(IQDT.GE.0)GOTO 121
          ENDIF
        ENDDO
  121   IF((QDT.AND.IQDT.EQ.0).OR.IQDT.LT.0)THEN
          IF(NQ.GT.NCHOP)THEN
            NCHOP1=NQ+1
            IPERT=0
            IF(IPRINT.GT.0)WRITE(6,630)NCHOP,NQ
          ENDIF
        ENDIF
      ENDIF
      IF(IQDT.GT.0)NCHOP1=NCHF+1
C
C IF NOT UPDATING S-MATRIX THEN
C
      IF(QJUMP)RETURN
C
C
C  CALCULATION OF RTWO
C  INCLUDES CALCULATION OF INNER POINTS OF INFLECTION RINF
C
      RTWO=RZERO
      RIMX=TZERO
C
C  (1) OPEN CHANNELS
C  FOR OPEN CHANNELS RTWO IS DEFINED BY CONVERGENCE CRITERION
C  FOR THE JWBK METHOD.
C
c      write(77,*)etot
      DO I=1,NCHOP
        RINF(I)=RZERO
        R2=RZERO
        IF(IOMIT(I).GT.0)GO TO 138
        E=EPS(I)
        C=CC(I)
        L=LLCH(I)
        EC=E*C
CNRB
        RINF(I)=C/(TZED+SQRT(TZED+EC)+(1.D0-TZED)*1.D-4)+1.D-4       !KEEP NON-ZERO WHEN L=0
        IF(RINF(I).GT.RIMX)RIMX=RINF(I)
C
        IF(L-1)131,132,133
  131   IF(AC.GE.1.D-3)THEN
          CONST=12.D0
        ELSE
         CONST=56.D0
        ENDIF
        CE=CONST*E
CNRB
        R2=CONST/(TZED+SQRT(TZED+CE)+(1.D0-TZED)*1.D-4)
C
        GOTO 138
  132   IF(AC.GE.1.D-3)THEN
          R2=3.9D0*RINF(I)
        ELSE
          R2=16.D0*RINF(I)
        ENDIF
        GOTO 138
  133   IF(AC.GE.1.D-3)THEN
          R2=RINF(I)*(1.2D0+5.7D0/DBLE(L))
        ELSE
          R2=RINF(I)*(1.4D0+9.8D0/DBLE(L))
        ENDIF
  138   CONTINUE
c        if(r2.lt.rone)r2=rone
        R2ST(I)=R2
        IF(RTWO.LT.R2)RTWO=R2
c        write(77,*)i,llch(i),eps(i),rinf(i),r2
      ENDDO
C
C  (2) CLOSED CHANNELS (STRONGLY CLOSED FOR QDT.EQ..TRUE.)
C  FOR CLOSED CHANNELS RTWO IS EQUAL TO THE OUTER POINT OF
C  INFLECTION, EXCEPT FOR THE CASE OF FNU.LT.(LL+1)
C
      ROMN=RTWO
      DO I=NCHOP+1,NCHF
        IF(TZED.EQ.TZERO)THEN
          RINF(I)=1.D-4        !KEEP NON-ZERO, ELSE PERT DROPPED
          R2ST(I)=RZERO-1.D-4  !OMIT CLOSED-CLOSED PERT
        ELSE
          FNU=FKNU(I)
          FLP1=LLCH(I)
          FLP1=FLP1+0.5D0
          IF(FNU.LT.FLP1)THEN
            RINF(I)=TZERO
            R2=RZERO
C            R2=R2+FLP1     ! +3*FLP1 TO CONVERGE HIGH-L
          ELSE
            A1=SQRT(FNU*FNU-CC(I))
            R2=FNU*(FNU+A1)
            RINF(I)=FNU*(FNU-A1)+1.D-4       !KEEP NON-ZERO WHEN L=0
            IF(R2.GT.RZERO.AND.R2.LT.ROMN)ROMN=R2
          ENDIF
          IF(RINF(I).GT.RIMX)RIMX=RINF(I)
          IF(RTWO.LT.R2.AND.(I.GE.NCHOP1.OR.INTPQ.NE.0))RTWO=R2
          R2ST(I)=R2
c        write(77,*)i,llch(i),fknu(i),rinf(i),r2
        ENDIF
      ENDDO
      IF(RONE.GT.RTWO)RTWO=RONE
      IF(ROMN.LT.RZERO)ROMN=RZERO
      IF(RIMX.LT.RZERO)RIMX=RZERO
c      write(77,*)rtwo
C
C  CASE OF IRAD.GT.0
C
      IF(IRAD.GT.0)THEN
C  CHECK VALUE OF RTWO
        IF(RTWO.GT.RTWOLD)THEN
          IF(WARN)WRITE(6,600)ETOT,RTWOLD
          WARN=.FALSE.
        ENDIF
C  RE-INSTATE OLD KP2,RTWO AND H
        KP2=KP2OLD
        RTWO=RTWOLD
        H=HOLD
        RTWOO=RTWOLD
        KP2O=KP2OLD
        RETURN
      ENDIF
C
C DETERMINE SAFE STARTING POINT FOR CORINT
C
      IF(IQDT.GT.0.AND.IPERT.NE.0.AND.INTPQ.EQ.0)THEN
        IF(ROMN.GE.RIMX)THEN
          RTWOC=ROMN
        ELSE
          RTWOC=RIMX
        ENDIF
c        if(rone.gt.2.0)rtwoc=rone
        IF(RTWOC.GT.RTWO)RTWO=RTWOC
      ENDIF
C
C  FIND INTERVAL
C
      WM=TZERO
      DO 170 I=1,NCHF
        C=CC(I)
        E=EPS(I)
        X=1.D0/RZERO
        W=ABS(E+X*(2.D0*TZED-C*X))
        IF(RINF(I).EQ.TZERO)W=W/16.D0
        IF(W.GT.WM)WM=W
        X=1.D0/RTWO
        WH=W
        W=ABS(E+X*(2.D0*TZED-C*X))
        IF(RINF(I).EQ.TZERO)W=W/16.D0
        IF(W.GT.WM)WM=W
        IF(W.GT.WH)WH=W
        IF(C.GT.RZERO.AND.C.LT.RTWO)THEN
          W=ABS(E+TZED/C)
          IF(RINF(I).EQ.TZERO)W=W/16.D0
          IF(W.GT.WM)WM=W
          IF(W.GT.WH)WH=W
        ENDIF
        H=ACNUM/SQRT(WH-TINY)
        IF(IPRINT.GT.2)WRITE(6,621)I,H
        TEMPH(I)=H
  170 CONTINUE
C
      H=ACNUM/SQRT(WM)
c      h=h/2.
      IF(RTWO.LE.RZERO)THEN
        KP2=1
COLD        H=TZERO
        RTWOO=RTWO
        RTWOC=RTWO
        KP2C=1
        RETURN
      ENDIF
C
C  FIND TABULAR POINTS BETWEEN RZERO AND RTWO
C
      IF(ABS(RTWO-RZERO).LT.(2.D0*H))THEN
        R2MAX=R2ST(1)
        IMAX=1
        IF(NCHOP.EQ.1) GO TO 190
        DO I=2,NCHOP
          IF(R2MAX.LT.R2ST(I)) THEN
            R2MAX=R2ST(I)
            IMAX=I
          END IF
        ENDDO
  190   RTWO=RZERO+2.01D0*H
        R2ST(IMAX)=RTWO
      ENDIF
C
      N=(RTWO-RZERO)/H
      N=4*((N-1)/4)+5
      KP2=N
      HO=H
      H=(RTWO-RZERO)/DBLE(KP2-1)
C
C  IF NOT ENOUGH OUTER-REGION POINTS, SEE IF WE CAN DROP DEEPLY CLOSED
C  CHANNELS (E.G. RMPS) AND THEREBY INCREASE H AND SO RETAIN ALL OPEN CHANNELS
C
      IF(KP2.GT.MZPTS)THEN
        IF(IPRINT.GT.0)WRITE(6,612)RTWO,KP2,H
  195   DO I=NCHF,NCHOP+1,-1
          IF(RINF(I).EQ.TZERO)THEN
            IF(TEMPH(I).LT.HO)THEN
              IF(IPRINT.GT.1)WRITE(6,613)I,TEMPH(I)
              TEMPH(I)=999.D0
              IOMIT(I)=1
              H=999.D0
              DO J=1,NCHF
                H=MIN(H,TEMPH(J))
              ENDDO
              N=(RTWO-RZERO)/H
              N=4*((N-1)/4)+5
              KP2=N
              HO=H-TINY
              H=(RTWO-RZERO)/DBLE(KP2-1)
              IF(KP2.GT.MZPTS)GO TO 195
              IF(IPRINT.GT.1)WRITE(6,614)H
              GO TO 196
            ENDIF
          ENDIF
        ENDDO
      ENDIF
C
C  CHECK DIMENSIONS FOR NUMBER OF OUTER-REGION POINTS
C
 196  KP2O=KP2
      RTWOO=RTWO
C
      IF(KP2.GT.MZPTS)THEN
        IPERTO=IPERT
        KP2=4*((MZPTS-1)/4)+1
        RTWO=(KP2-1)*H+RZERO
C
C MODIFICATION BY NRB 30/7/92 TO OVERCOME PROBLEM WITH SMALL NEGATIVE
C ENERGIES, NEGLECT C-C AND C-O CONTRIBUTION FROM RTWO TO INFINITY
C FOR AFFECTED (BOUND) CHANNEL RATHER THAN SWITCHING OFF PERTURBATION
C COMPLETELY. ALSO, STOP NOW IF DIMENSION PROBLEM ON OPEN CHANNEL.
C SEE ADDITIONAL CODING IN SR.ALPHA, SR.COUL, SR.NUMT.
C
C
        IF(NPERT.EQ.0)IPERT=0
C
        IF(IPERTO.NE.0)THEN
          IF(IPRINT.GT.0.AND.NPERT.EQ.1)WRITE(6,610)RTWOO,KP2O,RTWO,KP2
          IF(IPRINT.GT.0.AND.NPERT.EQ.0)WRITE(6,611)RTWOO,KP2O,RTWO,KP2
          IF(IQDT.LE.0)THEN
            DO I=1,NCHF
              IF(R2ST(I).GT.RTWO)THEN
                IF(RINF(I).GT.RZERO.AND.EPS(I).GT.0.1D0)
     X                         WRITE(6,619)I,EPS(I)
                IF(IPRINT.GT.0)WRITE(6,620)I,R2ST(I)
              ENDIF
            ENDDO
          ELSE
            DO I=1,NCHOP
              IF(R2ST(I).GT.RTWO)THEN
                IF(RINF(I).GT.RZERO.AND.EPS(I).GT.0.01D0)
     X                         WRITE(6,619)I,EPS(I)
                IF(IPRINT.GT.0)WRITE(6,620)I,R2ST(I)
              ENDIF
            ENDDO
            DO I=NCHOP+1,NCHF
              IF(RINF(I).GT.RTWO)THEN
                IF(IPRINT.GT.0)WRITE(6,620)I,R2ST(I)
              ENDIF
            ENDDO
          ENDIF
        ENDIF
      ENDIF
C
C SET-UP CORINT POINTS
C
      IF(IQDT.GT.0.AND.IPERT.NE.0.AND.INTPQ.EQ.0)THEN
c        rtwoc=rzero
        N=(RTWOC-RZERO)/H+1.D-6
        IF(N.LT.2)THEN
          RTWOC=RZERO
          KP2C=1
        ELSE
          KP2C=4*((N-1)/4)+5
          IF(KP2C.GT.KP2)KP2C=KP2
          RTWOC=(KP2C-1)*H+RZERO
        ENDIF
c        write(77,*)'kp2c=',kp2c,'  rtwoc=',rtwoc,' rtwo=',rtwo
      ELSE
        KP2C=KP2
      ENDIF
C
C  WEIGHTS FOR BODE RULE INTEGRATION
C
      CALL BODE(H,KP2C,IPERT,RZERO)
C
C
  600 FORMAT(2X,' **WARNING** FOR ETOT = ',
     1 F10.5,' RTWO REDUCED TO MAXIMUM VALUE OF',F7.2
     + /10X,' NO MORE SIMILAR WARNINGS GIVEN'/)
  610 FORMAT(/10X,'USE OF PERTURBATION REQUIRES RTWO = ',
     +  F8.2,', KP2 = ',I5,/10X,'WHICH IS LARGER THAN MAXIMUM OF ',
     +  'MZPTS ALLOWED BY DIMENSIONS'/10X,'NEGLECT CLOSED-CLOSED'
     X,' CLOSED-OPEN AND OPEN-OPEN CONTRIBUTION FROM R .GT.'
     X,' RTWO = ',F8.2,'  KP2 = ',I5/10X,'(FROM R .GT. RZERO'
     X,' IF RINF GT. RZERO)')
  611 FORMAT(/10X,'USE OF PERTURBATION REQUIRES RTWO = ',
     +  F8.2,', KP2 = ',I5,/10X,'WHICH IS LARGER THAN MAXIMUM OF ',
     +  'MZPTS ALLOWED BY DIMENSIONS'/10X,'SET IPERT = 0'
     X,' RTWO = ',F8.2,'  KP2 = ',I5)
  612 FORMAT(/10X,'USE OF PERTURBATION REQUIRES RTWO = ',
     +  F8.2,', KP2 = ',I5,/10X,'WHICH IS LARGER THAN MAXIMUM OF ',
     +  'MZPTS ALLOWED BY DIMENSIONS'/10X,'ATTEMPTING TO DROP',
     X ' DEEPLY-CLOSED CHANNELS SO AS TO INCREASE'/10X,
     X 'THE STEP LENGTH, CURRENTLY H=',F8.5)
  613 FORMAT(/10X,'DROP CHANNEL I =',I5,3X,' STEP =',F8.5)
  614 FORMAT(/10X,'NEW STEP H =',F8.5/)
  619 FORMAT(10X,'CHANNEL ',I3,' EPS = ',1PE11.2,
     + ' OUTER REGION CONTRIBUTION DROPPED')
  620 FORMAT(10X,'CHANNEL ',I3,' REQUIRES RTWO = ',F8.2,
     + ' FOR USE OF PERTURBATION')
  621 FORMAT(10X,'CHANNEL ',I3,' REQUIRES H = ',F11.6,
     + ' FOR USE OF PERTURBATION')
  630 FORMAT(/1X,5('*'),' QDT USED'/7X,'NCHOP = ',I3/
     +  7X,'NQ    = ',I3/)
C
      RETURN
      END
C***************************************************************
C
      SUBROUTINE PRUNE(ABVTHR,BELTHR)
C
CNRB
C PRUNE UNDESIREABLE ENERGIES
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      COMMON/CEN/ETOT,MXE,NWT,NZ
      COMMON/CMESH/EMAX,EMIN,DEOPEN,DQN,QNMAX,EMESH(MZMSH),IMESH
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      DIMENSION EMESH0(MZMSH)
C
      IF(ABVTHR.LT.0.OR.BELTHR.LT.0.)RETURN
C
C HOLD
      MXE0=MXE
C
      IT0=1
      DO IE=1,MXE0
        IFLAGE=0
        EMESH0(IE)=EMESH(IE)
        DO 2 IT=IT0,NAST
           IF(EMESH(IE).LT.ENAT(IT)-BELTHR)GO TO 1
           IF(EMESH(IE).GT.ENAT(IT)+ABVTHR)GO TO 2
           IFLAGE=1
   2    CONTINUE
   1    IF(IFLAGE.NE.0)EMESH0(IE)=-EMESH(IE)
        IT0=IT-1
      ENDDO
C
      MXE=0
      IF(IPRINT.GE.0)THEN
        WRITE(6,*)' '
        WRITE(6,*)'ORIGINAL MESH POINTS DROPPED:'
      ENDIF
      ID=0
      DO IE=1,MXE0
        IF(EMESH0(IE).GT.0.)THEN
          MXE=MXE+1
          EMESH(MXE)=EMESH0(IE)
        ELSE
          IF(IPRINT.GE.0)THEN
            ID=ID+1
            WRITE(6,100)ID,IE,-EMESH0(IE)
          ENDIF
        ENDIF
      ENDDO
C
      RETURN
 100  FORMAT(2I6,1PE16.8)
      END
C
C***************************************************************
C
      SUBROUTINE RAD
C
C NRB: EXTENDED TO JK- AND JJ-COUPLING.
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2)
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
      PARAMETER (THREE=3.0)
      PARAMETER (FOUR=4.0)
      PARAMETER (SIX=6.0)
      PARAMETER (EINF=1.0D6)
      PARAMETER (CON1=.007297353)
      PARAMETER (CON2=4.134D16)
      PARAMETER (TINY=1.D-6)
C
      CHARACTER ELAS*3
C
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/CDEC/ARAD(MXTST),ARDEC(MZTAR),SLIN(MXTST),IRDEC,IEND
     X,IPAR(MZTAR),NEWAR
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/COMEGA/OMEGA(MXTST),IE,NOMWRT
      COMMON/NRBSKP/ISKP(MZMSH),ISKP0,LINC,ELAS
C
      AZ=MAX(NZED-NELC,1)
      IONE=1
      IF(ELAS.EQ.'YES')IONE=0
      PI=ACOS(-ONE)
C
C  RADIATIVE PROBABILITIES
C
      K=0
      IC0=0
      IF(IONE.EQ.1)IC0=NCONAT(1)
C
      DO I=1+IONE,NAST
        JC0=0
        DO 130 J=1,I-IONE
          K=K+1
          IF(NOMWRT.GE.0)KS=I+1-IONE+(NAST+1-IONE)*(J-1)-(J*(J+1))/2
          IF(NOMWRT.LT.0)KS=K
          IF(I.EQ.J)THEN
            ARAD(K)=TZERO
            SLIN(KS)=TZERO
            GO TO 130
          ENDIF
          IF(NSPN2.NE.0)THEN
            IF(IABS(ISAT(I)).NE.IABS(ISAT(J)).OR.
     X        LAT(I)+LAT(J).EQ.0.OR.ABS(LAT(I)-LAT(J)).GT.1)THEN
              ARAD(K)=TZERO
              SLIN(KS)=TZERO
            ENDIF
          ENDIF
          IF(ARAD(K).GE.TZERO)GOTO 30
          DO IC=IC0+1,IC0+NCONAT(I)
            DO JC=JC0+1,JC0+NCONAT(J)
              IF(ABS(CF(IC,JC,1)).LT.TINY)THEN
                ARAD(K)=TZERO
                SLIN(KS)=TZERO
              ELSE
               IF(NSPN2.NE.0)THEN    !LS
                SLIN(KS)=DBLE(2*LRGL2+1)*(CF(IC,JC,1)**2)
     +          /(WSQ(LAT(I),LAT(J),LLCH(IC),LLCH(JC),LRGL2,ISIGN)
     +          *DBLE(2*LAT(I)+1)*MAX(LLCH(IC),LLCH(JC)))
                WGT=DBLE(IABS(ISAT(I))*(2*LAT(I)+1))
                ISLN=(-1)**(LAT(I)+LLCH(IC)+LRGL2+1)
                IF(ISIGN.LT.0)ISLN=-ISLN
                IF(CF(IC,JC,1).LT.TZERO)ISLN=-ISLN
                SLIN(KS)=SLIN(KS)*ISLN
               ELSE                                !JK OR JJ
                 IF(LAT(I)+LAT(J).EQ.0.OR.ABS(LAT(I)-LAT(J)).GT.2)THEN
                   SLIN(KS)=TZERO
                 ELSE
                   IF(KFLAG.GE.0.AND.KJ(IC).EQ.KJ(JC))THEN !JK-NRB
                     SLIN(KS)=DBLE(KJ(IC)+1)*(CF(IC,JC,1)**2)
     +              /(WSQ2(LAT(I),LAT(J),2*LLCH(IC),2*LLCH(JC),KJ(IC),
     +                ISIGN)*DBLE(LAT(I)+1)*MAX(LLCH(IC),LLCH(JC)))
                     WGT=DBLE(LAT(I)+1)
                   ELSEIF(KFLAG.LT.0)THEN      !JJ-NRB
                     IC2=2*(L2P(IC)/2)+1       !2J-VALENCE
                     JC2=2*(L2P(JC)/2)+1       !2J-VALENCE
                     IF(IC2.EQ.JC2)THEN
                       W3J=DBLE(IC2+1)/(DBLE((IC2+2)*IC2))
                     ELSE
                       IC3=MIN(IC2,JC2)
                       W3J=DBLE((IC3+3)*(IC3+1))/DBLE(2*(IC3+2))
                     ENDIF
c                     write(6,*)LLCH(IC),LLCH(JC),ic2,jc2,w3j
                     SLIN(KS)=DBLE(LRGL2+1)*(CF(IC,JC,1)**2)
     +              /(WSQ2(LAT(I),LAT(J),IC2,JC2,LRGL2,ISIGN)*
     +                W3J*DBLE(LAT(I)+1))
                     WGT=DBLE(LAT(I)+1)
                   ENDIF
                 ENDIF
               ENDIF
C
C ENER           GIES ARE UNSCALED ATOMIC (NOT RYDBERGS) UNITS HERE.
C
               ARAD(K)=((CON1*(ENAT(I)-ENAT(J)))**3)*ABS(SLIN(KS))
               SLIN(KS)=SLIN(KS)*WGT*LOG(EINF*AZ**2)
               GOTO 30
              ENDIF
            ENDDO
          ENDDO
   30     JC0=JC0+NCONAT(J)
  130   ENDDO
        IC0=IC0+NCONAT(I)
      ENDDO
C
C  CHECK COMPLETENESS OF ARAD
C
      DO K=1,(NAST*(NAST-2*IONE+1))/2
        IF(ARAD(K).LT.TZERO)THEN
          IEND=0
          RETURN
        ENDIF
      ENDDO
      IEND=1
C
C  CALCULATE ARDEC= = 2*PI*ARAD/Z**2
C
      C=TWO*PI/AZ**2
      K=0
      DO I=1+IONE,NAST
        A=TZERO
        DO J=1,I-IONE
          K=K+1
          A=A+ARAD(K)
        ENDDO
        ARDEC(I)=A*C
      ENDDO
C
C  WRITES
C
      IF(IRDEC.GT.0)WRITE(6,600)
      WRITE(6,605)(I,ISAT(I),LAT(I),IPAR(I),I=1,NAST)
      WRITE(6,610)
C
      K=0
      DO I=1+IONE,NAST
        DO J=1,I-IONE
          K=K+1
          IF(NOMWRT.GE.0)KS=I+1-IONE+(NAST+1-IONE)*(J-1)-(J*(J+1))/2
          IF(NOMWRT.LT.0)KS=K
          IF(ARAD(K).GT.TZERO)THEN
            S=SLIN(KS)*THREE/(LOG(EINF*AZ**2)*FOUR)
            GF=TWO*S*(ENAT(I)-ENAT(J))/THREE
            WRITE(6,620)I,J,ARAD(K),ARAD(K)*CON2,S,GF
          ENDIF
        ENDDO
      ENDDO
C
      WRITE(6,630)(I,ARDEC(I),I=2,NAST)
      WRITE(6,640)
C
      RETURN
C
C  FORMATS
  600 FORMAT(//72('+')//2X,'*** OMEGA AND/OR OMEGDR'
     + ,' CALCULATED ALLOWING FOR RADIATIVE DECAYS ***')
  605 FORMAT(//72('+')//
     + 25X,'TARGET STATES'//12X,'INDEX',5X,'2*S+1',7X,
     + 'L',8X,'PARITY'/20X,'OR P      OR 2*J'
     +//(I15,3I10))
  610 FORMAT(//10X,'RADIATIVE PROBABILITIES (ATOMIC UNITS,'
     + ,' NOT Z-SCALED)'//14X,'I',9X,'J',13X,'A(I,J)',15X,'*SEC'
     X ,18X,'S',14X,'GF'/)
  620 FORMAT(I15,I10,1P2E21.4,0PF20.6,F15.6)
  630 FORMAT(///14X,'I',11X,'ARDEC(I)'//(I15,1PE20.4))
  640 FORMAT(//72('+')//)
C
      END
C***************************************************************
C
      SUBROUTINE REACT(IOPT1,QJUMP,PQRD)
C
C NRB: HEAVILY REWORKED
C  CALCULATION OF REACTANCE MATRIX.
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      LOGICAL QDT,QJUMP,PQRD
      LOGICAL NEWBUT
      CHARACTER ELAS*3
C
      INCLUDE 'PARAM'
C
      PARAMETER (MZKIL=  0)
C
      PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2)
      PARAMETER (MXOM=MZMEG*1000000+MZKIL*1000)
      PARAMETER (MNPEXT=MZMNP+MZCHF)
      PARAMETER (MXF=5)         !(MZLMX+1)/2)
C
      PARAMETER (ONE=1.0)
      PARAMETER (TZERO=0.0)
      PARAMETER (TWO=2.0)
      PARAMETER (FOUR=4.0)
      PARAMETER (QUART=0.25)
      PARAMETER (ZERO=(0.0,0.0))
      PARAMETER (ZI=(0.0,1.0))
C
      COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC
      COMMON/CALP/ASS(MZCHF,MZCHF),ASC(MZCHF,MZCHF),ACS(MZCHF,MZCHF)
     1 ,ACC(MZCHF,MZCHF)
      COMMON/CDEC/ARAD(MXTST),ARDEC(MZTAR),SLIN(MXTST),IRDEC,IEND
     X,IPAR(MZTAR),NEWAR
      COMMON/CEN/ETOT,MXE,NWT,NZ
C  ***  NOTE CHANGE OF CC TO CCT IN /CHAN/ ***
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/CLOGB/NEWBUT
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/CNTRLS/ISGPT,ITRMN,ITRMX
      COMMON/COMEGA/OMEGA(MXTST),IE,NOMWRT
      COMMON/COULSC/FS(MZPTS,MZCHF),FSP(MZCHF),FC(MZPTS,MZCHF)
     1 ,FCP(MZCHF)
      COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2
      COMMON/CPOT/BW(MZCHF,MZCHF),LAMP(MZCHF,MZCHF)
      COMMON/CQDT/R2ST(MZCHF),QDT,NQ
      COMMON/CTOP/LRGLAM,LITLAM(MXTST),NTOP(MXTST,2),NTCHAN(MZTAR,2),
     X INDM,TOPA(MXTST),TOPB(MXTST),NTOPA(MXTST,2),NTOPB(MXTST,2),
     X MTOPA(MXTST,2),MTOPB(MXTST,2),FTOPA(MXTST,MXF),FTOPB(MXTST,MXF),
     X KTOPA(MXTST),KTOPB(MXTST),LRGLMN
      COMMON/DBUT/EBUTD(MZNRG,MZLP1),CBUTD(MZNRG,MZLP1),NBUTD(MZNRG)
     X           ,K2P(MZCHF)
      COMMON/MEMORY/OMEM(MXOM+1),MPOS(0:MZMSH),ITMAX,JTMAX
      COMMON/NRBCBE/RBE(MZCHF,MZCHF),LCBE
      COMMON/NRBDR/PDR(MZCHF),OMEGDR(MZMET,MZMSH),NDRMET
      COMMON/NRBHYB/FNUHYB,NCHCL,ICHCL(MZCHF),NCHHYB,ICHHYB(MZCHF)
      COMMON/NRBKHI/ZKHICC(MZDEG,MZDEG),ZKHIOC(MZCHF,MZDEG),ZVAL(MZDEG)
CBL  X,ZVL(MZDEG,MZDEG),ZVR(MZDEG,MZDEG),RWORK(2*MZDEG)
      COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT
      COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN
      COMMON/NRBRCT/
     X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF)
     X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF)
     X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF)
     X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF)
     X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF)
     X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF)
     X,RMAT(MZCHF,MZCHF)
      COMMON/NRBSCL/ZFSCL(MZCHF),FSCL(MZCHF)
      COMMON/NRBSKP/ISKP(MZMSH),ISKP0,LINC,ELAS
      COMMON/NRBTOP/ITST(MXTST),JTST(MXTST),KTST(MZTAR,MZTAR)
     X             ,OMST(MXTST),ITOP
      COMMON/NRBZED/TZED,LPRTSW
      COMMON/NRBGAM/ZGAM(MZCHF),GAM(MZCHF)
      COMMON/NRBPH1/ZCOEF(MNPEXT,MZCHF),OMEGPR(MZMET,MZMSH),EPHMIN,
     1              EPHMAX,IPHOTO,NODAMP
      COMMON/NRBPH2/ZS(MZCHF),ZSP(MZCHF),ZC(MZCHF),ZCP(MZCHF)
      COMMON/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF),
     X          ZA(MZCHF,MZCHF),ZB(MZCHF,MZCHF)
      COMMON/NRBPH5/ZCS(MZCHF,MZCHF),ZCSP(MZCHF,MZCHF),ZCC(MZCHF,MZCHF)
     1 ,ZCCP(MZCHF,MZCHF)
      COMMON/NRBPH7/ZBB(MZDIP,MZCHF),ZDIP(MZDIP,MZCHF)
     X,ZD(MZCHF,MZCHF),ZE(MZCHF,MZCHF),ZF(MZCHF,MZCHF)
     X,IDEC(MZEPI*MZMET),JDEC(MZDEC),IPIV(MZCHF),NDEC0
      COMMON/THETAF/THFACT(MZCHF)
      COMMON/TYPE/NTYP1,NTYP2I,NTYP2OF,NTYP2OR,NMIN
      COMMON/WIDSV/FWIDSV1(MZCHF),FWIDSV2(MZCHF),EWIDSV1(MZCHF),
     1             EWIDSV2(MZCHF),RWIDSV(MZCHF),NWIDSV(MZCHF)
      COMMON/ZCOUL/ZFS(MZPTS,MZCHF),ZFSP(MZCHF),ZFC(MZPTS,MZCHF)
     1 ,ZFCP(MZCHF),ZFKNU(MZCHF)
C
      DIMENSION Y(MZCHF,MZCHF),P(MZCHF,MZCHF),Q(MZCHF,MZCHF)
     X         ,POLD(MZCHF,MZCHF),QOLD(MZCHF,MZCHF)
      DIMENSION INOUT(MZCHF),SIGPW(MXTST)
C
      EQUIVALENCE (Y,RMAT),(P,CSP),(Q,CC),(POLD,DSP),(QOLD,DC)
C
      NZA=MAX(NZED-NELC,1)
      CONSIG=87.97351
      AZ=MAX(NZED-NELC,1)
      AZAZ=AZ*AZ
C
C
C IN IQDT MODE SEE IF WE CAN CUT TO THE CHASE
C
      IF(IQDT.GT.0)THEN
        IF(QJUMP)THEN
          IF(NCHOP.EQ.0)RETURN
          IPERTO=IPERT
          NCHOPO=NCHOP
          NCHOP=NCHF
          IF(IQDT.EQ.2)GO TO 2000
          GO TO 1000
        ELSE
COLD          IEE(IE)=IE
        ENDIF
      ENDIF
C
      IF(LRGL2.GT.ISKP(IE).AND.IPRKM.GT.0)THEN
        IF(IQDT.GT.0)THEN
          NCHOPO=NCHOP
          NCHOP=NCHF
        ENDIF
        DO J=1,NCHOP
          DO I=1,NCHOP
            RK(I,J)=TZERO
          ENDDO
        ENDDO
        GO TO 3000
      ENDIF
C
C
C CALCULATE INITIAL R-MATRIX
C
      CALL RINIT
C
C
C COULOMB FUNCTIONS AT RZERO
C
C       S(I) IS REGULAR FUNCTION FOR OPEN CHANNELS, DECAYING
C       REAL*8 FUNCTION THETA FOR CLOSED CHANNELS.
C       C(I) IS IRREGULAR FUNCTION FOR OPEN CHANNELS,
C       THETAD = ENERGY DERIVATIVE OF DECAYING FUNCTIONS FOR
C       CLOSED CHANNELS.
C       IN IQDT MODE ALL CHANNELS ARE TREATED AS OPEN.
C
      CALL COUL(INOUT)
C
      NCHOPO=NCHOP
C
C RESET IPERT AND NCHOP FOR QDT CASE
      IF(QDT.OR.IQDT.NE.0) THEN
        IPERTO=IPERT
        IF(IQDT.GT.0)THEN
          NCHOP=NCHF
        ELSE
C NRB: IPERT SHOULD ALREADY HAVE BEEN ZEROED BY POINTS, BUT CHECK
          IF(IPERT.NE.0)STOP 'REACT: IPERT???'
          IPERT=0
          NCHOP=NQ
        ENDIF
        IF(IOMSW.LT.0)THEN
          NCC=NCHCL
        ELSE
          NCC=NCHOP-NCHOPO
          DO N=1,NCC
            ICHCL(N)=NCHOPO+N
          ENDDO
        ENDIF
        DO N=1,NCC
          I=ICHCL(N)
          IF(FKNU(I).LT.FNUMIN)IOMIT(I)=1
        ENDDO
      ENDIF
      IF(NCHOP.EQ.0) THEN
        IF(IRAD.NE.0)THEN
          WRITE(9) QDT
          WRITE(9) NCHOP
        ENDIF
        ISTOT=NSPN2
        IF(NPTY2.EQ.1) ISTOT=-ISTOT
        IF(IPRKM.EQ.1)WRITE(20,660) NCHOP,ISTOT,LRGL2,ETOT
        RETURN
      ENDIF
C
C CALCULATE REACTANCE MATRIX
C
      AR=ONE/RZERO
      DO I=1,NCHF
        GAM(I)=TZERO
        ZGAM(I)=ZERO
        IF(IOMIT(I).LE.0)THEN
          IF(IQDT.EQ.0.OR.INTPQ.EQ.0)THEN
            S(I)=FS(1,I)
            SP(I)=FSP(I)-BSTO*S(I)
          ELSE
            SP(I)=SP(I)-BSTO*S(I)
          ENDIF
          HAM=AR*(AR*CCT(I)-TWO)-EPS(I)
          SPP(I)=HAM*S(I)
COLD          IF(I.LT.NCHOP1.OR.IPERT.GT.0) THEN
          IF(IQDT.EQ.0.OR.INTPQ.EQ.0)THEN
            C(I)=FC(1,I)
            CP(I)=FCP(I)-BSTO*C(I)
          ELSE
            CP(I)=CP(I)-BSTO*C(I)
          ENDIF
          CPP(I)=HAM*C(I)
        ELSE
          S(I)=TZERO
          SP(I)=TZERO
          SPP(I)=TZERO
          C(I)=TZERO
          CP(I)=TZERO
          CPP(I)=TZERO
          ZS(I)=ZERO
          ZSP(I)=ZERO
          ZC(I)=ZERO
          ZCP(I)=ZERO
          DO J=1,NCHF
            ZR(I,J)=ZERO
          ENDDO
        ENDIF
      ENDDO
C
      DO I=NCHOP1,NCHF            !NCHOP1=NCHF+1 WHEN IQDT=1,2
        IF(IOMIT(I).LE.0)THEN
          ZS(I)=ZFS(1,I)
          ZSP(I)=ZFSP(I)-BSTO*ZS(I)
          ZC(I)=ZFC(1,I)
          ZCP(I)=ZFCP(I)-BSTO*ZC(I)
        ELSE
          ZS(I)=ZERO
          ZSP(I)=ZERO
          ZC(I)=ZERO
          ZCP(I)=ZERO
        ENDIF
      ENDDO
C
      IF(NCHHYB.GT.0)THEN
        DO N=1,NCHHYB
          I=ICHHYB(N)
          ZS(I)=ZFS(1,I)
          ZSP(I)=ZFSP(I)-BSTO*ZS(I)
          ZC(I)=ZFC(1,I)
          ZCP(I)=ZFCP(I)-BSTO*ZC(I)
        ENDDO
      ENDIF
C
C EVALUATE NTYP2O CONTRIBUTIONS AND LOAD INTO ZGAM NOW
C IF IQDT.EQ.0 OR STORE IN GAM AND LOAD LATER IF IQDT.GT.0
C
C FOR NTYP2OF, NOW INTERPOLATE, RATHER THAN PERIODIC SCALED EXTRAPOLATION
C WHICH CAN LEAD TO SMALL SAWTOOTH FEATURES.
C
      IF(NTYP2OF.GT.0)THEN
C       GET SIGMA(RR)*E/PIAOSQ IN RYDBERGS, CONVERT TO <S|V|S>
        if(iqdt.gt.0)then           !decouple from iqdt.le.0
          DO I=1,NCHOPO
            IF(ITARG(I).EQ.1)THEN   !NMAX(I) should really only be determined once
              NMAX=1000
            ELSE
              NMAX=INT(SQRT(ONE/(ENAT(ITARG(I))-ENAT(1))))
            ENDIF
            NMAX=MIN(NMAX,NCUTOFF)
            GAM(I)=FWIDTH(NZA,NMIN,NMAX,EPS(I),LLCH(I))
     X            /(FOUR*L2P(I)+TWO)
          ENDDO
        else                        !now modify original case
          DO I=1,NCHOPO
            ETEST=ABS((EPS(I)-EWIDSV1(I))/EWIDSV1(I))
            IF(ETEST.GT.0.2)THEN                        !.OR.IQDT.GT.0
              IF(ITARG(I).EQ.1)THEN   !NMAX(I) should really only be determined once
                NMAX=1000
              ELSE
                NMAX=INT(SQRT(ONE/(ENAT(ITARG(I))-ENAT(1))))
              ENDIF
              NMAX=MIN(NMAX,NCUTOFF)
              If(EWIDSV1(I).GT.0)then
                EWIDSV1(I) = EWIDSV2(I)
                FWIDSV1(I) = FWIDSV2(I)
              else
                FWIDSV1(I)=FWIDTH(NZA,NMIN,NMAX,EPS(I),LLCH(I))
     X                    /(FOUR*L2P(I)+TWO)
                IF(EPS(I).GT.1.0E-8)EWIDSV1(I)=EPS(I)
              endif
                EWIDSV2(I)=1.2*EPS(i)
                FWIDSV2(I)=FWIDTH(NZA,NMIN,NMAX,EWIDSV2(I),LLCH(I))
     X                    /(FOUR*L2P(I)+TWO)
c          ELSE
            ENDIF                       !<--- since EPS may not equal ewidsv1
c            GAM(I)=EWIDSV(I)*FWIDSV(I)/EPS(I)
            GAM(I)=FWIDSV1(I)+( FWIDSV2(I)-FWIDSV1(I) )*
     X             (EPS(I)-EWIDSV1(I))/( EWIDSV2(I) - EWIDSV1(I))
            IF(IQDT.EQ.0)ZGAM(I)=ZI*GAM(I)/TWO
          ENDDO
        endif
      ENDIF
C
C FOR NTYP2OR SCALE AS 1/N^3.
C
      IF(NTYP2OR.GT.0)THEN
        DO I=NCHOPO+1,NCHF
          XTEST=ABS((FKNU(I)-NWIDSV(I))/NWIDSV(I))
          IF(XTEST.GT.0.2.OR.IQDT.GT.0)THEN
            NWID=NINT(FKNU(I))
            IF(NWID.GT.0)THEN
              NMAX=INT(SQRT(ONE/(ENAT(ITARG(I))-ENAT(1))))
              GAM(I)=RWIDTH(NZA,NMIN,NMAX,NWID,LLCH(I))
              RWIDSV(I)=GAM(I)
              NWIDSV(I)=NWID
              GAM(I)=GAM(I)*NWID**3/(NZA**2*FKNU(I)**3)
            ENDIF
          ELSE
            GAM(I)=RWIDSV(I)*(NWIDSV(I)**3)/(NZA**2*FKNU(I)**3)
          ENDIF
C
C         THFACT(I)=1.0 IF SR.THETA IS USED
C                  = PI*NU**3/2 IF SR.SC IS USED
C
          GAM(I)=GAM(I)*THFACT(I)
          IF(IQDT.EQ.0)ZGAM(I)=ZI*GAM(I)/TWO
        ENDDO
        IF(NCHHYB.GT.0)THEN
          DO N=1,NCHHYB
            I=ICHHYB(N)
            ZGAM(I)=ZI*GAM(I)/TWO
          ENDDO
        ENDIF
      ENDIF

C
C EVALUATE PERTURBATION INTEGRALS (ALL IPERT)
C
      IF(IPERT.NE.0)CALL ALPHA(NCHOPO)
C
C..CASE OF IPERT.GT.0 (PERTURB S & C)
C
      IF(IPERT.GT.0)THEN
C
        IF(IQDT.NE.0.AND.IOMSW.GE.0)CALL PETFSC
        IF(IQDT.EQ.0.OR.IOMSW.LT.0)CALL ZPETFSC
C
      ELSE
C
C..CASE OF IPERT.LE.0
C
C ENERGY SCALE CASE NEUTRAL MQDT
C
        IF(TZED.EQ.TZERO.AND.IQDT.GT.0)THEN
          DO J=1,NCHF
            S(J)=S(J)/FSCL(J)
            SP(J)=SP(J)/FSCL(J)
            C(J)=C(J)*FSCL(J)
            CP(J)=CP(J)*FSCL(J)
          ENDDO
        ENDIF
C
C CALCULATE MATRICES A AND B
        DO J=1,NCHOP
          DO I=1,NCHF
            ZA(I,J)=-ZR(I,J)*CP(J)
            ZB(I,J)=-ZR(I,J)*(SP(J)-ZGAM(J)*CP(J))
          ENDDO
        ENDDO
        DO I=1,NCHOP
          ZA(I,I)=ZA(I,I)+C(I)
          ZB(I,I)=ZB(I,I)+S(I)-ZGAM(I)*C(I)
        ENDDO
C                           NON-MQDT
        DO J=NCHOP1,NCHF
          DO I=1,NCHF
            ZA(I,J)=-ZR(I,J)*(ZSP(J)+ZGAM(J)*ZCP(J))
          ENDDO
          ZA(J,J)=ZA(J,J)+ZS(J)+ZGAM(J)*ZC(J)
        ENDDO
        IF(NCHHYB.GT.0)THEN
          DO N=1,NCHHYB
            J=ICHHYB(N)
            DO I=1,NCHF
              ZA(I,J)=-ZR(I,J)*(ZSP(J)+ZGAM(J)*ZCP(J))
              ZB(I,J)=ZERO
            ENDDO
            ZA(J,J)=ZA(J,J)+ZS(J)+ZGAM(J)*ZC(J)
          ENDDO
        ENDIF
C
      ENDIF
C.....
C
C NOW LOAD ZGAM (CASE IQDT.GT.0)
C
      IF(IQDT.GT.0)THEN
        DO I=1,NCHF
          ZGAM(I)=ZI*GAM(I)/TWO
        ENDDO
        IF(NCHHYB.GT.0)THEN
          DO N=1,NCHHYB
            I=ICHHYB(N)
            ZGAM(I)=ZERO
          ENDDO
        ENDIF
      ENDIF
C
C COMPLETE CALCULATION OF (REACTANCE) K-MATRIX
C
      CALL ZAINVB
C
C PERTURB DIAGONAL OF UNPHYSICAL K-MATRIX BY NTYP2O RADIATION
C
      IF(IQDT.GT.0)THEN
        DO I=1,NCHF
          ZK(I,I)=ZK(I,I)+ZGAM(I)
        ENDDO
      ENDIF
C
C TRANSFER REAL PART OF COMPLEX (REACTANCE) K-MATRIX
C
      DO J=1,NCHF
        DO I=1,NCHF
          RK(I,J)=DBLE(ZK(I,J))
        ENDDO
      ENDDO
C
C
C FOR CASE OF IRAD.NE.0, EVALUATE PERTURBATIONS TO RADIATIVE
C DATA AND WRITE REACTANCE MATRIX AND FUNCTIONS TO UNIT 9
C NOTE: COULD CALL PETRAD AFTER CALL PETKMX BUT LITTLE TO BE
C GAINED. INSTEAD WE FORCE IPERT>0 (DEFAULT) WHEN IRAD>0.
C (NOT USED BY STGBF0DAMP).
C
      IF(IRAD.GT.0.AND.IOPT1.LT.10) THEN
C
CSTGF        CALL PETRAD(INOUT)
C
        IF(IRAD.EQ.2) RETURN
      ENDIF
C
C FORM DIPOLE MATRIX ELEMENTS FOR INTERNAL DAMPED PHOTOIONIZATION
C AS ABOVE, WE NEED TO FORCE POSITIVE IPERT FOR IPHOTO.NE.0
C
      IF(IPHOTO*NDEC0.NE.0)CALL PHOTO1
C
C
C USE VARIATIONAL METHOD FOR IPERT<0 (PERTURB K-MX [-2] OR T-MX [-1])
C EITHER WAY WE NEED THE PERTURBATION (Y) TO THE K-MX FIRST, SO
C
      IF(IPERT.LT.0)CALL PETKMX
C
C PERTURB K-MATRIX.
C
      IF(IPERT.LE.-2)THEN
        DO J=1,NCHOP
          DO I=1,NCHOP
            ZK(I,J)=ZK(I,J)+Y(I,J)
          ENDDO
        ENDDO
      ENDIF
C
C OPTIONALLY GO VIA K-UNPHYS->K-PHYS
C     (FIRST PUT ZK IN P AND Q, THEN VARIOUS WRITES....)
C
 3000 IF(ABS(IQDT).EQ.2)THEN
        DO J=1,NCHOP
          DO I=1,NCHOP
            P(I,J)=DBLE(ZK(I,J))
            Q(I,J)=DIMAG(ZK(I,J))
          ENDDO
        ENDDO
        IF(IQDT.EQ.2.AND..NOT.PQRD.AND.IPRKM.EQ.0.AND.IJBIN.NE.0)THEN
          MPTY=IABS(NSPN2)*10000+100*LRGL2+NPTY2
          IF(NSPN2.LT.0)MPTY=-MPTY
          WRITE(21) IE,MPTY,NCHOP,ETOT,NDEC0
          WRITE(21) (IOMIT(I),I=1,NCHOP)
          WRITE(21) ((P(I,J),I=J,NCHOP),J=1,NCHOP),
     X              ((Q(I,J),I=J,NCHOP),J=1,NCHOP)
         IF(IPHOTO*NDEC0.NE.0)WRITE(39)((ZDIP(I,J),I=1,NDEC0),J=1,NCHOP)
        ENDIF
        IF(IPRKM.EQ.2)THEN
          WRITE(36)ETOT,((P(I,J),J=1,I),I=1,NCHOP) !LOWER HALF
          IF(IPHOTO*NDEC0.NE.0)
     X      WRITE(38)ETOT,((DBLE(ZDIP(I,J)),I=1,NDEC0),J=1,NCHOP)
          IF(NOMWRT.EQ.0)GO TO 666
        ENDIF
        IF(IPRKM.EQ.4)THEN
          WRITE(32)((ZK(I,J),I=1,J),J=1,NCHOP)  !UPPER HALF
          IF(IE.EQ.1)WRITE(6,999)IABS(NSPN2),LRGL2,NPTY2
  999       FORMAT(/72('*')/3X,'WROTE DATA TO KMTLS.DAT FOR NSPN2 = ',I3
     1      ,3X,'LRGL2 = ',I3,3X,'NPTY2 = ',I3/72('*'))
          IF(IPRINT.GE.2)THEN                        !SO UNPHYSICAL HERE
            WRITE(6,707)ETOT,(J,J=1,NCHOP)
            WRITE(6,*)
            DO I=1,NCHOP
              WRITE(6,710)I,(P(I,J),J=1,NCHOP)
            ENDDO
          ENDIF
          IF(NOMWRT.EQ.0)GO TO 666
        ENDIF                                !NOT NOMWRT.EQ.0, FOR PHOTO
        IF(IMODE.LT.0.OR.LRGL2.GT.ISKP(IE).OR.NCHOPO.EQ.0)GO TO 666
      ENDIF
C
 2000 IF(ABS(IQDT).EQ.2)THEN
        NCHOP=NCHOPO
        IF(QDT)NCHOP=NQ
        NCHOP1=NCHOP+1
C
        IF(NCHOP.LT.NCHF)THEN
C
          CALL ZMQDTK
C
        ELSE
          DO J=1,NCHF
            DO I=1,NCHF
              ZK(I,J)=DCMPLX(P(I,J),Q(I,J))
              POLD(I,J)=P(I,J)
              QOLD(I,J)=Q(I,J)
            ENDDO
          ENDDO
          IF(IPHOTO.GE.1000.AND.NDEC0.GT.0)CALL PIABSK
        ENDIF
C
      ENDIF
C
C OPTIONALLY GET EIGENPHASE SUM
C
      IF(IPRINT.GT.0)CALL EPHASE
C
C GET NEW P,Q MATRICES (ALL CASES OF IPERT/IQDT)
C SUCH THAT TRANSMISSION MATRIX  IS -2*I*(P+I*Q), I=SQRT(-1)
C
      CALL ZPQ
C
C NOW, PERTURB (IN EFFECT) T-MATRIX, ALTHOUGH I CAN'T SEE WHY-NRB.
C
      IF(IPERT.EQ.-1)CALL PETTMX
C
C
C WRITE K-MATRIX (SO IPERT=-1 IS THE UNPERTURBED MATRIX)
C
      IF(IPRINT.GT.0)THEN
        IF(IPRINT.GE.2)THEN
          WRITE(6,668)
          WRITE(6,669)(I,ITARG(I),LLCH(I),FKNU(I),I=1,NCHOPO)
          WRITE(6,*)
          WRITE(6,669)(I,ITARG(I),LLCH(I),FKNU(I),I=NCHOPO+1,NCHF)
        ENDIF
        WRITE(6,707)ETOT,(J,J=1,NCHOP)
        WRITE(6,*)
        DO I=1,NCHOP
          WRITE(6,710)I,(DBLE(ZK(I,J)),J=1,NCHOP)
        ENDDO
        IF(IPRINT.GT.1)THEN
          WRITE(6,*)
          DO I=1,NCHOP
            WRITE(6,710)I,(DIMAG(ZK(I,J)),J=1,NCHOP)
          ENDDO
        ENDIF
        IF(IQDT.NE.2.AND.(IRAD.GT.0.OR.IPERT.LT.0))THEN
          WRITE(6,*)
          DO I=NCHOP1,NCHF
            WRITE(6,710)I,(DBLE(ZK(I,J)),J=1,NCHOP)
          ENDDO
          IF(IPRINT.GT.1)THEN
            WRITE(6,*)
            DO I=NCHOP1,NCHF
              WRITE(6,710)I,(DIMAG(ZK(I,J)),J=1,NCHOP)
            ENDDO
          ENDIF
        ENDIF
      ENDIF
C
C WRITE K-MATRICES TO DIFFERENTIAL CROSS SECTION CODE
C
      IF(IPRKM.NE.0)THEN
        ISTOT=NSPN2
        IF(NPTY2.EQ.1)ISTOT=-ISTOT
        ETRYD=AZAZ*ETOT
      END IF
      IF(IPRKM.EQ.1) THEN
        IF(NSPN2.NE.0)THEN                                  !LS-COUPLING
          WRITE(20,660)NCHOP,ISTOT,LRGL2,ETRYD
          DO I=1,NCHOP
            WRITE(20,670)ITARG(I),LLCH(I)
          ENDDO
        ELSE
          WRITE(20,660)NCHOP,LRGL2,NPTY2,ETRYD
          IF(KFLAG.GE.0)THEN                                !JK-COUPLING
            DO I=1,NCHOP
              WRITE(20,671)ITARG(I),LLCH(I),KJ(I)
            ENDDO
          ELSE                                              !JJ-COUPLING
            DO I=1,NCHOP
              WRITE(20,671)ITARG(I),LLCH(I),2*IABS(K2P(I))-1        !2*J
            ENDDO
          ENDIF
        ENDIF
        DO I=1,NCHOP
          DO IP=1,NCHOP
            WRITE(20,680)DBLE(ZK(I,IP))
          ENDDO
        ENDDO
      ENDIF
C
CTBD: WRITE PARTIAL WAVE LIST TO A SEQUENTIAL FILE AND THE K-MATRICES
C     TO A DIRECT ACCESS FILE FOR USE BY THE PARTIAL CROSS SECTION CODE
      IF(IPRKM.EQ.3) STOP 'SR.REACT: IPRKM=3 NOT ACTIVE YET'
C
C
C NOW P AND Q SUCH THAT KHI=P+I*Q (=1-T)
C
      DO J=1,NCHOP
        DO I=1,NCHOP
          T=P(I,J)
          P(I,J)=-TWO*Q(I,J)
          Q(I,J)=TWO*T
          IF(I.LE.NCHOPO.AND.J.LE.NCHOPO)THEN
            TT=P(I,J)**2+Q(I,J)**2
            IF(I.NE.J.AND.TT.GT.ONE)WRITE(6,695)ETOT,IPERT,I,J,TT
            IF(I.EQ.J.AND.TT.GT.FOUR)WRITE(6,695)ETOT,IPERT,I,J,TT
          ENDIF
        ENDDO
      ENDDO
      DO I=1,NCHOP
        P(I,I)=ONE+P(I,I)
      ENDDO
C
C CHANGE DIPOLE-MX TO S-MX NORMALIZATION: -I/2*(1+S)
C
      IF(IPHOTO*NDEC0.NE.0)THEN
        DO J=1,NCHOP
          DO I=1,NCHOP
            Z=DCMPLX(P(I,J),Q(I,J))
            ZB(I,J)=-ZI*Z/TWO
          ENDDO
          ZB(J,J)=ZB(J,J)-ZI/TWO
        ENDDO
        DO J=1,NCHOP
          DO I=1,NDEC0
            ZBB(I,J)=ZDIP(I,J)
            ZDIP(I,J)=ZERO
          ENDDO
        ENDDO
        DO J=1,NCHOP
          DO K=1,NCHOP
            DO I=1,NDEC0
              ZDIP(I,J)=ZDIP(I,J)+ZBB(I,K)*ZB(K,J)
            ENDDO
          ENDDO
        ENDDO
C
        IF(IPRINT.GT.1)THEN
          WRITE(6,708)ETOT,(I,I=1,NDEC0)
          WRITE(6,*)
          DO I=1,NDEC0
            WRITE(6,710)I,(DBLE(ZDIP(I,J)),J=1,NCHOP)
          ENDDO
          WRITE(6,*)
          DO I=1,NDEC0
            WRITE(6,710)I,(DIMAG(ZDIP(I,J)),J=1,NCHOP)
          ENDDO
        ENDIF
      ENDIF
C
C OUTPUT KHI MATRICES FOR MQDTS
C
      IF(IOPT1.GT.9.OR.(IQDT.GT.0.AND.IQDT.EQ.1.AND..NOT.PQRD)) THEN
        IF(NSPN2.EQ.0.AND.IOPT1.GT.9)THEN
          WRITE(6,*)'***ERROR: IOPT1>9 REQUESTS (LS) OUTPUT FOR JAJOM'
     X   , ' BUT NSPN2=0. I.E. B.P. DATA BEING PROCESSED!'
          WRITE(6,*)' DELETE RECUPH.DAT AND RE-RUN STG3'
          STOP
        ENDIF
        IF(IJBIN.NE.0) THEN
          IF(IOPT1.GT.9)THEN
C FOR JAJOM CONSISTENCY
            MPTY=NSPN2*1000+LRGL2
            IF(NPTY2.EQ.1) MPTY=-MPTY
            KNUM=(NCHOP*(NCHOP+1))/2
            WRITE(21) IE,MPTY,KNUM,ETOT
            WRITE(21) ((P(I,J),I=J,NCHOP),J=1,NCHOP),
     X                ((Q(I,J),I=J,NCHOP),J=1,NCHOP)
            IF(IOPT1.EQ.11)RETURN
          ELSEIF(IPRKM.EQ.0)THEN
C LS, BP, NX ETC.
            MPTY=IABS(NSPN2)*10000+100*LRGL2+NPTY2
            IF(NSPN2.LT.0)MPTY=-MPTY
            WRITE(21) IE,MPTY,NCHOP,ETOT
            WRITE(21) (IOMIT(I),I=1,NCHOP)
            WRITE(21) ((P(I,J),I=J,NCHOP),J=1,NCHOP),
     X                ((Q(I,J),I=J,NCHOP),J=1,NCHOP)
         IF(IPHOTO*NDEC0.NE.0)WRITE(39)((ZDIP(I,J),I=1,NDEC0),J=1,NCHOP)
         ENDIF
        ENDIF
        IF(IPRKM.EQ.4)THEN
          IF(NCHOP.GT.MZDEG)THEN
            WRITE(6,*)'***INCREASE MZDEG TO AT LEAST: ',NCHOP
            STOP '***INCREASE MZDEG'
          ENDIF
          DO J=1,NCHOP
            DO I=1,J
              ZKHICC(I,J)=DCMPLX(P(I,J),Q(I,J))
            ENDDO
          ENDDO
          WRITE(32)((ZKHICC(I,J),I=1,J),J=1,NCHOP)  !UPPER HALF
          IF(IE.EQ.1)WRITE(6,998)IABS(NSPN2),LRGL2,NPTY2
  998       FORMAT(/72('*')/3X,'WROTE DATA TO SMTLS.DAT FOR NSPN2 = ',I3
     1      ,3X,'LRGL2 = ',I3,3X,'NPTY2 = ',I3/72('*'))
          IF(NOMWRT.EQ.0)GO TO 666
        ENDIF
      ENDIF
C
      IF(IQDT.NE.2.AND.IMODE.LT.0.OR.
     X   LRGL2.GT.ISKP(IE).OR.NCHOPO.EQ.0)GO TO 666
C
C
C....I/QDT CASE (MQDT ENTRY POINT FOR S-MX)
C
 1000 IF(IQDT.NE.0.AND.TZED.EQ.TZERO)NCHOP=NCHOPO
      IF(QDT.OR.(IQDT.NE.0.AND.NCHOP.GT.NCHOPO))THEN
C
C REVERT TO ORIGINAL IPERT, NCHOP
C
        NCHOP=NCHOPO
        IPERT=IPERTO                         !SHOULD BE UNNECESSARY....
C
C TREATED CHANNELS ASSOCIATED WITH ALL CLOSED TARGET STATES AS OPEN, NOW
C CLOSE THEM OFF (IF QDT=.TRUE. LEAVE LOWEST TARGET UNTIL SQDT)
C
        IF(IQDT.GT.0.AND.IQDT.NE.2)THEN
          IF(QDT)NCHOP=NQ
C
          IF(NCHOP.LT.NCHF)  CALL MQDTS
C
        ENDIF
C
C TREATED CHANNELS ASSOCIATED WITH SINGLE (LOWEST) CLOSED TARGET AS OPEN,
C NOW CLOSE THOSE OFF.
C
        IF(IQDT.LE.0.OR.QDT)THEN
          IF(QDT)NCHOP=NCHOPO
C
          CALL SQDTS
C
        ENDIF
C
        NCHOP1=NCHOP+1
C....
      ELSE
C
        IF(IQDT.EQ.1.AND.IPHOTO.GE.1000.AND.NDEC0.GT.0)CALL PIABSS
C
C CALCULATE COLLISION STRENGTHS FOR NON-I/QDT CASE AND STORE IN RK, PDR.
C
        T=NWT*QUART
        DO J=1,NCHOP
          P(J,J)=P(J,J)-ONE
          DO I=1,NCHOP
            RK(I,J)=(P(I,J)**2+Q(I,J)**2)*T
          ENDDO
          P(J,J)=P(J,J)+ONE
        ENDDO
        DO J=1,NCHOP
          PDR(J)=T
          DO I=1,NCHOP
            PDR(J)=PDR(J)-(P(I,J)**2+Q(I,J)**2)*T
          ENDDO
        ENDDO
C....
      ENDIF
C
C (PARTIAL) PHOTOIONIZATION/RECOMBINATION
C
      IF(IPHOTO*NDEC0.NE.0)CALL PHOTO2
C
C RESTORE P AND Q WHEN WORKING WITH UNPHYSICAL K-MATRIX.
C
      IF(ABS(IQDT).EQ.2)THEN
        DO J=1,NCHF
          DO I=1,NCHF
            P(I,J)=POLD(I,J)
            Q(I,J)=QOLD(I,J)
          ENDDO
        ENDDO
      ENDIF
C
C SKIP OMEGA PROCESSING IF NOT REQUIRED
C
      IF(NOMWRT.EQ.0)GO TO 666
C
C WRITE COLLISION STRENGTH
C
      IF(IPRINT.GT.0)THEN
        WRITE(6,640)
        DO J=1,NCHOP
          DO I=1,J
            WRITE(6,650)ETOT,NSPN2,LRGL2,NPTY2,ITARG(I),LLCH(I),
     X      ITARG(J),LLCH(J),RK(I,J)
          ENDDO
          WRITE(6,651)PDR(I)
        ENDDO
      ENDIF
C
C EVALUATE CBE COLLISION STRENGTH
C
      IF(LCBE.GE.0.AND.LRGL2.GE.LCBE)THEN
        DO J=1,NCHOP
          DO I=1,J
            IF(LAMP(I,J).EQ.2)THEN
              IFAIL=IPRINT
              F=FDIP(EPS(I),LLCH(I),EPS(J),LLCH(J),IFAIL)
              IF(IFAIL.NE.0.AND.IPRINT.GE.0)
     X           WRITE(6,655)IFAIL,I,J,EPS(I),LLCH(I),EPS(J),LLCH(J)
              RBE(I,J)=NWT*(BW(I,J)*F)**2
            ELSE
              RBE(I,J)=TZERO
            ENDIF
            RBE(J,I)=RBE(I,J)
          ENDDO
        ENDDO
C
C WRITE CBE AND CC OMEGA'S
C
      IF(IPRINT.GT.-2)THEN
        WRITE(6,720)
        DO J=1,NCHOP
          DO I=1,J
            IF(LAMP(I,J).EQ.2.AND.RK(I,J).NE.0.)WRITE(6,721)I,J,ITARG(I)
     X     ,ITARG(J),RK(I,J),RBE(I,J),RBE(I,J)/RK(I,J)
          ENDDO
        ENDDO
      ENDIF
C
C REPLACE OMEGA-CC BY OMEGA-CBE FOR TOP-UP
C
      IF(LRGL2.GE.LRGLAM-1.AND.LRGLAM.GE.0)THEN
        DO J=1,NCHOP
          DO I=1,J
            IF(LAMP(I,J).EQ.2)THEN
              RK(I,J)=ABS(RBE(I,J))
              RK(J,I)=RK(I,J)
            ENDIF
          ENDDO
        ENDDO
      ENDIF
C
      ENDIF
C
C FOR LRGL2.GE.LRGLMN (SEE TOP1), TAKE OUT ALLOWED TRANSITIONS
C WITH LLCH.GT.LITLAM. IN LS, LRGLMN=LRGLAM BUT IS SMALLER FOR BP.
C
      IF(LRGLAM.GE.0.AND.LRGL2.GE.LRGLMN)THEN
        DO 100  I=1,INDM
          IT1=NTOP(I,1)
          IT2=NTOP(I,2)
          IF(IT1.LT.0)GO TO 150
          I2=NTCHAN(IT2,2)
          IF(I2.GT.NCHOP)GOTO 100
          I1=NTCHAN(IT1,2)
          IF(I1*I2.EQ.0)GO TO 100
          IF(MAX(LLCH(I1),LLCH(I2)).GT.LITLAM(I))RK(I1,I2)=TZERO
 150      IF(NSPN2.EQ.0)THEN
            IFTOP=0
            IF(IT1.GT.0)IFTOP=1
            IF(IT2.LT.0.AND.LRGL2.GT.LRGLAM)IFTOP=-1     !QUADRUPOLE ETC.
            IF(IFTOP.NE.0)THEN
              IT1=ABS(IT1)
              IT2=ABS(IT2)
              DO I1=NTCHAN(IT1,1),NTCHAN(IT1,2)
                DO I2=NTCHAN(IT2,1),NTCHAN(IT2,2)
                  IF(IFTOP.GT.0.AND.MAX(LLCH(I1),LLCH(I2)).GT.LITLAM(I)
     X              .OR.IFTOP.LT.0)RK(I1,I2)=TZERO
                ENDDO
              ENDDO
            ENDIF
          ENDIF
 100    CONTINUE
      ENDIF
C
C
C STORE OMEGA RESULTS IN COMPACT FORM
C
C MXTST=(MZTAR*(MZTAR+1))/2
C
C IT AND JT ARE TARGET STATES
C OMEGA(IT,JT) FOR JT.GT.IT STORED IN
C OMST(IJST)=OMEGA(ITST(IJST),JTST(IJST))
C
C NUMBER OF OPEN TARGET LEVELS
      IF(NCHOP.EQ.0)GO TO 666
C
      NTAROP=ITARG(NCHOP)
      IONE=1
      IF(ELAS.EQ.'YES')IONE=0
      NOMT=(NTAROP*(NTAROP-2*IONE+1))/2
      JTMAX=NTAROP
      IF(NOMWRT.LT.0.AND.-NOMWRT.LT.NOMT)THEN
        NOMT=-NOMWRT
        K=0
        DO J=1+IONE,NTAROP
          DO I=1,J-IONE
            K=K+1
          ENDDO
          IF(K.GE.NOMT)GO TO 11
        ENDDO
  11    JTMAX=MIN(J,NTAROP)
      ENDIF
      IF(NOMWRT.GT.0.AND.NOMWRT.LT.(NAST*(NAST-2*IONE+1))/2)THEN
        K=0
        DO J=1+IONE,NTAROP
          IP=MIN(ITMAX,J-IONE)
          DO I=1,IP
            K=K+1
          ENDDO
        ENDDO
        NOMT=K
      ENDIF
      DO J=1,NAST
        DO I=1,J
          KTST(I,J)=0
        ENDDO
      ENDDO
C
      IJST=0
      J2=IONE*NCONAT(1)
      DO 130  JT=1+IONE,JTMAX
        IF(NCONAT(JT).EQ.0)GOTO 130
        J1=J2+1
        J2=J2+NCONAT(JT)
        I2=0
        DO 120  IT=1,JT-IONE
          IF(NCONAT(IT).EQ.0)GOTO 120
          I1=I2+1
          I2=I2+NCONAT(IT)
          IJST=IJST+1
          OMT=TZERO
          KTST(IT,JT)=IJST
          DO J=J1,J2
            DO I=I1,I2
              OMT=OMT+RK(I,J)
            ENDDO
          ENDDO
          OMST(IJST)=OMT
          ITST(IJST)=IT
          JTST(IJST)=JT
 120    CONTINUE
 130  CONTINUE
C
C STORE DR OMEGA(IT,IE) BY INITIAL METASTABLE STATE IT AND ENERGY
C I.E. SUMMED OVER ALL FINAL STATES. (ELAS='YES' HERE).
C
CSTGF               .AND.NCHOP.LT.NCHF
      IF(NDRMET.GT.0                  )THEN
CSTGF        IF(QDT.OR.IQDT.NE.0)THEN
          ITT=MIN(NDRMET,NTAROP)
          I2=0
          DO 135  IT=1,ITT
            IF(NCONAT(IT).EQ.0)GO TO 135
            I1=I2+1
            I2=I2+NCONAT(IT)
            DO I=I1,I2
              OMEGDR(IT,IE)=OMEGDR(IT,IE)+PDR(I)
            ENDDO
 135      CONTINUE
CSTGF        ENDIF
      ENDIF
C
C TOP-UP NOW CONTROLLED BY LRGLAM
C
      IF(LRGLAM.GE.0)CALL TOP2
C
C WRITE TARGET STATES AND COLLISION STRENGTHS
C
      IF(ISGPT.NE.0)WRITE(14,776)
      IF(IPRINT.GT.-2)WRITE(6,777)
      IF(IPRINT.GT.-2)
     X WRITE(6,601)ETOT,QDT,IPERT,(ITST(K),JTST(K),OMST(K),K=1,IJST)
C
C ADD TO OMEGA
C
      IF(NOMT.GT.0)THEN
        IFLG=0
        IF(MPOS(IE).GT.0) THEN
          K=MPOS(IE-1)
          DO JT=1+IONE,JTMAX
            ITP=MIN(JT-IONE,ITMAX)
            DO IT=1,ITP
              K=K+1
              KK=KTST(IT,JT)
              IF(KK.GT.0)THEN
                OMEM(K)=OMEM(K)+OMST(KK)
                IF(OMST(KK).GT.1.0E-10)IFLG=1
              ENDIF
            ENDDO
          ENDDO
        ELSEIF(MPOS(IE).LT.0) THEN
          NREC=-MPOS(IE)
          CALL OMREAD(OMEGA,NOMT,NREC)
          K=0
          DO JT=1+IONE,JTMAX
            ITP=MIN(JT-IONE,ITMAX)
            DO IT=1,ITP
              K=K+1
              KK=KTST(IT,JT)
              IF(KK.GT.0)THEN
                OMEGA(K)=OMEGA(K)+OMST(KK)
                IF(OMST(KK).GT.1.0E-10)IFLG=1
              ENDIF
            ENDDO
          ENDDO
          CALL OMWRIT(OMEGA,NOMT,NREC)
        ENDIF
        IF(IFLG.EQ.1.AND.LRGL2.GT.ISKP0)ISKP(IE)=LRGL2+LINC
      ENDIF
C
C CALCULATE THE PARTIAL CROSS SECTIONS
C
      IF(ISGPT*ITRMN*ITRMX.NE.0)THEN
        IF(NOMWRT.GT.0)THEN
          SIGPWT=TZERO
          K=0
          DO IT=1,ITMAX
            DO JT=IT+IONE,NAST
              K=K+1
              IF(K.GE.ITRMN.AND.K.LE.ITRMX) THEN
                ITST(K)=IT
                JTST(K)=JT
                KK=KTST(IT,JT)
                IF(KK.GT.0)THEN
                  WWI=ISAT(IT)*(2*LAT(IT)+1)
                  IF(NSPN2.EQ.0) WWI=LAT(IT)+1
                  EKI=AZAZ*(ETOT-ENAT(IT))
                  SIGPW(K)=CONSIG*OMST(KK)/(WWI*EKI)
                  SIGPWT=SIGPWT+SIGPW(K)
                ELSE
                  SIGPW(K)=TZERO
                ENDIF
              ENDIF
            ENDDO
          ENDDO
        ENDIF
        IF(NOMWRT.LT.0)THEN
          SIGPWT=TZERO
          K=0
          DO JT=1+IONE,NAST
            DO IT=1,JT-IONE
              K=K+1
              IF(K.GE.ITRMN.AND.K.LE.ITRMX) THEN
                ITST(K)=IT
                JTST(K)=JT
                KK=KTST(IT,JT)
                IF(KK.GT.0)THEN
                  WWI=ISAT(IT)*(2*LAT(IT)+1)
                  IF(NSPN2.EQ.0) WWI=LAT(IT)+1
                  EKI=AZAZ*(ETOT-ENAT(IT))
                  SIGPW(K)=CONSIG*OMST(KK)/(WWI*EKI)
                  SIGPWT=SIGPWT+SIGPW(K)
                ELSE
                  SIGPW(K)=TZERO
                ENDIF
              ENDIF
            ENDDO
          ENDDO
        ENDIF
        WRITE(14,6011) ETOT,(ITST(K),JTST(K),SIGPW(K),K=ITRMN,ITRMX)
        WRITE(14,6012) ITRMN,ITRMX,SIGPWT
      ENDIF
C
C
 666  IPERT=IABS(IPERT)
C
C
      RETURN
C
C FORMATS
C
  601 FORMAT(F9.5,L3,I6,2X,3(I3,I3,1PE11.3)/(20X,3(I3,I3,E11.3)))
  640 FORMAT(//7X,'ENERGY',13X,'S',2X,'L',1X,'PI',6X,'TI',
     1 1X,'LI',4X,'TJ',1X,'LJ',7X,'OMEGA'/)
  650 FORMAT(5X,E14.6,5X,3I3,5X,2I3,3X,2I3,5X,E14.6)
  651 FORMAT(47X,'OMEGA-DR = ',1PE14.6)
  655 FORMAT(' FDIP FAILURE: IFAIL=',I2,' FOR I,J=',2I4,' E,L='
     X       ,2(1PE13.5,I3))
  660 FORMAT(3I5,1PE14.8)
  668 FORMAT(/2X,'I',2X,'T',3X,'L'3X,'K/NU')
  669 FORMAT(I3,I3,I4,F7.2)
  670 FORMAT(2I5)
  671 FORMAT(3I5)
  680 FORMAT(E15.6)
  695 FORMAT(' T-MATRIX VIOLATES UNITARITY FOR ETOT=',F12.8,3X,
     X'IPERT=',I2,4X,'I,J=',2I3,4X,'T**2=',F7.4)
  707 FORMAT(/'   REACTANCE MATRIX FOR ETOT = ',F10.6//
     1  (I9,6I11))
  708 FORMAT(/'   DIPOLE MATRIX FOR ETOT = ',F10.6//
     1  (I9,6I11))
  710 FORMAT(I3,1P7E11.3/(3X,7E11.3))
  720 FORMAT(//3X,'I',3X,'J',4X,' IT',1X,' JT',7X
     X,'OMEGA-CC',2X,'OMEGA-CBE',6X,'CBE/CC')
  721 FORMAT(2I4,3X,2I4,4X,2(1PE11.3),0PF12.5)
  776 FORMAT(//'   ETOT',3X,
     1 'INITIAL AND FINAL TARGET LEVELS, AND CROSS SECTIONS (Mb)'/)
  777 FORMAT(//'   ETOT',3X,'QDT',2X,'IPERT',2X,
     1 'INITIAL AND FINAL TARGET LEVELS, AND COLLISION STRENGTHS'/)
 6011 FORMAT(F9.5,1X,3(I3,I3,1PE13.5)/(10X,3(I3,I3,E13.5)))
 6012 FORMAT('THE TOTAL CROSS SECTION FOR TRANSITIONS',I3,' TO ',
     X I3,' EQUALS ',1PE13.5,' Mb')
C
      END
C***************************************************************
C
      SUBROUTINE READ1
C
C  READS DATA INDEPENDENT OF SLPI FROM R-MATRIX FILE, FILA
C
C  THE FOLLOWING DATA ARE READ _
C       NZ = NUCLEAR CHARGE
C       NELC = NUMBER OF ELECTRONS IN TARGET
C       NAST = NUMBER OF TARGET STATES
C       LRANG2 = TOTAL NUMBER OF SMALL L/BIG K VALUES
C       LAMAX = MAXIMUM LAMBDA FOR MULTIPOLE POTENTIALS
C       RA = R-MATRIX RADIUS
C       BSTO = LOGARITHMIC DERIVATIVE
C       FOR I = 1,NAST -
C               ENAT(I) = TARGET ENERGIES
C               LAT(I) = TARGET ORBITAL ANGULAR MOMENTA
C               ISAT(I) = VALUES OF (2*S+1) FOR TARGET STATES
C       FOR I = 1,3 AND L = 1,LRANG2 -
C               COEFF(I,L) = BUTTLE CORRECTION FITS
C       FOR I=1,NBUTD(L) FOR L=1,LRANG2 DARC BUTTLE CORRECTION
C               EBUTD(I,L),CBUTD(I,L)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      LOGICAL EX
C
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZ,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/DBUT/EBUTD(MZNRG,MZLP1),CBUTD(MZNRG,MZLP1),NBUTD(MZNRG)
     X           ,K2P(MZCHF)
      COMMON/NRBLMX/LMX
      COMMON/PART/EIGENS(MZNRG,MZLP1),ENDS(MZNRG,MZLP1),SI(MZCHF),
     X            TRACE,NRANG1(MZLP1),NRANG2,IPRCENT
C
C  READ AND DIMENSION CHECKS
C
      IF(IWORD.EQ.2)GO TO 50
      READ(10)NELC,NZ,LRANG2,LAMAX,NAST,RA,BSTO
C
      IF(LRANG2.LT.0)THEN     !FROM DARC DSTG2 VIA DTO3.
        LRANG2=-LRANG2
        KFLAG=-1
      ENDIF
C
      IF(LAMAX.GT.MZLMX)THEN
        WRITE(6,614)LAMAX,MZLMX
        LAMAX=MZLMX
      ENDIF
C
      IF(LMX.GT.LAMAX)THEN
        WRITE(6,615)LMX,LAMAX
        LMX=LAMAX
      ENDIF
C
      IF(NAST.LT.0)THEN
        IPRCENT=0
        NAST=-NAST
      ELSE
        IPRCENT=100
      ENDIF
C
      IF(NAST.GT.MZTAR)THEN
        WRITE(6,610)NAST
        STOP '*** DIMENSION EXCEEDED: INCREASE MZTAR'
      ENDIF
C
      READ(10)(ENAT(I),I=1,NAST)
      READ(10)(LAT(I),I=1,NAST)
      READ(10)(ISAT(I),I=1,NAST)
C
      IF(LRANG2.GT.MZLP1)THEN
        WRITE(6,620)LRANG2,MZLP1
        STOP '*** DIMENSION EXCEEDED: INCREASE MZLP1'
      ENDIF
C
      READ(10)((COEFF(I,L),I=1,3),L=1,LRANG2)
C
      IF(IPRCENT.NE.100)THEN              !FOR PARTITIONED
        READ(10)IPRCENT,NRANG2
        IF(NRANG2.GT.MZNRG)THEN
          WRITE(6,625)NRANG2,MZNRG
          STOP  '*** DIMENSION EXCEEDED: INCREASE MZNRG'
        ENDIF
        DO L = 1,LRANG2
          READ (10) (EIGENS(N,L),N=1,NRANG2)
          READ (10) (ENDS(N,L),N=1,NRANG2)
        ENDDO
      ENDIF
C
      INQUIRE(FILE='DBUT.DAT',EXIST=EX)
      IF(EX)THEN
        IWORD=-1
        IB=11
        OPEN(11,FILE='DBUT.DAT',FORM='UNFORMATTED')
        GO TO 51
      ENDIF
C
      RETURN
C
C DARC
   50 READ(10)
      READ(10)NELC,NZ,NRANG2,LRANG2,NAST,RA,BSTO
C
      IF(NAST.GT.MZTAR)THEN
        WRITE(6,610)NAST
        STOP '*** DIMENSION EXCEEDED: INCREASE MZTAR'
      ENDIF
C
      READ(10)(ENAT(I),I=1,NAST)
      READ(10)(LAT(I),I=1,NAST)
C
      DO I=1,NAST
        LAT(I)=ABS(LAT(I))-1
        ISAT(I)=0
      ENDDO
C
      IF(LRANG2.GT.MZLP1)THEN
        WRITE(6,620)LRANG2,MZLP1
        STOP '*** DIMENSION EXCEEDED: INCREASE MZLP1'
      ENDIF
C
      IB=10
C
   51 DO L=1,LRANG2
        READ(IB)NBUTD(L)
        IF(NBUTD(L).GT.MZNRG)THEN
          WRITE (6,699) NBUTD(L),MZNRG
          STOP '*** DIMENSION EXCEEDED: INCREASE MZNRG'
        ENDIF
        READ(IB)(EBUTD(I,L),I=1,NBUTD(L))
        READ(IB)(CBUTD(I,L),I=1,NBUTD(L))
      ENDDO
C
      IF(IB.EQ.11)CLOSE(11)
C
      RETURN
C
  610 FORMAT(///20X,'TOO MANY TARGET STATES'//
     1 10X,'VALUE READ FOR NAST IS ',I3//
     2 10X,'MAXIMUM ALLOWED BY DIMENSIONS IS MZTAR'//)
  614 FORMAT(///20X,'WARNING TOO MANY MULTIPOLES PRESENT VIZ.',I3//
     2 20X,'MAXIMUM ALLOWED BY DIMENSIONS IS:',I3//)
  615 FORMAT(///20X,'WARNING TOO MANY MULTIPOLES REQUESTED VIZ.',I3//
     2 20X,'MAXIMUM AVAILABLE/ALLOWED BY DIMENSIONS IS:',I3//)
  620 FORMAT(///20X,'TOO MANNY BUTTLE COEFFICIENTS'//
     1 10X,'VALUE READ FOR LRANG2 IS ',I3//
     2 10X,'MAXIMUM VALUE ALLOWED BY DIMENSIONS IS MZLP1 =',I3//)
  625 FORMAT(//' ******* NRANG2 = ',I4,'  LARGER THAN ',
     + 'MZNRG = ',I4//)
  699 FORMAT(//' ******* NBUT = ',I4,'  LARGER THAN ',
     + 'MZNRG = ',I4//)
C
      END
C***************************************************************
C
      SUBROUTINE READ2(IOPT1)
C
C  READS R-MATRIX DATA FOR ONE SLPI CASE, FROM FILA
C
C  THE FOLLOWING DATA ARE READ -
C       LRGL2 = TOTAL ORBITAL ANGULAR MOMENTUM/ 2J
C       NSPN2 = TOTAL (2*S+1)/0
C       NPTY2 = TOTAL PARITY
C       NCHAN = NUMBER OF CHANNELS
C       MNP2 = NUMBER OF R-MATRIX POLES
C       MORE2 = ZERO TO TERMINATE SLPI CASES
C       FOR I = 1,NAST -
C               NCONAT(I) = NUMBER OF CHANNELS FOR TARGET STATE I
C       FOR I = 1,NCHAN -
C               L2P(I), KJ(I) = SMALL L AND BIG jK FOR CHANNEL I
C                             = K-1, 0 FROM DSTG2/DARC
C       FOR I = 1,NCHAN AND N = 1,NCHAN AND M = 1,LAMAX -
C               CF(I,N,M) = COEFFICIENTS IN MULTIPOLE POTENTIALS
C       FOR I = 1,MNP2 -
C               VALUE(I) = R-MATRIX POLE ENERGIES
C       FOR K = 1,NCHAN AND I = 1,MNP2 -
C               WMAT(I,K) = R-MATRIX AMPLITUDES
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2)
C
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZ,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/CDEC/ARAD(MXTST),ARDEC(MZTAR),SLIN(MXTST),IRDEC,IEND
     X,IPAR(MZTAR),NEWAR
      COMMON/CDEGEN/ENATR(MZTAR),NASTD,NASTR,NLEV(MZTAR),NCNATR(MZTAR)
     X,IWD(MZTAR),IWT
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/DBUT/EBUTD(MZNRG,MZLP1),CBUTD(MZNRG,MZLP1),NBUTD(MZNRG)
     X           ,K2P(MZCHF)
      COMMON/PART/EIGENS(MZNRG,MZLP1),ENDS(MZNRG,MZLP1),SI(MZCHF),
     X            TRACE,NRANG1(MZLP1),NRANG2,IPRCENT
C
C  READ AND DIMENSION CHECKS
C
      IF(IWORD.NE.2)THEN
        READ(10,END=999)LRGL2,NSPN2,NPTY2,NCHAN,MNP2,MORE2
      ELSE                               !DARC
        READ(10,END=999)LRGL2,NPTY2,NCHAN,MNP2,NCFGP,LAMAX
        MORE2=1
        LRGL2=ABS(LRGL2)-1
        NSPN2=0
        IF(NPTY2.EQ.-1)THEN
          NPTY2=1
        ELSE
          NPTY2=0
        ENDIF
        KFLAG=-2
      ENDIF
C
      READ(10)(NCONAT(I),I=1,NASTR)     ! NAST?

      IF(NCHAN.GE.MZCHF)THEN            !.GE. FOR SR.LU
        WRITE(6,600)NSPN2,LRGL2,NPTY2,NCHAN
        STOP  '*** DIMENSION EXCEEDED: INCREASE MZCHF'
      ENDIF
C
      IF(NSPN2.NE.0)READ(10)(L2P(I),I=1,NCHAN)
      IF(NSPN2.EQ.0)THEN
        IF(KFLAG.EQ.1)READ(10,ERR=997)(L2P(I),I=1,NCHAN),
     X                                      (KJ(I),I=1,NCHAN)
        IF(KFLAG.NE.1)READ(10)(L2P(I),I=1,NCHAN)
      ENDIF
C
      IF(LAMAX.GT.0)            !DIMENSION TEST ON LAMAX NOW IN SR.READ1
     XREAD(10)(((CF(I,N,M),I=1,NCHAN),N=1,NCHAN),M=1,LAMAX)
C
      IF(iabs(MNP2).GT.MZMNP)THEN
        WRITE(6,610)NSPN2,LRGL2,NPTY2,MNP2
        STOP '*** DIMENSION EXCEEDED: INCREASE MZMNP'
      ENDIF
C
      IF(IPRCENT.NE.100)READ(10)TRACE
C
      IF(MNP2.GE.0)THEN
        READ(10)(VALUE(I),I=1,MNP2)
        READ(10)((WMAT(I,K),K=1,NCHAN),I=1,MNP2)
      ELSE                                   !DIVIDED WMAT - CPB
        MNP2=-MNP2
C      write(0,*)'get read2 div',NCHAN,MNP2
        READ(10)(VALUE(I),I=1,MNP2)
        KK=0
  13    READ(10)ILOW,IUPPER,NDIV
        READ(10)((WMAT(I-ILOW+1+KK,K),K=1,NCHAN),I=ILOW,IUPPER)
        KK=KK+IUPPER-ILOW+1
        IF(ILOW.NE.1) GO TO 13
      ENDIF
C
      IF(IWORD.EQ.2)THEN                     !DARC
        DO I=1,NCHAN
          L2P(I)=2*L2P(I)                    !2*kappa
          IF(L2P(I).LT.0)L2P(I)=-L2P(I)-1    !K, analogue of L
          L2P(I)=L2P(I)-1                    !K-1
        ENDDO
      ENDIF
      IF(KFLAG.LT.0)THEN                     !L2P(I)=K-1
        DO I=1,NCHAN
          LLCH(I)=(L2P(I)+1)/2               !CHANNEL ORB ANG
          K2P(I)=LLCH(I)
          IF(LLCH(I)*2.NE.L2P(I)+1)K2P(I)=-K2P(I)-1   !KAPPA
          KJ(I)=0                            !AS JJ COUPLING
        ENDDO
      ELSE
        DO I=1,NCHAN
          LLCH(I)=L2P(I)                     !CHANNEL ORB ANG
        ENDDO
      ENDIF
C
C  GROUP TOGETHER CHANNELS BELONGING TO DEGENERATE LEVELS
C  AND PRESERVE THE READ VALUES OF NCONAT IN /CDEGEN/
      IF(IOPT1.GT.9) NASTR=NAST
      IF(NASTD.GT.0)THEN
        DO I=1,NASTR
          NCNATR(I)=NCONAT(I)
        ENDDO
        IF(IOPT1.LT.10)THEN
          N1=1
          DO I=1,NASTD
            NCON=0
            N2=NLEV(I)+N1-1
            DO IN=N1,N2
              NCON=NCON+NCNATR(IN)
            ENDDO
            NCONAT(I)=NCON
            N1=N2+1
          ENDDO
        ENDIF
      ENDIF
C
C  TARGET PARITIES
C
      K=1
      DO I=1,NAST
        IF(NCONAT(I).NE.0)THEN
          IF(IPAR(I).LT.0)IPAR(I)=ABS(NPTY2-LLCH(K)+2*(LLCH(K)/2))
          K=K+NCONAT(I)
        ENDIF
      ENDDO
C
      IF (NSPN2.EQ.0.AND.KFLAG.EQ.0) THEN
C
C      RECOVER THE K CHANNEL NUMBERS (BASED ON SR.NJCHAN) IF
C      NOT READ FROM H.DAT
C
      NJCHA = 0
C
C      LOOP OVER THE TARGET STATES.
C
      DO 4 I = 1,NAST
C
C      LOOP OVER THE ONLY TWO POSSIBLE 2K VALUES, THAT IS LRGL2-1,LRGL2+1
C
        IFIN = 3
        IF (LRGL2.EQ.0) IFIN = 1
        DO 3 K = 1,IFIN,2
          JK = ABS(LRGL2-2+K)
C
C      RECOVER THE RANGE OF L(INCIDENT) VALUES.
C
          LMIN = ABS(LAT(I)-JK)
          LMAX = LAT(I) + JK
C
C      CHECK IF LMIN IS AN INTEGER.
C
          IF (MOD(LMIN,2).NE.0) GOTO 3
C
C      CHECK THE PARITY OF LMIN.
C
          LP = LMIN/2 + IPAR(I)
          IF (MOD(LP,2).NE.NPTY2) LMIN = LMIN + 2
C
          LP = (LMIN+LMAX)/2
          IF (MOD(LP,2).EQ.1) LMAX = LMAX - 2
          IF (LMIN.GT.LMAX) GOTO 3
C
C      STORE THE 2K-VALUES IN KJ.
C
          LMIN = LMIN + 1
          LMAX = LMAX + 1
          DO 2 L = LMIN,LMAX,4
            NJCHA = NJCHA + 1
            KJ(NJCHA) = JK
    2     CONTINUE
    3   CONTINUE
    4 CONTINUE
C
C END RECOVERY OF K QUANTUM NUMBER
C
      ENDIF
C
      RETURN
C
  999 MORE2=-777
      RETURN
C
  997 WRITE(6,*)'***SR.READ2 ERROR, TRY SETTING KLAG=0'
      STOP '***SR.READ2 ERROR, TRY SETTING KLAG=0'
C
  600 FORMAT(///20X,'TOO MANY CHANNELS FOR (IS, IL, IP) = (',
     1  3I3,')'//10X,'VALUE READ FOR NCHAN IS ',I4//
     2  10X,'MAXIMUM ALLOWED BY DIMENSIONS IS MZCHF'//)
  610 FORMAT(///20X,'TOO MANY R-MATRIX STATES FOR (IS, IL, IP) = (',
     * 3I3,')'//10X,'VALUE READ FOR MNP2 IS ',I5//
     3 10X,'MAXIMUM ALLOWED BY DIMENSIONS IS MZMNP'//)
C
      END
C**********************************************************************
C
      SUBROUTINE READB(MF)
C
C  READS BOUND DATA
C  NOTE: B-DATA IS NOT PERTURBED.
C        IPERTB IS JUST USED TO SKIP THE CORRECT NUMBER OF RECORDS.
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (MNPEXT=MZMNP+MZCHF)
C
      PARAMETER (TZERO=0.0)
C
      COMMON/A1/AVECT1(MNPEXT,MZEST),MXE1
      COMMON/BDSYM/ISB(MZSLP),ILB(MZSLP),IPB(MZSLP),NFILEB,
     1             ISDL(MZSLP),ILDL(MZSLP),IPDL(MZSLP),NFILED,
     2             ISDR(MZSLP),ILDR(MZSLP),IPDR(MZSLP),
     3             NFBD,NFB(3),NFD(3),MXEB(3)
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR),
     5 WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/CNTRLB/IPERTB
      COMMON/RADDEC/EDEC(MZDEC),DDEC(MNPEXT,MZDEC),NDEC
C
      CHARACTER FILE*3,NUM(0:9)
      DATA NUM/'0','1','2','3','4','5','6','7','8','9'/
C
      FILE='B'//NUM(MF/10)//NUM(MF-10*(MF/10))
      OPEN(2,FILE=FILE,STATUS='OLD',FORM='UNFORMATTED',ERR=90)
      REWIND(2)
C
C  READ E1-INDEPENDENT DATA
C
      READ(2)IS,IL,IP
C    *******CHECK SLPI
      IF(IS.NE.ISB(MF).OR.IL.NE.ILB(MF).OR.IP.NE.IPB(MF))THEN
        WRITE(6,*)' ***ERROR** IS,IL,IP .NE. ISB,ILB,IPB'
        WRITE(6,*)IS,IL,IP,ISB(MF),ILB(MF),IPB(MF)
      STOP
      ENDIF
C
      READ(2)MNP2B
            IF(MNP2B.GT.MZMNP) THEN
              WRITE(6,613)MNP2B
              STOP
            ENDIF
      READ(2)
      READ(2)
      IF(IPERTB.EQ.1)READ(2)
      READ(2)MXE1
C
      IF(MXE1.GT.MZEST)THEN
        WRITE(6,612)MXE1
        STOP
      ENDIF
C
      NDEC=NDEC+MXE1
      IF(NDEC.GT.MZDEC)THEN
        WRITE(6,614)NDEC
        STOP
      ENDIF
      N0=NDEC-MXE1+1
      NREC=5
      IF(IPERTB.EQ.1)NREC=NREC+3
C
C  READ E1-DEPENDENT DATA
C
      IE=0
      DO ND=N0,NDEC
        IE=IE+1
        READ(2) EDEC(ND)
        READ(2) (AVECT1(K1,IE),K1=1,MNP2B)
        DO NR=1,NREC
          READ(2)
        ENDDO
      ENDDO
C
      IF(IPRKM.EQ.2)WRITE(38)EDEC(1),NZED-NELC
C
      CLOSE(2)
      RETURN
C
   90 WRITE(6,696) FILE
      STOP
C
  612 FORMAT(//'    NO OF BOUND STATE ENERGIES MXE1 = ',I4
     X,' WHICH IS LARGER THAN ',
     1 'MAXIMUM VALUE OF MZEST ALLOWED BY DIMENSIONS'//)
  613 FORMAT(//'    READS MNP2B = ',I4,' WHICH IS LARGER THAN ',
     1 'MAXIMUM VALUE OF MZMNP ALLOWED BY DIMENSIONS'//)
  614 FORMAT(//'    NO OF DECAYS NDEC = ',I4,' WHICH IS LARGER THAN ',
     1 'MAXIMUM VALUE OF MZDEC ALLOWED BY DIMENSIONS'//)
  696 FORMAT(/' *** CANNOT OPEN FILE ',A/)
C
      END
C**********************************************************************
C
      SUBROUTINE READB0
C
C  READ DIRECTORY FILES ON B DATASETS
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      LOGICAL FEXIST
C
      INCLUDE 'PARAM'
C
      COMMON/BDSYM/ISB(MZSLP),ILB(MZSLP),IPB(MZSLP),NFILEB,
     1             ISDL(MZSLP),ILDL(MZSLP),IPDL(MZSLP),NFILED,
     2             ISDR(MZSLP),ILDR(MZSLP),IPDR(MZSLP),
     3             NFBD,NFB(3),NFD(3),MXEB(3)
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR),
     5 WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/CNTRLB/IPERTB
      COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2
      COMMON/TYPE/NTYP1,NTYP2I,NTYP2OF,NTYP2OR,NMIN
C
C  INITIAL BOUND STATE DATA
C
      INQUIRE(FILE='B00',EXIST=FEXIST)
      IF(FEXIST)THEN
       OPEN(2,FILE='B00',STATUS='OLD',FORM='UNFORMATTED')
      ELSE
        WRITE(6,505)
        STOP 'STGB DATASET B00 NOT FOUND'
      ENDIF
C
      REWIND(2)
C
      READ(2)NZEDB,NELCB
      READ(2)
      READ(2)RZEROB
      READ(2)
      READ(2)IPERTB
C
      IF(NZEDB.NE.NZED.OR.NELCB.NE.NELC)THEN
        WRITE(6,504)NZEDB,NELCB,NZED,NELC
        STOP 'STGB - STGF MIS-MATCH'
      ENDIF
      IF(ABS(RZERO-RZEROB).GT.1.E-4)THEN
        WRITE(6,503)RZEROB,RZERO
        STOP 'STGB - STGF MIS-MATCH'
      ENDIF
      IF(IPRINT.GT.0)WRITE(6,501)
      KSLP1=0
C
C  AND LIST OF SLPI CASES
C
    5 READ(2,END=77)IS,IL,IP
      IF(IL.NE.-1) THEN
        KSLP1=KSLP1+1
        NFILEB=KSLP1
        ISB(NFILEB)=IS
        ILB(NFILEB)=IL
        IPB(NFILEB)=IP
        IF(IPRINT.GT.0)WRITE(6,502)KSLP1,IS,IL,IP
        GOTO 5
      ELSE
        IF(NMIN.NE.0)THEN
          READ(2,END=77)NMAX
          IF(NMIN.LT.0)THEN
            NMIN=NMAX+1
          ELSEIF(NMIN.NE.NMAX+1)THEN
            WRITE(6,507)NMIN,NMAX
          ENDIF
        ENDIF
      ENDIF
   77 IF(NMIN.LT.0)THEN
      WRITE(6,506)
      STOP'*** UNABLE TO DETERMINE NMIN FROM B00 FOR NTYP2O RADIATION'
      ENDIF
C
      CLOSE(2)
C
      RETURN
C
  501 FORMAT(//10X,'FROM STGB DATASET'/10X,'KSLP',3X,'IS',3X,'IL',3X,
     1      'IP')
  502 FORMAT(10X,I3,4X,I2,3X,I2,3X,I2)
  503 FORMAT(//' STGB - STGF MIS-MATCH: RZERO=',2F8.4)
  504 FORMAT(//' STGB - STGF MIS-MATCH: NZED, NELC=',4I3)
  505 FORMAT(/'*** ERROR: UNABLE TO FIND DIRECTORY FILE B00 ***'//
     X' EITHER GENERATE SUITABLE BOUND FILES *OR* SET:  NTYP2I=0'/
     X' WHICH SWITCHES-OFF TYPE-2 (OUTER ELECTRON) RADIATION INTO',
     X' THE BOX.')
  506 FORMAT(/'*** ERROR: UNABLE TO DETERMINE NMIN FROM B00 FOR',
     X' NTYP2O RADIATION - TRY UPDATING STGB TO UoS 2.17 OR LATER.'/
     X' IN THE MEAN TIME, EITHER SET NMIN EXPLICITLY OR TURN OFF',
     X' TYPE-2 (OUTER ELECTRON) RADIATION TO NON-BOX STATES'/
     X' VIA: NTYP2OR=0 NTYP2OF=0')
  507 FORMAT(/'*** WARNING: YOUR INPUT VALUE OF NMIN (=',I4,') DOES',
     X' NOT APPEAR TO BE CONSISTENT WITH NMAX FROM STGB (=',I4,')'/)
C
      END
C**********************************************************************
C
      SUBROUTINE READD(LPOS,LV)
C
C  ADAPTED FROM
C  PROGRAM OF KTT FOR READING DIPOLE MATRIX ELEMENT DATA
C  AND KB/WE FOR REDUCED MEMORY - ERRORS CORRECTED BY NRB 10/03/99.
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (MNPEXT=MZMNP+MZCHF)
      PARAMETER (MXLV=2)
C
      PARAMETER (TZERO=0.0)
C
      COMMON/A1/AVECT1(MNPEXT,MZEST),MXE1
      COMMON/RADDEC/EDEC(MZDEC),DDEC(MNPEXT,MZDEC),NDEC
C
      DIMENSION D(MNPEXT,MZNRG,MXLV)              !USE MZNRG - NRB
C
      CHARACTER  DKK*3,NUM(0:9)
      DATA NUM/'0','1','2','3','4','5','6','7','8','9'/
C
C************ STGFDAMP/STGBF0DAMP ********************
      IBUT=0
C*****************************************
C
      IF(LV.GT.MXLV)THEN
         WRITE(6,*)' ****INCREASE PARAMETER MXLV TO:',LV
         STOP
      ENDIF
C
      MLAST=NDEC
      M11=MLAST-MXE1+1
C
      DO M1=M11,MLAST
        DO K2=1,MNPEXT
          DDEC(K2,M1)=TZERO
        ENDDO
      ENDDO
C
      LTAPE=3
      K1 = ABS(LPOS)
      DKK='D'//NUM(K1/10)//NUM(K1-10*(K1/10))
C     write(6,*)'about to open ',DKK
      OPEN(LTAPE,FILE=DKK,STATUS='OLD',FORM='UNFORMATTED',ERR=99)
      REWIND LTAPE
C
      READ(LTAPE) NOTERM,MNP2D2,NCHND2,LRGLD2,NPTYD2,
     &  NSPND ,MNP2D1,NCHND1,LRGLD1
C
C  CHECK DIMENSIONS FOR MNP2,MZCHF
      N=MAX(NCHND1,NCHND2)
      M=MAX(MNP2D1,MNP2D2)
      IF(M.GT.MZMNP.OR.N.GT.MZCHF) THEN
        WRITE(6,600)MNP2D1,NCHND1,MNP2D2,NCHND2
        STOP
      ENDIF
C
C  CHECK DIMENSION FOR "NR2".
C  STGFDAMP DOES NOT USE BUTTLE CORRECTION AND SO COULD JUST USE MZNR2
C  BUT WILL USE THE RELATED OUTER REGION PARAMETER MZNRG INSTEAD. NRB
      IF(NOTERM.GT.MZNRG)THEN
        WRITE(6,601)NOTERM
        STOP
      ENDIF
C
C  READ DIPOLE MATRIX - TRANSPOSING IF -VE LPOS
C
      IAIN1 = (MNP2D1 - 1) / NOTERM
      IBIN1 = (MNP2D2 - 1) / NOTERM
      MCI = 0
      DO IK = 1 , IAIN1
        MCH = MCI + 1
        MCI = MCI + NOTERM
        NCI = 0
        DO JK = 1 , IBIN1
          NCH = NCI + 1
          NCI = NCI + NOTERM
          READ(LTAPE) (((D(J,I,L),J=1,NOTERM),I=1,NOTERM),L=1,LV)
          IF(LPOS.GT.0) THEN
                M1P=0
                DO M1=M11,MLAST
                  M1P=M1P+1
              K1P = 0
              DO K1=MCH,MCI
                K1P=K1P+1
            K2P = 0
            DO K2=NCH,NCI
              K2P=K2P+1
                  DDEC(K2,M1)=DDEC(K2,M1)+AVECT1(K1,M1P)*D(K2P,K1P,LV)
            ENDDO
              ENDDO
                ENDDO
          ELSE
                M1P=0
                DO M1=M11,MLAST
                  M1P=M1P+1
              K2P = 0
              DO K2=MCH,MCI
                K2P=K2P+1
            K1P = 0
            DO K1=NCH,NCI
              K1P=K1P+1
                  DDEC(K2,M1)=DDEC(K2,M1)+AVECT1(K1,M1P)*D(K1P,K2P,LV)
            ENDDO
              ENDDO
                ENDDO
          ENDIF
        ENDDO
        NCH = NCI + 1
        NCI = MNP2D2
        NCP=NCI-NCH+1
        READ(LTAPE) (((D(J,I,L),J=1,NCP),I=1,NOTERM),L=1,LV)
        IF(LPOS.GT.0) THEN
              M1P=0
              DO M1=M11,MLAST
                M1P=M1P+1
            K1P = 0
            DO K1=MCH,MCI
              K1P=K1P+1
          K2P = 0
          DO K2=NCH,NCI
            K2P=K2P+1
                DDEC(K2,M1)=DDEC(K2,M1)+AVECT1(K1,M1P)*D(K2P,K1P,LV)
          ENDDO
            ENDDO
              ENDDO
        ELSE
              M1P=0
              DO M1=M11,MLAST
                M1P=M1P+1
            K2P = 0
            DO K2=MCH,MCI
              K2P=K2P+1
          K1P=0
          DO K1=NCH,NCI
            K1P=K1P+1
                DDEC(K2,M1)=DDEC(K2,M1)+AVECT1(K1,M1P)*D(K1P,K2P,LV)
          ENDDO
            ENDDO
              ENDDO
        ENDIF
      ENDDO
C
      MCH = MCI + 1
      MCI = MNP2D1
      MCP=MCI-MCH+1
      NCI = 0
      DO JK = 1 , IBIN1
        NCH = NCI + 1
        NCI = NCI + NOTERM
        READ(LTAPE) (((D(J,I,L),J=1,NOTERM),I=1,MCP),L=1,LV)
        IF(LPOS.GT.0) THEN
              M1P=0
              DO M1=M11,MLAST
                M1P=M1P+1
            K1P = 0
            DO K1=MCH,MCI
              K1P=K1P+1
          K2P = 0
          DO K2=NCH,NCI
            K2P=K2P+1
                DDEC(K2,M1)=DDEC(K2,M1)+AVECT1(K1,M1P)*D(K2P,K1P,LV)
          ENDDO
            ENDDO
              ENDDO
        ELSE
              M1P=0
              DO M1=M11,MLAST
                M1P=M1P+1
            K2P = 0
            DO K2=MCH,MCI
              K2P=K2P+1
          K1P = 0
          DO K1=NCH,NCI
            K1P=K1P+1
                DDEC(K2,M1)=DDEC(K2,M1)+AVECT1(K1,M1P)*D(K1P,K2P,LV)
          ENDDO
            ENDDO
              ENDDO
        ENDIF
      ENDDO
      NCH = NCI + 1
      NCI = MNP2D2
      NCP=NCI-NCH+1
      READ(LTAPE) (((D(J,I,L),J=1,NCP),I=1,MCP),L=1,LV)
      IF(LPOS.GT.0) THEN
            M1P=0
            DO M1=M11,MLAST
              M1P=M1P+1
          K1P = 0
          DO K1=MCH,MCI
            K1P=K1P+1
        K2P = 0
        DO K2=NCH,NCI
          K2P=K2P+1
              DDEC(K2,M1)=DDEC(K2,M1)+AVECT1(K1,M1P)*D(K2P,K1P,LV)
        ENDDO
          ENDDO
            ENDDO
      ELSE
            M1P=0
            DO M1=M11,MLAST
              M1P=M1P+1
          K2P = 0
          DO K2=MCH,MCI
            K2P=K2P+1
        K1P = 0
        DO K1=NCH,NCI
          K1P=K1P+1
              DDEC(K2,M1)=DDEC(K2,M1)+AVECT1(K1,M1P)*D(K1P,K2P,LV)
        ENDDO
          ENDDO
            ENDDO
      ENDIF
C
C  READ BUTTLE PART
C
      IF(IBUT.EQ.-1) GOTO 1000
      READ(LTAPE)
      READ(LTAPE)
      READ(LTAPE)
C
C-----READ ANGULAR COEFFICIENTS
 1000 CONTINUE
      READ(LTAPE)
      READ(LTAPE)
      CLOSE(LTAPE)
C
      RETURN
C
   99 WRITE(6,*)' *** FATAL ERROR IN READD *** '
      WRITE(6,*)' UNABLE TO OPEN DIPOLE FILE: ',DKK
      STOP
C
  600 FORMAT(//1X,30(1H*)//' DIMENSION FOR MNP2 OR NCHF TOO'
     &,' SMALL'//  ' MNP2D1, NCHND1 = ',I5,', ',I5/
     &  ' MNP2D2, NCHND2 = ',I5,', ',I5//1X,30(1H*)//)
  601 FORMAT(//1X,30(1H*)//' MZNRG TOO SMALL FOR BUFFER'//
     &  ' NEED AT LEAST ',I4//1X,30(1H*)//)
C
      END
C*********************************************************************
C
      SUBROUTINE READD0
C
C  READ DIRECTORY FILE ON D DATASET
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      LOGICAL FEXIST
C
      CHARACTER  DKK*3,NUM(0:9)
      DATA NUM/'0','1','2','3','4','5','6','7','8','9'/
C
      INCLUDE 'PARAM'
C
      COMMON/BDSYM/ISB(MZSLP),ILB(MZSLP),IPB(MZSLP),NFILEB,
     1             ISDL(MZSLP),ILDL(MZSLP),IPDL(MZSLP),NFILED,
     2             ISDR(MZSLP),ILDR(MZSLP),IPDR(MZSLP),
     3             NFBD,NFB(3),NFD(3),MXEB(3)
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
C
C  INITIAL DIPOLE DATA
C
      INQUIRE(FILE='D00',EXIST=FEXIST)
      IF(FEXIST)THEN
        OPEN(3,FILE='D00',STATUS='OLD',FORM='UNFORMATTED')
      ELSE
        WRITE(6,503)
        STOP 'STG3 DATASET D00 NOT FOUND'
      ENDIF
C
      REWIND(3)
      ICOUNT=0
C
      READ(3)KOUNT
      K1=0
      K2=1
C
      DO I=1,KOUNT
        DKK='D'//NUM(K1)//NUM(K2)
        INQUIRE(FILE=DKK,EXIST=FEXIST)
        IF(FEXIST) THEN
          ICOUNT=ICOUNT+1
          FEXIST=.FALSE.
        END IF
        K2=K2+1
        IF(MOD(K2,10).EQ.0) THEN
          K2=0
          K1=K1+1
        END IF
      ENDDO
      IFLAG=0
      IF(ICOUNT.LT.KOUNT) THEN
        IFLAG=1
        WRITE(6,502)KOUNT,ICOUNT
        KOUNT=ICOUNT
      END IF
C
      NFILED=KOUNT
      IF(IPRINT.GT.0.OR.IFLAG.GT.0)WRITE(6,500)
      DO K=1,KOUNT
        READ(3)IS1,IL1,IP1,IS2,IL2,IP2
        ISDL(K)=IS1
        ISDR(K)=IS2
        ILDL(K)=IL1
        ILDR(K)=IL2
        IPDL(K)=IP1
        IPDR(K)=IP2
        IF(IPRINT.GT.0.OR.IFLAG.GT.0)
     X     WRITE(6,501)K,IS1,IL1,IP1,IS2,IL2,IP2
      ENDDO
      CLOSE(3)
C
      RETURN
C
  500 FORMAT(//10X,'FROM D DATASET'//10X,'K',8X,'IS1',2X,'IL1',2X,'IP1',
     1       6X,'IS2',2X,'IL2',2X,'IP2'/)
  501 FORMAT(8X,I3,8X,I3,2X,I3,2X,I3,6X,I3,2X,I3,2X,I3)
  502 FORMAT (/'***WARNING: ',I3,' POSSIBLE DIPOLES BUT ONLY '
     X,I3,' GENERATED' /)
  503 FORMAT(/'*** ERROR: UNABLE TO FIND DIRECTORY FILE D00 ***'//
     X' EITHER GENERATE SUITABLE DIPOLE FILES *OR* SET:  NTYP2I=0'/
     X' WHICH SWITCHES-OFF TYPE-2 (OUTER ELECTRON) RADIATION INTO',
     X' THE BOX.')
C
      END
C***************************************************************
C
      SUBROUTINE READPQ(IE,QETEST,ISLP,IOPT1,QJUMP,PQRD)
C
C NRB:
C  CALCULATE, READ AND/OR INTERPOLATE MATRICES P AND Q,
C  WHICH MAY BE UNPHYSICAL K OR S.
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      LOGICAL PQRD,QJUMP
C
      INCLUDE 'PARAM'
C
      PARAMETER (MNPEXT=MZMNP+MZCHF)
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ZERO=(0.0,0.0))
      PARAMETER (ONE=1.0)
C
      COMMON/CEN/ETOT,MXE,NWT,NZ
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CMESH/EMAX,EMIN,DEOPEN,DQN,QNMAX,EMESH(MZMSH),IMESH
      COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT
      COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN
      COMMON/NRBRCT/
     X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF)
     X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF)
     X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF)
     X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF)
     X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF)
     X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF)
     X,RMAT(MZCHF,MZCHF)
      COMMON/NRBPH1/ZCOEF(MNPEXT,MZCHF),OMEGPR(MZMET,MZMSH),EPHMIN,
     1              EPHMAX,IPHOTO,NODAMP
      COMMON/NRBPH7/ZBB(MZDIP,MZCHF),ZDIP(MZDIP,MZCHF)
     X,ZD(MZCHF,MZCHF),ZE(MZCHF,MZCHF),ZF(MZCHF,MZCHF)
     X,IDEC(MZEPI*MZMET),JDEC(MZDEC),IPIV(MZCHF),NDEC0
C
      DIMENSION P(MZCHF,MZCHF),Q(MZCHF,MZCHF)
      DIMENSION P1(MZCHF,MZCHF),Q1(MZCHF,MZCHF)
      DIMENSION P2(MZCHF,MZCHF),Q2(MZCHF,MZCHF)
      DIMENSION IOMIT1(MZCHF),IOMIT2(MZCHF)
      DIMENSION ZD1(MZDIP,MZCHF),ZD2(MZDIP,MZCHF)
C
      EQUIVALENCE (P,CSP),(Q,CC),(P2,CCPP),(Q2,DS)
C
      SAVE IE1,IE2,MPTY1,MPTY2,E1,E2,IOMIT1,IOMIT2,P1,Q1
      SAVE ZD1,ZD2,NDEC1,NDEC2
C
C
      IF(IE.EQ.0)THEN
C
        IF(IMODE.LT.0)THEN
C
C CALCULATE UNPHYSICAL P,Q
C
          CALL POINTS(IOPT1,.FALSE.)
          CALL REACT(IOPT1,.FALSE.,.TRUE.)
C
          IF(NCHOP.NE.NCHF)STOP'READPQ: NCHOP.NE.NCHF'
          E2=ETOT
          IE2=1
          MPTY2=0   !NOT NEEDED?
          DO J=1,NCHF
            IOMIT2(J)=IOMIT(J)
            DO I=J,NCHF
              P2(I,J)=P(I,J)
              Q2(I,J)=Q(I,J)
            ENDDO
          ENDDO
          IF(IPHOTO*NDEC0.NE.0)THEN
            NDEC2=NDEC0
            DO J=1,NCHF
              DO I=1,NDEC0
                ZD2(I,J)=ZDIP(I,J)
              ENDDO
            ENDDO
          ENDIF
C
        ELSE
C
C FIRST ENERGY READ FOR THIS SYMMETRY, AND POSSIBLY FIRST READ AT ALL.
C IF IOPT1=2 WE FIRST NEED TO FIND THE CORRECT SYMMETRY.
C NCHF SHOULD BE EQUAL TO NCHF THROUGHOUT THE IQDT=1 PROBLEM.
C
          IF(IOPT1.EQ.2)THEN
            REWIND(21)
            IF(IPHOTO.NE.0)REWIND(39)
          ENDIF
   1      READ(21,END=100)IE2,MPTY2,NCHOPP,E2,NDEC2
          READ(21) (IOMIT2(I),I=1,NCHOPP)
          READ(21)((P2(I,J),I=J,NCHOPP),J=1,NCHOPP),
     X          ((Q2(I,J),I=J,NCHOPP),J=1,NCHOPP)
          IF(IPHOTO*NDEC2.NE.0)READ(39)((ZD2(I,J),I=1,NDEC2),J=1,NCHOPP)
          IF(IE2.NE.1)THEN
C HIGH ENERGY OF OLD SLP
            IF(MPTY2.NE.ISLP)GO TO 1
          ELSE
C NO SEARCH ON SLP IF IOPT1.NE.2 SO STOP IF MIS-MATCH
            IF(MPTY2.NE.ISLP)THEN
              IF(IOPT1.EQ.2)GO TO 1
            WRITE(6,*)' CHECK JBIN? MIS-MATCH ON SYMMETRIES IN PQ DATA:'
     X                ,MPTY2,ISLP
              STOP 'READPQ'
            ENDIF
          ENDIF
        ENDIF
C
        QJUMP=.TRUE.
        PQRD=.TRUE.
        E1=999999.
        RETURN
C
      ENDIF
C
C SEE IF WE NEED TO READ NEW DATA OR JUST INTERPOLATE EXISTING PQ.
C
      IF(ETOT.GT.E1-QETEST .AND. ETOT.LT.E2+QETEST)GO TO 3
C
C MOVE P2,Q2 TO P1,Q1 ETC.
C
   2  E1=E2
      IE1=IE2
      MPTY1=MPTY2
      DO J=1,NCHF
        IOMIT1(J)=IOMIT2(J)
        DO I=J,NCHF
          P1(I,J)=P2(I,J)
          Q1(I,J)=Q2(I,J)
        ENDDO
      ENDDO
      IF(IPHOTO*NDEC2.NE.0)THEN
        NDEC1=NDEC2
        DO J=1,NCHF
          DO I=1,NDEC2
            ZD1(I,J)=ZD2(I,J)
          ENDDO
        ENDDO
      ENDIF
C
      IF(IMODE.LT.0)THEN
C
C CALCULATE NEW P,Q BUT FIRST FIND APPROPRIATE ENERGY
C
        DO I=IE1+1,MXE
           IF(IEE(I).NE.0)GO TO 20
        ENDDO
        STOP ' READPQ CANNOT FIND NEXT ENERGY'
  20    IE2=I
        E2=EMESH(I)
        MPTY2=0   !NOT NEEDED?
        ETT=ETOT
        ETOT=E2
C
        CALL POINTS(IOPT1,.FALSE.)
        CALL REACT(IOPT1,.FALSE.,.TRUE.)
C
        IF(NCHOP.NE.NCHF)STOP'READPQ: NCHOP.NE.NCHF'
        ETOT=ETT
          DO J=1,NCHF
            IOMIT2(J)=IOMIT(J)
            DO I=J,NCHF
              P2(I,J)=P(I,J)
              Q2(I,J)=Q(I,J)
            ENDDO
          ENDDO
        IF(IPHOTO*NDEC0.NE.0)THEN
          NDEC2=NDEC0
          DO J=1,NCHF
            DO I=1,NDEC2
              ZD2(I,J)=ZDIP(I,J)
            ENDDO
          ENDDO
        ENDIF
        GO TO 3
      ENDIF
C
C READ A NEW P,Q SET
C
      READ(21,END=100)IE2,MPTY2,NCHOPP,E2,NDEC2
      IF(IE2.LT.IE1)THEN      !WE HAVE MOVED ONTO THE NEXT SYMMETRY SO
        BACKSPACE(21)
        E2=999999.
        GO TO 100
      ENDIF
      IF(MPTY2.NE.ISLP)THEN   !NO SEARCH ON SLP HERE SO STOP IF MIS-MATCH
        WRITE(6,*)' CHECK JBIN? MIS-MATCH ON SYMMETRIES IN PQ DATA:'
     X            ,MPTY2,ISLP
        STOP 'READPQ'
      ENDIF
      IF(NCHOPP.NE.NCHF)STOP'READPQ: NCHOP.NE.NCHF'
      READ(21) (IOMIT2(I),I=1,NCHF)
      READ(21)((P2(I,J),I=J,NCHF),J=1,NCHF),
     X        ((Q2(I,J),I=J,NCHF),J=1,NCHF)
      IF(IPHOTO*NDEC2.NE.0)READ(39)((ZD2(I,J),I=1,NDEC2),J=1,NCHF)
C                                              !SEE IF THIS ENERGY IS ENOUGH,
      IF(ETOT.GT.E2+QETEST)GO TO 2             ! ELSE MOVE AND RE-READ
C
C NOW FORM NEW P,Q (SIMPLE LINEAR INTERPOLATION), CHECK ENERGIES O.K.
C
   3    IF(ETOT.LT.E1-2.*QETEST.OR.ETOT.GT.E2+2.*QETEST)THEN
          WRITE(6,*)' CHECK JBIN? ENERGY MIS-MATCH, E1,E2,ETOT'
     X              ,E1,E2,ETOT
          STOP 'ENERGY MIS-MATCH'
        ENDIF
C
C WATCH-OUT FOR MIS-MATCH IN OMITTED CHANNELS
C
        IFOM=0
        DO J=1,NCHF
          IOMIT(J)=IOMIT1(J)+IOMIT2(J)
          IF(IOMIT(J).EQ.1)THEN
            IF(IFOM.NE.0)THEN  !IF THERE'S MORE THAN MORE CASE......
c              write(75,*)etot,ifom,j
            ELSE
              IFOM=J           !USE ONE WITH LOWEST CHANNEL OMITTED
            ENDIF
          ENDIF
        ENDDO
        IF(IFOM.NE.0)THEN                      !DON'T INTERPOLATE, INSTEAD
C          IF(ABS(E2-ETOT).LT.ABS(ETOT-E1))THEN ! USE NEAREST
          IF(IOMIT2(IFOM).EQ.1)THEN            ! USE OMITTED, MORE STABLE
            T2=-ONE
            T1=TZERO
            DO J=1,NCHF
              IOMIT(J)=IOMIT2(J)
            ENDDO
          ELSE
            T1=ONE
            T2=TZERO
            DO J=1,NCHF
              IOMIT(J)=IOMIT1(J)
            ENDDO
          ENDIF
        ELSE                  !INDEED, SAFE TO INTERPOLATE
          T1=(E2-ETOT)/(E2-E1)
          T2=(E1-ETOT)/(E2-E1)
        ENDIF
C
C NOW FORM NEW P,Q
C
        DO J=1,NCHF
          DO I=J,NCHF
            P(I,J)=T1*P1(I,J)-T2*P2(I,J)
            Q(I,J)=T1*Q1(I,J)-T2*Q2(I,J)
            P(J,I)=P(I,J)
            Q(J,I)=Q(I,J)
          ENDDO
        ENDDO
        IF(IPHOTO*NDEC2.NE.0)THEN
          NDEC0=NDEC2
          DO J=1,NCHF
            DO I=1,NDEC0
              ZDIP(I,J)=T1*ZD1(I,J)-T2*ZD2(I,J)
            ENDDO
          ENDDO
        ENDIF
C
C ZERO-OUT OMITTED CHANNELS (IF ANY IOMIT(ICHAN)=1).
C
        IF(IQDT.GT.0)THEN
          DO J=1,NCHF
            IF(IOMIT(J).EQ.1)THEN
              DO I=1,NCHF
                P(I,J)=TZERO
                Q(I,J)=TZERO
                P(J,I)=TZERO
                Q(J,I)=TZERO
              ENDDO
              IF(IQDT.EQ.1)P(J,J)=ONE
              IF(IPHOTO*NDEC0.NE.0)THEN
                DO I=1,NDEC0
                  ZDIP(I,J)=ZERO
                ENDDO
              ENDIF
            ENDIF
          ENDDO
        ELSE
          DO I=1,NCHF
            IOMIT(I)=0
          ENDDO
        ENDIF
C
      RETURN
C
C
 100  IF(IE.EQ.0)THEN    !PQ FILE DOES NOT EXIST
        PQRD=.FALSE.
        REWIND(21)
      ELSE
C NO MORE DATA AVAILABLE, PRINT WARNING, AND CONTINUE WITH OLD P,Q.
        WRITE(6,*)' ****NO MORE PQ DATA ON FILE FOR THIS SYMMETRY'
     X            ,' USING LAST ENERGY'
      ENDIF
C
      RETURN
      END
C***************************************************************
C
      SUBROUTINE RINIT
C
C NRB: USES WMAT WITH INDEXES INTERCHANGED COMPARED TO CPC.
C
C  INITIALIZE CALCULATION OF R-MATRIX.
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      LOGICAL NEWBUT
C
      INCLUDE 'PARAM'
C
      PARAMETER (MNPEXT=MZMNP+MZCHF)
C
      PARAMETER (MXNCH1=MZCHF/10+1)            !FOR DGEMM
C      PARAMETER (MXNCH1=1)                    !FOR DDOT & NON-BLAS
C
      PARAMETER (ONE=1.0)
      PARAMETER (TZERO=0.0)
C
      COMMON/CEN/ETOT,MXE,NWT,NZ
C  ***  NOTE CHANGE OF CC TO CCT IN /CHAN/ ***
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/CLOGB/NEWBUT
      COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/DBUT/EBUTD(MZNRG,MZLP1),CBUTD(MZNRG,MZLP1),NBUTD(MZNRG)
     X           ,K2P(MZCHF)
      COMMON/PART/EIGENS(MZNRG,MZLP1),ENDS(MZNRG,MZLP1),SI(MZCHF),
     X            TRACE,NRANG1(MZLP1),NRANG2,IPRCENT
C
      COMMON/NRBRCT/
     X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF)
     X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF)
     X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF)
     X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF)
     X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF)
     X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF)
     X,RMAT(MZCHF,MZCHF)
      COMMON/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF),
     X          ZA(MZCHF,MZCHF),ZB(MZCHF,MZCHF)
      COMMON/RADDEC/EDEC(MZDEC),DDEC(MNPEXT,MZDEC),NDEC
C
      DIMENSION TEMP1(MZMNP),TEMP2(MZMNP,MXNCH1)
C
      DATA IDIV/0/                             !FOR NON-DGEMM SYMMETRISE
C
C    INITIALISE
C
      DO I=1,NCHF
        DO J=1,NCHF
          RMAT(J,I)=TZERO
        ENDDO
      ENDDO
C
C    INITIALISE DIAGONAL ELEMENTS TO BUTTLE CORRECTION
C
      IF(IWORD.EQ.1)THEN
        IF(NEWBUT)THEN
          RA2=RZERO*RZERO
          DO I=1,NCHF
            L=L2P(I)+1
            NBUT=COEFF(3,L)
            RMAT(I,I)=COEFF(1,L)*BUT0(NBUT,COEFF(2,L)+RA2*EPS(I))
          ENDDO
        ELSE
          DO I=1,NCHF
            L=L2P(I)+1
            E=EPS(I)
            RMAT(I,I)=COEFF(1,L)+E*(COEFF(2,L)+E*COEFF(3,L))
          ENDDO
        ENDIF
      ELSE                     !DARC
        DO I=1,NCHF
          L=L2P(I)+1
          E=ETOT-ECH(I)                         !EPS(I)
          CALL INTBUT(L,E,BUTT)
          RMAT(I,I)=BUTT
        ENDDO
      ENDIF
C
C    NOW ADD-IN ANY PARTITIONED CORRECTION
C
      EZERO=TZERO
      IF(IPRCENT.NE.100)THEN
        EZERO=ONE/(TRACE-ETOT)
        DO I=1,NCHF
          RMAT(I,I)=RMAT(I,I)+SI(I)*EZERO
          L=L2P(I)+1
          DO N=NRANG1(L),NRANG2
            V=ONE/(EIGENS(N,L)-ETOT)
            RMAT(I,I)=RMAT(I,I)+ENDS(N,L)*(V-EZERO)
          ENDDO
        ENDDO
      ENDIF
C
C    PRELIMINARY SET-UP
C
      DO K=1,MNP2
        TEMP1(K)=ONE/(VALUE(K)-ETOT)-EZERO
      ENDDO
C
C    FORM R-MATRIX (TIME CONSUMING)
C
CSTRTBL
C    USE DGEMM, HOPEFULLY FROM HIGHLY OPTIMZED LIBRARY.
C               SINCE IT COMPUTES THE WHOLE MATRIX MULTIPLY, WE DIVIDE
C               IT IDIV TIMES TO COMPUTE THE UPPER HALF ONLY AND SO
C               REDUCE THE TIME/MEMORY BY APPROX FACTOR 2.
C               .
      IDIV=MIN(10,NCHF/20+1)
   1  T=NCHF
      T=T/IDIV
      NCHFI=NINT(T)
      NCHF0=NCHF-IDIV*NCHFI
C
      IF(NCHF0.GT.0)THEN
        IDIV=IDIV+1
      ELSEIF(NCHF0.EQ.0)THEN
        NCHF0=NCHFI
      ELSE
        NCHF0=NCHFI+NCHF0
      ENDIF
C
      IF(NCHF0.GT.MXNCH1)THEN                !NCHF *AND* MZCHF ARE SMALL
        IDIV=NCHF/MXNCH1
        GO TO 1
      ENDIF
C
      NCHF2=0
C
      DO ID=1,IDIV
C
        DO I=1,NCHF0
          II=NCHF2+I
          DO K=1,MNP2
            TEMP2(K,I)=TEMP1(K)*WMAT(K,II)
          ENDDO
        ENDDO
C
        NCHF1=NCHF2+1
        NCHF2=NCHF2+NCHF0
C
        CALL DGEMM('T','N',NCHF2,NCHF0,MNP2,ONE,WMAT,MZMNP
     X             ,TEMP2,MZMNP,ONE,RMAT(1,NCHF1),MZCHF)
C
        NCHF0=NCHFI
C
      ENDDO
C
C    OR DDOT TO GENERATE UPPER HALF RMAT (CASE ONLY NON-OPTIMIZED DGEMM)
C
CBL   DO I=1,NCHF
CBL     DO K=1,MNP2
CBL       TEMP2(K,1)=TEMP1(K)*WMAT(K,I)
CBL     ENDDO
CBL     DO J=1,I
CBL       RMAT(J,I)=RMAT(J,I)+DDOT(MNP2,TEMP2(1,1),1,WMAT(1,J),1)
CBL     ENDDO
CBL   ENDDO
CENDBL
C
CSTRTNBL
CNBL  DO I=1,NCHF
CNBL    DO K=1,MNP2
CNBL      TEMP2(K,1)=TEMP1(K)*WMAT(K,I)
CNBL    ENDDO
CNBL    DO J=1,I
CNBL      DO K=1,MNP2
CNBL        RMAT(J,I)=RMAT(J,I)+TEMP2(K,1)*WMAT(K,J)
CNBL      ENDDO
CNBL    ENDDO
CNBL  ENDDO
CENDNBL
C
C    SYMMETRISE U->L (IF NECESSARY)
C
      IF(IDIV.NE.1)THEN
        DO I=2,NCHF
          DO J=1,I-1
            RMAT(I,J)=RMAT(J,I)
          ENDDO
        ENDDO
      ENDIF
C
C ADD-IN RADIATION DAMPING
C
      CALL ZRMAT
C
      RETURN
      END
C***************************************************************
C
      REAL*8 FUNCTION RWIDTH(NZA,NMIN,NMAX,NV,LV)
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER (HBAR=4.837769D-17,ZERO=0.0D0)
      DIMENSION CP(100),CM(100),JDUM(100)
C
C EVALUATE RADIATIVE WIDTH (IN RY) OF VALENCE ORBITAL NV,LV
C NMIN=LOWEST N-VALUE ACCESSIBLE
C NMAX=HIGHEST N-VALUE INCLUDED
C NZA=ION CHARGE (AS SEEN BY VALENCE ELECTRON).
C
      RWIDTH=ZERO
      NR1=MAX0(NMIN,LV)
      NR2=MIN0(NMAX,NV-1)
      IF(NR1.GT.NR2)RETURN
      DZ=NZA*NZA
      TV=NV*NV
      LP=LV+1
      IF(LP.GT.100)THEN
      WRITE(6,*)' **ERROR** L =',LP,' > LDIM = 100'
      STOP
      ENDIF
      TL=LV
      TLP=LP
      DO 1 N=NR1,NR2
      T=N*N
      DE=DZ*(TV-T)/(TV*T)
      CALL DIPOL(-1,N,NV,ZERO,LP,CP,CM,JDUM)
      T1=TLP*CM(LP)*1.0E10**JDUM(LP)
      T2=ZERO
      IF(LV.GT.0)T2=TL*CP(LV)*1.0E10**JDUM(LV)
      T=(T1+T2)/(TL+TLP)
      T0=DE**3*2.6775E9/DZ
      T=T*T0
c      IF(N.EQ.2)T=T/4.
      RWIDTH=RWIDTH+T
   1  CONTINUE
      RWIDTH=HBAR*RWIDTH
      RETURN
      END
C***************************************************************
C
      SUBROUTINE SC(E,L,R,AC,S,SP,C,CP,IERR)
C
C  COULOMB FUNCTIONS S AND C FROM
C  POWER SERIES EXPANSIONS.
C NRB:
C MODIFIED TO HANDLE DEEPLY BOUND CHANNELS.
C NEUTRAL CASE TO BE ADDED.
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (XEPS=1.E-1)
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
C
      COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT
      COMMON/NRBSCL/ZFSCL(MZCHF),FSCL(MZCHF)
      COMMON/NRBZED/TZED,LPRTSW
      common /nrbtmpac/ac1,ac2,iomit0
C
      PI=ACOS(-ONE)
      TPI=TWO*PI
C
C  NEUTRAL CASE
C
      IF(TZED.EQ.0)THEN
C
        IF(E.LT.TZERO)THEN
          FNU=ONE/SQRT(-E)
          IF(FNU-0.1.LT.L.OR.FNU.LT.FNUMIN)THEN          !DROP
            IERR=-2
            IF(IFLAG.LE.0)THEN
              WRITE(6,*)' WARNING, N.LT.L IN SUBROUTINE SC0',
     X        ' ICHAN,E,N,L = ',ICHAN,E,FNU,L
        IF(IOMSW.GT.0)WRITE(6,*)' ***OMITTING THIS CHANNEL***',ICHAN
        WRITE(6,*)'***NO MORE SIMILAR WARNINGS FOR THIS SYMMETRY***'
              IFLAG=-1
            ENDIF
            IOMIT(ICHAN)=1
C ALLOW EXECUTION TO PROCEED AND OMIT LATER
            S=0.5
            SP=-0.05
            C=100.
            CP=-10.
            ZFSCL(ICHAN)=ONE
            RETURN
          ENDIF
        ENDIF
C
        CALL SC0(E,L,R,AC,ZS,S,SP,ZC,C,CP,IERR)
C
        IF(IERR.GT.0)THEN                  !NOT (SUFFICIENTLY) CONVERGED
          IF(IFLEG.LE.0)THEN
            WRITE(6,*)' ***OMITTING THIS CHANNEL***',ICHAN
            WRITE(6,*)'***NO MORE SIMILAR WARNINGS FOR THIS SYMMETRY***'
            IFLEG=-1
          ENDIF
          IOMIT(ICHAN)=1
C ALLOW EXECUTION TO PROCEED AND OMIT LATER
          S=0.5
          SP=-0.05
          C=100.
          CP=-10.
          ZFSCL(ICHAN)=ONE
          RETURN
        ENDIF
C
        IF(E.GE.0)THEN
          ZFSCL(ICHAN)=ONE
        ELSE
          ZFSCL(ICHAN)=ZS    !ZC=1/ZS
        ENDIF
        RETURN
      ENDIF
C
C  POWER SERIES FOR F AND G (POSITIVE IONS ONLY)
C
      CALL COULFG(L,E,R,AC,F,FP,G,GP,K,IERR,ACT)
C
      FNU=E
      IF(E.LT.TZERO)FNU=ONE/SQRT(-E)
C
      IF(IERR.GT.0)THEN                    !NOT (SUFFICIENTLY) CONVERGED
        IF(IFLEG.LE.0)THEN
          IF(IERR.EQ.1)WRITE(6,610)ICHAN,L,FNU,K,ACT
          IF(IERR.EQ.2)WRITE(6,600)ICHAN,L,FNU,ACT
          IF(IERR.EQ.3)WRITE(6,602)ICHAN,L,FNU
          IFLEG=-1
        ENDIF
        IF(IERR.GT.1)THEN
          IF(IFLEG.LE.0)THEN
            WRITE(6,*)' ***OMITTING THIS CHANNEL***',ICHAN
            WRITE(6,*)'***NO MORE SIMILAR WARNINGS FOR THIS SYMMETRY***'
            IFLEG=-1
          ENDIF
          IOMIT(ICHAN)=1
C ALLOW EXECUTION TO PROCEED AND OMIT LATER
          S=0.5
          SP=-0.05
          C=100.
          CP=-10.
          RETURN
        ELSE
c          TEST=1.D-4
                 test=ac2
          IF(ABS(ACT).GT.TEST)THEN
            IF(IFLEG.LE.0)THEN
            WRITE(6,*)' ***OMITTING THIS CHANNEL***',ICHAN
            WRITE(6,*)'***NO MORE SIMILAR WARNINGS FOR THIS SYMMETRY***'
            IFLEG=-1
            ENDIF
            IOMIT(ICHAN)=1
            RETURN
          ENDIF
        ENDIF
      ENDIF
C
C  CASE OF E.GE.0
C
      IF(E.GE.0)THEN
C
C  CALCULATE CAP. A
        A=ONE
        IF(L.GT.0)THEN
          A1=ONE
          A2=-E
          A3=E+E
          DO I=1,L
            A2=A2+A3
            A1=A1+A2
            A=A*A1
          ENDDO
        ENDIF
C  CALCULATE SCRIPT G AND COULOMB FUNCTION H AND DERIVATIVE
        SG=A*FKHI(E,L,AC)/PI
        H=-G-SG*F
        HP=-GP-SG*FP
C  CALCULATE CAP B
        IF(E.LT.0.01)THEN
          B=A
        ELSE
          B=A/(ONE-EXP(-TPI/SQRT(E)))
        ENDIF
C
      ELSE
C
C  CASE OF E.LT.0
C
        CALL ABG(E,L,AC,A,BG)
C
        IF(A.LT.TZERO.OR.(FNU-XEPS).LT.L)THEN
          IF(IFLAG.LE.0)THEN
            WRITE(6,*)' WARNING, N.LT.L+0.1 IN SUBROUTINE SC',
     X                ' ICHAN,E,N,L = ',ICHAN,E,FNU,L
            IF(IOMSW.GT.0)WRITE(6,*)' ***OMITTING THIS CHANNEL***',ICHAN
            WRITE(6,*)'***NO MORE SIMILAR WARNINGS FOR THIS SYMMETRY***'
            IFLAG=-1
          ENDIF
          IF(A.LT.TZERO)THEN
            A=-A
            IF(IOMSW.eq.0)IOMIT(ICHAN)=-1
          ENDIF
          IF(IOMSW.ne.0)THEN       !SYNC. WITH SR.POINTS FOR DROP/HYBRID
            IOMIT(ICHAN)=1
            IERR=-3
          ENDIF
        ENDIF
C
        H=-(G+BG*F)
        HP=-(GP+BG*FP)
        B=A
      ENDIF
C
C  COMPLETE CALCULATION OF S AND C
C
      C1=SQRT(B*PI/TWO)
      S=C1*F
      SP=C1*FP
      C1=C1/B
      C=H*C1
      CP=HP*C1
C
      W=C*SP-S*CP
      IF(IERR.EQ.0.AND.ABS(W-ONE).GT.100*AC.AND.IOMIT(ICHAN).LE.0)
     X   WRITE(*,630)L,E,R,W,ICHAN,IOMIT(ICHAN) !COULFG, ABG SHOULD TRAP
C
      RETURN
C
  600 FORMAT(///10X,'SERIES IN COULFG NOT CONVERGED'/5X,'ICHAN= ',I3,
     +', SMALL L = ',I3,', EPS/NU = ',1PE12.4,', ACTACC = ',1PE12.4//)
  602 FORMAT(///10X,'SERIES IN COULFG NOT CONVERGED'/5X,'ICHAN= ',I3
     +,', SMALL L = ',I3,', EPS/NU = ',1PE12.4//)
  610 FORMAT(//5X,'*** FUNCTIONS FROM COULFG INACCURATE ***'/
     +5X,'ICHAN= ',I3,', SMALL L =',I3,', EPS/NU = ',1PE12.4,', K = ',
     +I3,', ACTACC = ',E12.4//)
  630 FORMAT(/5X,'SUBROUTINE SC, LL = ',I2,',  EPS = ',
     +  1PE12.5,',  R = ',E10.3,',  W = ',0PF10.6,'  FOR ICHAN=',I4,
     +'  WITH IOMIT=',I2)
C
      END
C**********************************************************
C
      SUBROUTINE SC0(EPS,LL,RHO,AC,ZS,S,SP,ZC,C,CP,IERR)
C
CNRB
C  CALCULATES REGULAR AND IRREGULAR SPHERICAL BESSEL FUNCTIONS
C  S AND C AND THEIR DERIVATIVES SP, CP FROM POWER-SERIES EXPANSION.
C  ZS AND ZC ARE THE COMLPEX CONSTANTS TO BE MULTIPLED BY, CASE EPS.LT.0
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
      PARAMETER (ZI=(0.0,1.0))
C
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT
      COMMON/NRBZED/TZED,LPRTSW
C
C INITIALISATIONS
C
      IF(TZED.NE.0)THEN
        WRITE(6,*)'ERROR: SC0 IS FOR NEUTRALS ONLY'
        STOP 'ERROR: SC0 IS FOR NEUTRALS ONLY'
      ENDIF
      IF(EPS.EQ.TZERO)THEN
        IERR=-1
        S=TZERO
        SP=TZERO
        C=TZERO
        CP=TZERO
        ZS=ONE
        ZC=ONE
        IOMIT(ICHAN)=1
        RETURN
      ENDIF
C
      IERR=0
      ACC10=.1*AC
      DEPS=ABS(EPS)
      T0=SQRT(SQRT(DEPS))
      LAM=-3*LL
C
C LOOP OVER C AND S GENERATION
C
      DO LLL=-1,0
C
      LAM=LAM+2*LL
      FLP1=LAM+1+LLL
C
C POWER-SERIES EXPANSION
C **********************
C
C VALUES FOR N=0
      FNPLP1=FLP1
      C1=RHO**(LAM+LLL)
      U0=C1
      D0=FNPLP1*U0
      DM=ABS(D0)
      FP=D0
      U0=U0*RHO
      UM=ABS(U0)
      F=U0
C
C INITIALIZE FOR COEFFICIENTS IN RECURSION FORMULAE
      P1=-TWO*FLP1
      P2=P1
      REPS=RHO*EPS
C
C LOOP FOR N=2 TO 400, 2
      DO N=2,400,2
C COMPUTE COEFFICIENTS IN RECURSION FORMULAE
        P1=P1-TWO
        P2=P2+P1
C NOW HAVE P2=-N*(N+LAM)
C COMPUTE U2 AND INCREMENT FP
        FNPLP1=FNPLP1+TWO
        U2=REPS*U0/P2
        D2=FNPLP1*U2
        DM=MAX(ABS(D2),DM)
        FP=FP+D2
C MODIFY U2 AND INCREMENT F
        U2=U2*RHO
        UM=MAX(ABS(U2),UM)
        F=F+U2
C TEST CONVERGENCE
        IF(ABS(U2).LT.ABS(F)*ACC10.AND.ABS(D2).LT.ABS(FP)*ACC10)THEN
          IF(IPRINT.GT.1)THEN
            UM=UM/ABS(F)
            DM=DM/ABS(FP)
            IF(EPS.GT.TZERO)THEN
              WRITE(6,610)ICHAN,LL,EPS,UM
              WRITE(6,620)ICHAN,LL,EPS,DM
            ELSE
              FNU=ONE/SQRT(-EPS)
              WRITE(6,611)ICHAN,LL,FNU,UM
              WRITE(6,621)ICHAN,LL,FNU,DM
            ENDIF
          ENDIF
          GO TO 50
        ELSE
C  NEW U0
          U0=U2
          P1=P1-TWO
          P2=P2+P1
        ENDIF
      ENDDO
C
C  SERIES NOT CONVERGED
      WRITE(6,600)LL,EPS,RHO
      IERR=3
      RETURN
C      STOP 'SC0: SERIES NOT CONVERGED'
C
   50 IF(LLL.EQ.-1)THEN
        C=F/T0
        CP=FP/T0
      ELSE
        S=F*T0
        SP=FP*T0
      ENDIF
C
C END LOOP OVER C AND S
      ENDDO
C
C NORMALIZE FOR FUNCTIONS .5*F AND .5*FP
C
      CON=ONE
      DO K=1,LL
        CON=CON*DBLE(K*(2*K+1))
      ENDDO
      C=C*CON
      CP=CP*CON
      S=S/CON
      SP=SP/CON
C
C CALCULATE CAP A
      A=ONE
      IF(LL.GT.0)THEN
        CON=2*LL+1
        C=C/CON
        CP=CP/CON
        A1=TZED
        A2=-DEPS
        A3=DEPS+DEPS
        DO I=1,LL
          A2=A2+A3
          A1=A1+A2
          A=A*A1
        ENDDO
      ENDIF
      CON=SQRT(A)
      S=S*CON
      SP=SP*CON
      C=C/CON
      CP=CP/CON
C
      W=C*SP-S*CP
      IF(ABS(W-ONE).GT.100*AC)THEN
        IF(EPS.GT.TZERO)THEN
          WRITE(6,630)ICHAN,LL,EPS,RHO,W
        ELSE
          FNU=ONE/SQRT(-EPS)
          WRITE(6,631)ICHAN,LL,FNU,RHO,W
        ENDIF
        IERR=1
      ENDIF
C
C COMPLEX COEFFICIENT
      IF(EPS.LT.TZERO)THEN
        ZZ=SQRT(ZI)
        ZS=ZZ*ZI**LL
        ZC=ONE/ZS
      ELSE
        ZS=ONE
        ZC=ONE
      ENDIF
C
      RETURN
C
  600 FORMAT(//10X,60('*')//10X,'SERIES IN SC0 NOT CONVERGED'
     + /10X,' LL =',I3,',  EPS =',1PE15.5,',  RHO =',
     +  E15.5//10X,60('*')//)
  610 FORMAT(/5X,'SUBROUTINE SC0, ICHAN=',I3,'  LL = ',I2,',  EPS = ',
     +  1PE12.5,',  UM = ',E10.2)
  611 FORMAT(/5X,'SUBROUTINE SC0, ICHAN=',I3,'  LL = ',I2,',  FNU = ',
     +  0PF10.2,',  UM = ',E10.2)
  620 FORMAT(/5X,'SUBROUTINE SC0, ICHAN=',I3,'  LL = ',I2,',  EPS = ',
     +  1PE12.5,',  DM = ',E10.2)
  621 FORMAT(/5X,'SUBROUTINE SC0, ICHAN=',I3,'  LL = ',I2,',  FNU = ',
     +  0PF10.2,',  DM = ',E10.2)
  630 FORMAT(/5X,'SUBROUTINE SC0, ICHAN=',I3,'  LL = ',I2,',  EPS = ',
     +  1PE12.5,',  RHO = ',E10.3,',  W = ',0PF10.6)
  631 FORMAT(/5X,'SUBROUTINE SC0, ICHAN=',I3,'  LL = ',I2,',  FNU = ',
     +  0PF10.2,',  RHO = ',E10.3,',  W = ',0PF10.6)
      END
C
C***************************************************************
C
      SUBROUTINE SCALE1(IOPT1)
C
C   CONVERTS R-MATRIX TARGET DATA TO Z-SCALED FORM
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2)
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
C
      LOGICAL NEWBUT
C
C  COMMON BLOCKS FROM ASYMPTOTIC ROUTINE
      COMMON/CEN/ETOT,MXE,NWT,NZ
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2
      COMMON/CPOT/BW(MZCHF,MZCHF),LAMP(MZCHF,MZCHF)
      COMMON/CENAT1/ENAT1
      COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC
      COMMON/CLOGB/NEWBUT
      COMMON/CBUT/FKN(0:MZNRG),UKN(0:MZNRG)
      COMMON/DBUT/EBUTD(MZNRG,MZLP1),CBUTD(MZNRG,MZLP1),NBUTD(MZNRG)
     X           ,K2P(MZCHF)
      COMMON/PART/EIGENS(MZNRG,MZLP1),ENDS(MZNRG,MZLP1),SI(MZCHF),
     X            TRACE,NRANG1(MZLP1),NRANG2,IPRCENT
C
C  COMMON BLOCK FROM SUBROUTINE READ
C  NOTE USE OF NZED IN PLACE OF NZ
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
C
C
C  COMMON BLOCK FOR RADIATIVE DECAYS
      COMMON/CDEC/ARAD(MXTST),ARDEC(MZTAR),SLIN(MXTST),IRDEC,IEND
     X,IPAR(MZTAR),NEWAR
C  COMMON BLOCK FOR DEGENERATE TARGET LEVELS
      COMMON/CDEGEN/ENATR(MZTAR),NASTD,NASTR,NLEV(MZTAR),NCNATR(MZTAR)
     X,IWD(MZTAR),IWT
C
      DIMENSION INDEX(MZTAR),AVENGY(MZTAR)
C
C  Z-SCALING FACTORS
C
      AZ=MAX(NZED-NELC,1)
      AZ1=ONE/AZ
      AZ2=AZ1*AZ1
      TAZ2=2*AZ2
      AZAZ=AZ*AZ
C
C  Z-SCALED PARTITIONED DATA
C
      IF(IPRCENT.NE.100)THEN
        WRITE(6,3085)IPRCENT
        DO L=1,LRANG2
          DO N=1,NRANG2
            ENDS(N,L)=AZ1*ENDS(N,L)**2
            EIGENS(N,L)=AZ2*EIGENS(N,L)
          ENDDO
        ENDDO
      ENDIF
C
C  Z-SCALED TARGET ENERGIES, RELATIVE TO ZERO FOR TARGET GROUND STATE
C
      ENAT1=ENAT(1)
COLD  IF(NAST.EQ.1)GOTO 20
      DO I=1,NAST
        ENAT(I)=TAZ2*(ENAT(I)-ENAT1)
      ENDDO
C
C  TEST FOR DEGENERACY AND FORM AVERAGED TARGET ENERGY LEVELS
C
      IF (NASTD.GT.0) THEN
        NASTR=0
        DO N=1,NASTD
          NASTR=NASTR+NLEV(N)
        ENDDO
        IF(NASTR.NE.NAST)THEN
          WRITE(6,640)NASTR,NAST,(NLEV(N),N=1,NASTD)
          STOP 'LEVEL INCONSISTANCY ON GROUPING...'
        END IF
C
COLD  AVENGY(1)=0.0
COLD  N1=NLEV(1)+1
COLD  INDEX(1)=NLEV(1)
        N1=1
        DO J=1,NASTD
          N=NLEV(J)
          N2=N+N1-1
          INDEX(J)=N2
          ENSUM=TZERO
          ARSUM=TZERO
          WTSUM=TZERO
          DO IN=N1,N2
            IF(IWT.LT.0)THEN
              WT=LAT(IN)+1
            ELSEIF(IWT.EQ.0)THEN
              WT=1
            ELSE
              WT=ISAT(IN)*(2*LAT(IN)+1)
            ENDIF
            ENSUM=ENAT(IN)*WT+ENSUM
            WTSUM=WTSUM+WT
            IF(IRDEC.GT.0)ARSUM=ARSUM+ARDEC(IN)
          ENDDO
          AVENGY(J)=ENSUM/WTSUM
          IWD(J)=WTSUM-0.5
          IF(IRDEC.GT.0)ARDEC(J)=ARSUM
          IF(IOPT1.GT.9)THEN
C REPLACE ENERGY BY AVERAGE FOR BUNCHED TERMS BUT KEEP ALL ID'S
            DO IN=N1,N2
              ENATR(IN)=ENAT(IN)
              ENAT(IN)=AVENGY(J)
            ENDDO
          ENDIF
          N1=N2+1
        ENDDO
      ENDIF
C
COL20 ENAT(1)=0.
      NASTR=NAST
C
C  RA AND BSTO
      RZERO=RA*AZ
      BSTO=BSTO/RZERO
C
C  BUTTLE CORRECTION
C
      IF(IWORD.EQ.1)THEN
        IF(COEFF(3,1).GT.-10000)THEN
          NEWBUT=.FALSE.
          AA=RZERO*AZ2
          DO M=1,3
            AA=AA*AZAZ
            DO L=1,LRANG2
              COEFF(M,L)=COEFF(M,L)*AA
            ENDDO
          ENDDO
        ELSE
          NEWBUT=.TRUE.
          DO L=1,LRANG2
            NBUT=-INT(COEFF(3,L))/10000
            IF(NBUT.GT.MZNRG)THEN
              WRITE(6,699)NBUT,MZNRG
              STOP '*** DIMENSION EXCEEDED: INCREASE MZNRG'
            ENDIF
            COEFF(3,L)=NBUT
            COEFF(1,L)=RZERO*COEFF(1,L)
          ENDDO
C
C         INITIALISE FKN AND UKN
          PI=ACOS(-ONE)
          G=-PI/TWO
          DO I=0,MZNRG
            G=G+PI
            FKN(I)=G
            UKN(I)=G*G
          ENDDO
        ENDIF
      ELSE                   !DARC
        DO L=1,LRANG2
          DO N=1,NBUTD(L)
            EBUTD(N,L)=EBUTD(N,L)*TAZ2
            CBUTD(N,L)=CBUTD(N,L)*RZERO
          ENDDO
        ENDDO
      ENDIF
C
C  WRITE TARGET PROPERTIES
C
      WRITE(6,650)NZED,NELC
      WRITE(6,655)
      DO J=1,NAST
        WRITE(6,660)J,ISAT(J),LAT(J),ENAT(J)
      ENDDO
C
C  IF THERE ARE DEGENERATE LEVELS PRINT THE AVERAGED ENERGIES
C  PUT THEM IN /CINPUT/ AND PRESERVE THE ENERGIES READ FROM
C  THE H FILE IN /CDEGEN/
C
      IF(NASTD.NE.0)THEN
C
C     PRESERVE THE ENERGIES READ FROM THE H-FILE IN /CDEGEN/
        IF(IOPT1.GT.9) THEN
C
C         MORE CODING FROM VALF (HES)
C         IF THERE ARE BUNCHED TERMSPUT ENERGIES IN CINPUT
          WRITE(6,665)
          DO J=1,NAST
C            ENAT(J)=AVENGY(J)
            WRITE(6,'(3X,I14,F14.8,9X,F12.6)') J,ENAT(J),ENATR(J)
          ENDDO
C
        ELSE
C
          DO I=1,NAST
            ENATR(I)=ENAT(I)
          ENDDO
          INR1=1
          DO IND=1,NASTD
            N=NLEV(IND)
            INR2=INR1+N-1
            IF(N.GT.1)WRITE(6,664)INR1,INR2
            INR1=INR2+1
          ENDDO
          WRITE(6,665)IWT
          AV1=AVENGY(1)
          DO J=1,NASTD
            ENAT(J)=AVENGY(J)-AV1
            WRITE(6,666)INDEX(J),J,ENAT(J)
          ENDDO
        ENDIF
C
        NAST=NASTD
      END IF
C
      WRITE(6,670)RZERO,BSTO
      WRITE(6,680)AC
C
  640 FORMAT(///5X,'*****INCORRECT DATA   ',/
     1          5X,'EXPECT ',I3, 'LEVELS FROM NLEV DATA BUT NAST IS',
     2          I3,/5X,'NLEV=',20I3)
  650   FORMAT(' ',10X,'NUCLEAR CHARGE =',I3,', NUMBER OF TARGET ',
     1   ' ELECTRONS =',I3/11X,53('*')//)
  655 FORMAT(20X,'TARGET STATES -'/20X,15('*')//
     1 10X,'INDEX',5X,'2*S+1',5X,'TOTAL L',5X,'SCALED ENERGY'/
     2 20X,'OR P      OR 2*J'/)
  660 FORMAT(3X,3I10,7X,F12.6)
  664 FORMAT(/' LEVELS ',I3,' TO ',I3,' ARE COMBINED')
  665 FORMAT(//' IWT=',I2,8X,'EQUIVALENT TARGET STATES -'/15X,26('*')//
     1       12X,'OLD INDEX',5X,'NEW INDEX',7X,'SCALED ENERGY'//)
  666 FORMAT(3X,2I14,9X,F12.6)
  670 FORMAT(//5X,'RZERO = ',F10.4,3X,'BSTO = ',F10.4/)
  680 FORMAT(5X,'AC = ',E12.4)
  699 FORMAT(//' ******* NBUT = ',I4,'  LARGER THAN ',
     + 'MZNRG = ',I4//)
 3085 FORMAT (/'***** PARTITIONED R-MATRIX IN USE: ',I2,
     X'% OF E-SOLUTIONS IN USE.'//)
      RETURN
      END
C***************************************************************
C
      SUBROUTINE SCALE2
C
C   CONVERTS R-MATRIX DATA TO Z-SCALED FORM
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2)
      PARAMETER (MXF=5)         !(MZLMX+1)/2)
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
C
      CHARACTER ELAS*3
C
C  COMMON BLOCKS FROM ASYMPTOTIC ROUTINE
      COMMON/CEN/ETOT,MXE,NWT,NZ
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2
      COMMON/CPOT/BW(MZCHF,MZCHF),LAMP(MZCHF,MZCHF)
C
C  COMMON BLOCK FROM SUBROUTINE READ
C  NOTE USE OF NZED IN PLACE OF NZ
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/CENAT1/ENAT1
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
C
      COMMON/CNTRLS/ISGPT,ITRMN,ITRMX
      COMMON/CTOP/LRGLAM,LITLAM(MXTST),NTOP(MXTST,2),NTCHAN(MZTAR,2),
     X INDM,TOPA(MXTST),TOPB(MXTST),NTOPA(MXTST,2),NTOPB(MXTST,2),
     X MTOPA(MXTST,2),MTOPB(MXTST,2),FTOPA(MXTST,MXF),FTOPB(MXTST,MXF),
     X KTOPA(MXTST),KTOPB(MXTST),LRGLMN
      COMMON/DBUT/EBUTD(MZNRG,MZLP1),CBUTD(MZNRG,MZLP1),NBUTD(MZNRG)
     X           ,K2P(MZCHF)
      COMMON /NRBLMX/LMX
      COMMON /NRBSKP/ISKP(MZMSH),ISKP0,LINC,ELAS
      COMMON/PART/EIGENS(MZNRG,MZLP1),ENDS(MZNRG,MZLP1),SI(MZCHF),
     X            TRACE,NRANG1(MZLP1),NRANG2,IPRCENT
C
C  STATISTICAL WEIGHT * 2 (OR * 4 FOR NON-EXCHANGE CASE)
C  LRGL2=2*J FOR B.P.
C
      NWT=(2*LRGL2+1)
      IF(NSPN2.EQ.0)THEN
        NWT=NWT+1
        IF(LINC.EQ.1)LINC=2
      ELSE
        IF(NSPN2.LT.0)NWT=-2*NWT
        NWT=NWT*NSPN2*2
      ENDIF
C
C  Z-SCALING FACTORS
C
      AZ=MAX(NZED-NELC,1)
      AZ1=ONE/AZ
      AZ2=AZ1*AZ1
      TAZ2=2*AZ2
      AZHR=ONE/SQRT(AZ)
      AZAZ=AZ*AZ
C
C  CHANNELS
C
      NCHF=NCHAN
      DO I=1,NCHF
        LL=LLCH(I)
        CC(I)=DBLE(LL*(LL+1))
      ENDDO
      I=0
      DO 50 J=1,NAST
        K=NCONAT(J)
        IF(K.EQ.0)GOTO 50
        I0=I
        M=0
        JK=-1
        DO L=1,K
          I=I+1
          ITARG(I)=J
          ECH(I)=ENAT(J)
          IF(NSPN2.NE.0)THEN
            IF(LLCH(I).LT.M)THEN
              WRITE(6,645)J,(LLCH(I0+N),N=1,K)
              STOP '***INPUT ERROR IN SR.SCALE2***'
            ENDIF
          ELSE
            IF(KJ(I).EQ.JK.AND.LLCH(I).LT.M)THEN
              WRITE(6,646)J,(LLCH(I0+N),N=1,K)
              STOP '***INPUT ERROR IN SR.SCALE2***'
            ENDIF
          ENDIF
          M=LLCH(I)
          JK=KJ(I)
        ENDDO
   50 CONTINUE
C
C  R-MATRIX
C  VALUE AND WMAT
C
      DO I=1,NCHF
        DO N=1,MNP2
          WMAT(N,I)=WMAT(N,I)*AZHR
        ENDDO
      ENDDO
      IF(IPRINT.GT.3)WRITE(6,635)
      DO N=1,MNP2
        VALUE(N)=TAZ2*(VALUE(N)-ENAT1)
        IF(IPRINT.GT.3)WRITE(6,640)N,VALUE(N),(WMAT(N,I),I=1,NCHF)
      ENDDO
C
C  PARTITIONED
C
      IF(IPRCENT.NE.100)THEN
        TRACE=TAZ2*(TRACE-ENAT1)
        IF(IPRINT.GT.-2)WRITE(6,641)TRACE                  !EZERO
        DO L=1,LRANG2
          NRANG1(L)=NRANG2+1
          DO N=1,NRANG2
            IF(EIGENS(N,L).GT.VALUE(1))THEN
              NRANG1(L)=N
              GO TO 55
            ENDIF
          ENDDO
   55   ENDDO
        DO I=1,NCHF
          L=L2P(I)+1
          SI(I)=TZERO
          DO N=1,NRANG2
            SI(I)=SI(I)+ENDS(N,L)
          ENDDO
        ENDDO
      ENDIF
C
C  COEFFICIENTS IN POTENTIAL
C
      IF(IPERT.EQ.0.AND.LRGLAM.LT.0)GOTO 160
      IF(IPRINT.GT.2.AND.IPERT.NE.0)WRITE(6,655)
C
C  LAMP(I,J) AND BW(I,J)
C
      DO J=1,NCHF
        DO I=1,NCHF
          LAMP(I,J)=1
        ENDDO
      ENDDO
      IF(LAMAX.EQ.0)GOTO 160
C
C LOOK FOR DIPOLE
C
      IABW=IABS(IWORD)
      A1=ONE/RZERO
      A2=A1/2
      AZZ=ONE
      IF(NCHF.GT.1)THEN
      DO J=2,NCHF
        J1=J-1
        DO 130 I=1,J1
          CF(I,J,1)=CF(I,J,1)*IABW
          BU1=-CF(I,J,1)
          IF(ABS(BU1).LT.1.D-6)GOTO 130
          LAMP(I,J)=2
          BW(I,J)=BU1
          P=A2*BU1
          IF(IPRINT.GT.2.AND.IPERT.NE.0)
     X       WRITE(6,660)ITARG(I),I,ITARG(J),J,P
  130   CONTINUE
      ENDDO
      ENDIF
      IF(LAMAX.EQ.1)GOTO 160
C
C LOOK FOR QUADRUPOLE
C
      IF(IPRINT.GT.2.AND.IPERT.NE.0)WRITE(6,665)
      A2=A2*A1
      AZZ=AZZ*AZ
      DO J=1,NCHF
        DO 150 I=1,J
          CF(I,J,2)=CF(I,J,2)*IABW
          BU2=-CF(I,J,2)
          IF(ABS(BU2).LT.1.D-6)GOTO 150
          LAMP(I,J)=3
          BU2=BU2*AZZ
          BW(I,J)=BU2
          CF(I,J,2)=AZZ*CF(I,J,2)
          P=BU2*A2
          IF(IPRINT.GT.2.AND.IPERT.NE.0)
     X       WRITE(6,660)ITARG(I),I,ITARG(J),J,P
  150   CONTINUE
      ENDDO
      IF(LAMAX.EQ.2)GOTO 160
C
C LOOK FOR OCTUPOLE ETC.
C
      IF(IPRINT.GT.2.AND.IPERT.NE.0)WRITE(6,666)
      DO L=3,LAMAX
        A2=A2*A1
        AZZ=AZZ*AZ
        DO J=1,NCHF
          DO 155 I=1,J
            CF(I,J,L)=CF(I,J,L)*IABW
            BUL=-CF(I,J,L)
            IF(ABS(BUL).LT.1.D-6)GOTO 155
C SKIP IF LOWER MULTIPOLE EXISTS
            IF(LAMP(I,J).NE.1)GO TO 155
            LAMP(I,J)=L+1           !FOR DEGENERATE ENERGY TOP-UP
            P=TZERO
            IF(L.LE.LMX)THEN
              BUL=BUL*AZZ
              BW(I,J)=BUL
              CF(I,J,L)=AZZ*CF(I,J,L)
              P=BUL*A2
              IF(IPRINT.GT.2.AND.IPERT.NE.0)
     X           WRITE(6,660)ITARG(I),I,ITARG(J),J,P
            ENDIF
  155     CONTINUE
        ENDDO
      ENDDO
C
  160 CONTINUE
C
C SYMMETRIZE
C
      DO I=1,NCHF
        DO J=I,NCHF
          LAMP(J,I)=LAMP(I,J)
          BW(J,I)=BW(I,J)
        ENDDO
      ENDDO
C
C  WRITE SLPI AND CHANNEL DATA
C
      WRITE(6,600)NSPN2,LRGL2,NPTY2
      IF(ISGPT.NE.0) WRITE(14,600) NSPN2,LRGL2,NPTY2
      IF(NSPN2.NE.0)THEN
        WRITE(6,669)
        WRITE(6,670)(I,ITARG(I),LLCH(I),I=1,NCHF)
      ELSEIF(KFLAG.GE.0)THEN
        WRITE(6,671)
        WRITE(6,672)(I,ITARG(I),LLCH(I),KJ(I),I=1,NCHF)
      ELSE
        WRITE(6,673)
        WRITE(6,672)(I,ITARG(I),LLCH(I),K2P(I),I=1,NCHF)
      ENDIF
C
  600 FORMAT(///80('+')//12X,'(2S+1) L/2J P =',3I3/12X,24('*')//)
  635 FORMAT(//' N, VALUE(N) AND WMAT(N,I)'/)
  640 FORMAT(I5,E12.3,5X,9E12.3,(/5X,9E12.3))
  641 FORMAT(/'PARTITIONED R-MATRIX, EZERO=',F10.6,' Z**2 RYD'/)
  645 FORMAT(//'CHANNEL L MUST BE ASCENDING WITHIN A TERM:',I5/
     X(20I3))
  646 FORMAT(//'CHANNEL L MUST BE ASCENDING WITHIN A LEVEL (FIXED-K):'
     X,I5/(20I3))
  655 FORMAT(/' PERTURBATION P FOR MULTIPOLE POTENTIAL'//
     1 '  - DIPOLE PART'/)
  660 FORMAT(2(I5,I3),E12.4)
  665 FORMAT(/'  - QUADRUPOLE PART'/)
  666 FORMAT(/'  - OCTUPOLE ETC. PART'/)
  669 FORMAT(12X,'CHANNEL',2X,'TARGET',4X,'SMALL',
     1          /12X,'INDEX ',3X,'INDEX  ',5X,'L'/)
  670 FORMAT(7X,I8,I9,I10)
  671 FORMAT(12X,'CHANNEL',2X,'TARGET',4X,'SMALL',
     1          /12X,'INDEX ',3X,'INDEX  ',5X,'L',5X,'2K'/)
  672 FORMAT(7X,I8,I9,I10,I7)
  673 FORMAT(12X,'CHANNEL',2X,'TARGET',4X,'SMALL',
     1          /12X,'INDEX ',3X,'INDEX  ',5X,'L',4X,'KAPPA'/)
C
      RETURN
      END
C***************************************************************
C
      SUBROUTINE SQDTS
C
C NRB:
C  CALCULATION OF OMEGA FROM KHI-MX IN QDT, OPTIONAL GAILITIS AVERAGE,
C  OPTIONAL (TYPE-I) RADIATION DAMPING.
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      LOGICAL QDT
C
      INCLUDE 'PARAM'
C
      PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2)
      PARAMETER (LWORK=MZCHF*MZCHF)
      PARAMETER (MWORK=MZCHF*MZCHF)
      PARAMETER (ZERO=(0.0,0.0))
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
      PARAMETER (QUART=0.25)
      PARAMETER (BIG=150.0)
C
      CHARACTER ELAS*3
C
      COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC
      COMMON/CDEC/ARAD(MXTST),ARDEC(MZTAR),SLIN(MXTST),IRDEC,IEND
     X,IPAR(MZTAR),NEWAR
      COMMON/CEN/ETOT,MXE,NWT,NZ
C  ***  NOTE CHANGE OF CC TO CCT IN /CHAN/ ***
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/COMEGA/OMEGA(MXTST),IE,NOMWRT
      COMMON/CQDT/R2ST(MZCHF),QDT,NQ
      COMMON/NRBDR/PDR(MZCHF),OMEGDR(MZMET,MZMSH),NDRMET
      COMMON/NRBKHI/ZKHICC(MZDEG,MZDEG),ZKHIOC(MZCHF,MZDEG),ZVAL(MZDEG)
CBL  X,ZVL(MZDEG,MZDEG),ZVR(MZDEG,MZDEG),RWORK(2*MZDEG)
      COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN
      COMMON/NRBRCT/
     X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF)
     X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF)
     X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF)
     X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF)
     X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF)
     X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF)
     X,RMAT(MZCHF,MZCHF)
      COMMON/NRBSKP/ISKP(MZMSH),ISKP0,LINC,ELAS
      COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK)
      COMMON/NRBZED/TZED,LPRTSW
C
      DIMENSION P(MZCHF,MZCHF),Q(MZCHF,MZCHF)
     X         ,POLD(MZCHF,MZCHF),QOLD(MZCHF,MZCHF)
C
      EQUIVALENCE (P,CSP),(Q,CC),(POLD,DSP),(QOLD,DC)
C
C
      NCC=NQ-NCHOP
      IF(NCC.GT.MZDEG)THEN
        WRITE(6,601)NCC
        STOP
      ENDIF
C
      PI=ACOS(-ONE)
      TPI=TWO*PI
      CONST=TPI
      IF(TZED.GT.TZERO)CONST=CONST/DBLE((NZED-NELC)**2)
      IONE=1
      IF(ELAS.EQ.'YES')IONE=0
C
C  DIAGONALISE KHICC
C
        DO N2=1,NCC
          DO N1=1,NCC
            ZKHICC(N1,N2)=DCMPLX(P(NCHOP+N1,NCHOP+N2)
     X            ,Q(NCHOP+N1,NCHOP+N2))
          ENDDO
        ENDDO
C
CSTRTNBL
        CALL ZEIGEN(ZKHICC,ZVAL,NCC,AC)
CENDNBL
CSTRTBL - CURRENTLY NOT IN USE AS NCC IS SMALL HERE
CBL     CALL ZGEEV('N','V',NCC,ZCHICC,MZDEG,ZVAL,ZVL,MZDEG,ZVR,MZDEG,
CBL  X       ZWORK,MWORK,RWORK,INFO)
CBL     IF (INFO.NE.0) THEN
CBL        WRITE(6,'("ZGEEV CALLED, INFO=",I5)') INFO
CBL        STOP
CBL     ENDIF
CBL     LWOPT=INT(ZWORK(1))
CBL     IF (LWOPT.GT.MWORK) THEN
CBL        WRITE(6,'("ZGEEV: OPTIMAL WORK SPACE LENGTH =",I5)') LWOPT
CBL     ENDIF
CBL     DO N1=1,NCC
CBL       DO N2=1,NCC
CBL         ZKHICC(N2,N1)=ZVR(N2,N1)
CBL       ENDDO
CBL     ENDDO
CENDBL
C
C  CALCULATE ZKHIOC
C
        DO N2=1,NCC
          DO N1=1,NCHOP
            ZKHIOC(N1,N2)=ZERO
          ENDDO
          DO K=1,NCC
            DO N1=1,NCHOP
              ZKHIOC(N1,N2)=ZKHIOC(N1,N2)+
     X        DCMPLX(P(N1,NCHOP+K),Q(N1,NCHOP+K))*ZKHICC(K,N2)
            ENDDO
          ENDDO
        ENDDO
C
C  RADIATIVE DECAYS; RECALCULATE ARDEC (DEPENDS ON ETOT) IF NECESS.
C
      IF(IRDEC.GT.0)THEN
        NNN=NCHOP+1
        IF(NEWAR.GT.0)THEN
          KVEC=((ITARG(NNN)-IONE)*(ITARG(NNN)-1-IONE))/2
          ARDEC(ITARG(NNN))=TZERO
          DO JLOOP=1,ITARG(NNN)-1
            KVEC=KVEC+1
            IF(ETOT-(ENAT(ITARG(NNN))-ENAT(JLOOP)).LE.ENAT(1))THEN
              ARDEC(ITARG(NNN))=ARDEC(ITARG(NNN))+ARAD(KVEC)
            ENDIF
          ENDDO
          ARDEC(ITARG(NNN))=ARDEC(ITARG(NNN))*CONST
        ENDIF
        T=ARDEC(ITARG(NNN))*(FKNU(NNN)**3)
        T=MIN(T,BIG)
        FDEC=EXP(T)
      ELSE
        FDEC=ONE
      ENDIF
C
C INITIALIZE DR PROBABILITY
C
      DO I=1,NCHOP
        PDR(I)=ONE
      ENDDO
C
C
      IF(QDT)THEN
C
C  CALCULATE AVERAGE COLLISION STRENGTH
C
        DO J=1,NCHOP
          P(J,J)=P(J,J)-ONE            !-T
          DO I=1,J
            RK(I,J)=P(I,J)**2+Q(I,J)**2
            PDR(I)=PDR(I)-RK(I,J)
            PDR(J)=PDR(J)-RK(I,J)
          ENDDO
          PDR(J)=PDR(J)+RK(J,J)-TWO*P(J,J)-ONE
          P(J,J)=P(J,J)+ONE
        ENDDO
        DO K=1,NCC
          VV=ABS(ZVAL(K))
          IF((ONE-VV).LT.AC) THEN
            VV=FDEC-ONE
            DO M=1,NCHOP
              VV=VV+ABS(ZKHIOC(M,K))**2
            ENDDO
          ELSE
            VV=FDEC-VV**2
          ENDIF
          DO J=1,NCHOP
            DO I=1,J
              T=ABS(ZKHIOC(I,K)*ZKHIOC(J,K))**2/VV
              RK(I,J)=RK(I,J)+T
              PDR(I)=PDR(I)-T
              PDR(J)=PDR(J)-T
            ENDDO
            PDR(J)=PDR(J)+T
          ENDDO
        ENDDO
        DO K1=1,NCC-1
          DO K2=K1+1,NCC
            IF((ONE-ABS(ZVAL(K1))).LT.AC.AND.
     X             (ONE-ABS(ZVAL(K2))).LT.AC) THEN
              ZVV=ZVAL(K1)*CONJG(ZVAL(K1)-ZVAL(K2))+FDEC-ONE
              DO M=1,NCHOP
                ZVV=ZVV+ABS(ZKHIOC(M,K1))**2
              ENDDO
            ELSE
              ZVV=FDEC-ZVAL(K1)*CONJG(ZVAL(K2))
            ENDIF
            DO J=1,NCHOP
              DO I=1,J
                T=TWO*DBLE(ZKHIOC(I,K1)*ZKHIOC(J,K1)*
     X          CONJG(ZKHIOC(I,K2)*ZKHIOC(J,K2))/ZVV)
                RK(I,J)=RK(I,J)+T
                PDR(I)=PDR(I)-T
                PDR(J)=PDR(J)-T
              ENDDO
              PDR(J)=PDR(J)+T
            ENDDO
          ENDDO
        ENDDO
C
      ELSE
C
C DETAILED OMEGA
C
        TPINU=FKNU(NCHOP+1)*TPI
        ZFDEC=SQRT(FDEC)*EXP(DCMPLX(TZERO,-TPINU))
        DO J=1,NCHOP
          DO I=1,J
            ZKHI=DCMPLX(P(I,J),Q(I,J))
            DO K=1,NCC
              ZKHI=ZKHI-ZKHIOC(I,K)*ZKHIOC(J,K)/(ZVAL(K)-ZFDEC)
            ENDDO
            PP=ZKHI*CONJG(ZKHI)
            PDR(J)=PDR(J)-PP
            PDR(I)=PDR(I)-PP
            IF(I.EQ.J)THEN
              PDR(I)=PDR(I)+PP
              ZKHI=ZKHI-DCMPLX(ONE,TZERO)
            ENDIF
            RK(I,J)=ZKHI*CONJG(ZKHI)
          ENDDO
        ENDDO
C
      ENDIF
C
C SYMMETRIZE AND ADJUST WEIGHTING
C
      T=QUART*NWT
      DO J=1,NCHOP
        PDR(J)=PDR(J)*T
        DO I=1,J
          RK(I,J)=T*RK(I,J)
          RK(J,I)=RK(I,J)
        ENDDO
      ENDDO
C
C IF REALLY MQDT RESTORE ORIGINAL P,Q
C
      IF(IQDT.GT.0.AND.NQ.LT.NCHF)THEN
        DO J=1,NCHF
          DO I=1,NCHF
            P(I,J)=POLD(I,J)
            Q(I,J)=QOLD(I,J)
          ENDDO
        ENDDO
      ENDIF
C
      RETURN
  601 FORMAT(//10X,10('*'),' NUMBER OF DEGENERATE CLOSED',
     X ' CHANNELS, NCC = ',I2/20X,' LARGER THAN DIMENSION',
     X ' VALUE OF DEG = MZDEG'//)
      END
      SUBROUTINE TANDTDN(FK,N1,N2,I,TA,TDA,TP)
C
C
C  CALCULATES THETA AND THETAD =THETA DOT FOR  R REAL
C     THETA = TA*EXP(TP)
C     THETAD = TDA*EXP(TP)
C     TP = FNU*LOG(R) - R/FNU
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      COMMON/CTHET/BB(MZCHF,MZTET),BG(MZCHF,MZTET),MSUM(MZCHF)
      COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2
      COMMON/CBLK/XLAG(30),WLAG(30),XLEG(15),WLEG(15)
      COMMON/NRBZED/TZED,LPRTSW
      DIMENSION TP(30),TA(30),TDA(30)
C
      MI=MSUM(I)
      E=BG(I,1)
      F2=BG(I,2)
      FNU=BB(I,1)
C
      DO N=N1,N2
        U=XLAG(N)
        R=RTWO+U/FK
        X=2.*R/FNU
        Y=1./X
        AS=1.
        S=BB(I,2)
        CX=0.
        DO L=3,MI
          AS=AS*Y
          S=S+BB(I,L)*AS
          CX=CX+BG(I,L)*AS
        ENDDO
C
        DLR=LOG(R)*TZED
        TP(N)=-.5*X+FNU*DLR
        TA(N)=S
        TDA(N)=E*((DLR+R*F2)*S+CX)
      ENDDO
C
      RETURN
      END
C**********************************************************
C
      SUBROUTINE THETA(R,I,T,TP,TD,TDP,ICONV)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
C
CNRB
C  NEUTRAL CASE ADDED
C
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CEN/ETOT,MXE,NWT,NZ
      COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC
      COMMON/CTHET/BB(MZCHF,MZTET),BG(MZCHF,MZTET),MSUM(MZCHF)
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2
      COMMON/NRBZED/TZED,LPRTSW
C
      LOGICAL FLAG
C
      PI=ACOS(-ONE)
      FNU=FKNU(I)
      LL=LLCH(I)
      M=FNU+LL+12
C
      IF(M.LE.MZTET)GOTO 10
      IF(TZED.EQ.0)THEN
      M=MZTET       !SHOULD CONVERGE AT M=LL
      GO TO 10
      ENDIF
      WRITE(6,700)I,M
      GOTO 102
C
   10 F1=ONE/FNU
      F2=F1*F1
      X=TWO*R*F1
      Y=ONE/X
      FL=DBLE(LL)
C
      R1=ONE/R
      A=TZED*FNU*R1-F1
      B=TZED*LOG(R)+R*F2
      C=TZED*R1+F2
      D=-R1
      E=FNU**3/TWO
C
      BB(I,1)=FNU
      BB(I,2)=ONE
      BG(I,1)=E
      BG(I,2)=F2
C
      YN=ONE
      A1=FL-FNU*TZED
      A2=FL+FNU*TZED+ONE
      BN=-TWO*FNU-ONE
C
      BET=ONE
      GAM=TZERO
      W0=C
C
      S=ONE
      U=TZERO
      CX=TZERO
      CY=TZERO
C
C
      N=0
      FLAG=.FALSE.
      DO 20 MN=3,M
      N=N+1
      A1=A1+ONE
      A2=A2-ONE
      BN=BN+TWO
      CN=A1*A2
      DN=BN*TZED+F1*CN
      GAM=CN*GAM+DN*BET
      BET=CN*BET
      YN=YN*Y
      U=U+BET*YN
      CY=CY+GAM*YN
      AN=ONE/DBLE(N)
      GAM=GAM*AN
      BET=BET*AN
      S=S+BET*YN
      CX=CX+GAM*YN
      W1=C*S*S+D*(S*CY-U*CX)
      BB(I,MN)=BET
      BG(I,MN)=GAM
      IF(W1.EQ.TZERO)GO TO 30
      AC0=(W1-W0)/W1
c      write(6,*)mn,ac0
      IF(ABS(AC0).LT.10*AC)THEN
        IF(FLAG)THEN
          GO TO 30
        ELSE
          FLAG=.TRUE.
        END IF
      ELSE
        FLAG=.FALSE.
      END IF
   20 W0=W1
C-NRB
      IF(R*F1.GT.150.)THEN
      T=TZERO
      TP=TZERO
      TD=TZERO
      TDP=TZERO
      ICONV=0
      RETURN
      ENDIF
C-NRB
C
C  NOT CONVERGED
      GOTO 100
C
C  SUMMATIONS CONVERGED
C  30 P=EXP(-R*F1)*R**FNU
C
   30 P=EXP(-R*F1/TWO)
      IF(TZED.GT.0)P=P*R**(FNU/TWO)
      IF(ABS(P).GT.1.D-100)THEN
      CFACT=ONE/P
      ELSE
      CFACT=TZERO
      ENDIF
      BB(I,2)=BB(I,2)*CFACT
      DO 40 J=3,N+2
      BB(I,J)=BB(I,J)*CFACT
      BG(I,J)=BG(I,J)*CFACT
   40 CONTINUE
C
      T=P*S
      TP=P*(A*S+D*U)
      TD=P*E*(B*S+CX)
      TDP=P*E*((A*B+C)*S+B*D*U+A*CX+D*CY)
      N2=N+2
      MSUM(I)=N2
      ICONV=0
      RETURN
C
C RELAX TEST FOR ENERGIES CASE A POSSIBLY NEGATIVE IN SC
  100 IF(FNU.GE.DBLE(LL+1))GO TO 101
C
C PROCEED BUT PRINT WARNING
      IF(ABS(AC0).GT.1.E2*AC.AND.NCHOP.GT.0)
     XWRITE(6,650)M,I,EPS(I),LL,AC0,AC
      GO TO 30
C
C  USE SUBROUTINE SC AND SET IPERT = 0
  101 IF(TZED.GT.0)WRITE(6,610)N
      IF(TZED.EQ.0)THEN
      WRITE(6,611)
      STOP 'FAILURE FOR NEUTRAL THETA - TOO CLOSE TO THRESHOLD?'
      ENDIF
  102 IF(NPERT.GT.0)THEN
      WRITE(6,750)IABS(IPERT)+2,IABS(IPERT)
      STOP 750
      ENDIF
      CALL SC(EPS(I),LLCH(I),RZERO,AC,FSA,FSPA,FCA,FCPA,IERR)
      SINF=SIN(PI*FKNU(I))
      COSF=COS(PI*FKNU(I))
      T=FCA*SINF-FSA*COSF
      TP=FCPA*SINF-FSPA*COSF
      IPERT=0
      ICONV=1
      RETURN
C
  700 FORMAT(//10X,30('*')/10X,'SUBROUTINE THETA'/
     1 10X,'FOR I=',I3,' REQUIRE M=',I4/
     2 10X,'WHICH IS LARGER THAN MAXIMUM VALUE OF MZTET ALLOWED BY '
     3 ,'DIMENSIONS'/10X,'USING SUBROUTINE SC WITH IPERT = 0'/10X,
     4 30('*'))
  750 FORMAT(//' EXECUATION HALTED BECAUSE IPERT=',I3,' RESET IPERT=',I3
     X,' OR FIX INDICATED PROBLEM')
  650 FORMAT(//10X,30('*')//10X,'SUBROUTINE THETA'//'M=',I3,' SUMMATIONS
     X NOT',' CONVERGED FOR CHANNEL',I3,'  E .LT. -(L+1)**(-2): E,L='
     X,F10.6,I5//' CHECK ACCURACY AC0 WITH REQUIRED AC: AC0,AC='
     X,2F10.6//10X,30('*'))
  610 FORMAT(//10X,30('*')//10X,'SUBROUTINE THETA'//
     1' SUMMATIONS NOT CONVERGED WITH ',I4,' TERMS'/
     2 /10X,'USING SUBROUTINE SC WITH IPERT = 0'/10X,30('*'))
  611 FORMAT(//10X,30('*')//10X,'SUBROUTINE THETA'//
     1'FAILURE FOR NEUTRAL CASE - TOO CLOSE TO THRESHOLD?'/
     2 10X,30('*'))
      END
C**********************************************************
C
      SUBROUTINE TOP1(LLL)
C
C NRB:
C DETERMINE MULTIPOLE TOP-UP (LS AND BP)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2)
      PARAMETER (MXF=5)         !(MZLMX+1)/2)
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (SIX=6.0)
      PARAMETER (TOLE=1.E-10)
C
      COMMON/CPOT/BW(MZCHF,MZCHF),LAMP(MZCHF,MZCHF)
      COMMON/CEN/ETOT,MXE,NWT,NZ
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CTOP/LRGLAM,LITLAM(MXTST),NTOP(MXTST,2),NTCHAN(MZTAR,2),
     + INDM,TOPA(MXTST),TOPB(MXTST),NTOPA(MXTST,2),NTOPB(MXTST,2),
     + MTOPA(MXTST,2),MTOPB(MXTST,2),FTOPA(MXTST,MXF),FTOPB(MXTST,MXF),
     + KTOPA(MXTST),KTOPB(MXTST),LRGLMN
C
      LRGLAM=LLL
      LRGLMN=LRGLAM  !LOWEST LRGL2 THAT MAY CONTAIN OMEGAS TO BE STRUCK OUT
C
C  FIND ALLOWED TRANSITIONS
C  ************************
C  (THIS IS DONE AND NEEDED FOR EVERY LRGL2 IF LRGLAM.GE.0)
C
      DO 20 I1=1,NCHF
      DO 20 I2=I1,NCHF
C
C DIPOLE
C
        IF(LAMP(I1,I2).EQ.2)THEN
          IT1=ITARG(I1)
          IT2=ITARG(I2)
          DO I=1,INDM
            IF(IABS(NTOP(I,1)).EQ.IT1.AND.IABS(NTOP(I,2)).EQ.IT2)THEN
              NTOP(I,1)=IT1
              NTOP(I,2)=IT2
              LLM=MIN(LAT(IT1),LAT(IT2))
              IF(NSPN2.EQ.0)THEN
                LRGLMN=MIN(LRGLMN,LRGLAM-2*LLM)
                LLM=-LLM+1                          !NO K/J TOP-UP
              ENDIF
              LITLAM(I)=LRGLAM+LLM
              IF(NSPN2.EQ.0)LITLAM(I)=LITLAM(I)/2
              GO TO 20
            ENDIF
          ENDDO
          INDM=INDM+1
          NTOP(INDM,1)=IT1
          NTOP(INDM,2)=IT2
          LLM=MIN(LAT(IT1),LAT(IT2))
          IF(NSPN2.EQ.0)THEN
            LRGLMN=MIN(LRGLMN,LRGLAM-2*LLM)
            LLM=-LLM+1                          !NO K/J TOP-UP
          ENDIF
          LITLAM(INDM)=LRGLAM+LLM
          IF(NSPN2.EQ.0)LITLAM(INDM)=LITLAM(INDM)/2
C
C QUADRUPOLE, OCTUPOLE
C
        ELSEIF(LAMP(I1,I2).GE.3)THEN
          IT1=-ITARG(I1)
          IT2=-ITARG(I2)
          DO I=1,INDM
            IF(IABS(NTOP(I,1)).EQ.-IT1.AND.IABS(NTOP(I,2)).EQ.-IT2)THEN
              IF(NTOP(I,1).LT.0)LITLAM(I)=MIN(LITLAM(I),LAMP(I1,I2)-1)
              GO TO 20
            ENDIF
          ENDDO
          INDM=INDM+1
          NTOP(INDM,1)=IT1
          NTOP(INDM,2)=IT2
          LITLAM(INDM)=LAMP(I1,I2)-1
        ENDIF
   20 CONTINUE
C
C  CALCULATE INVERSE CHANNEL LIST
C
      NC=0
      DO IT=1,NAST
        IF(NCONAT(IT).EQ.0)THEN
          NTCHAN(IT,1)=0
          NTCHAN(IT,2)=0
        ELSE
          NC=NC+1
          NTCHAN(IT,1)=NC
          NC=NC+NCONAT(IT)-1
          NTCHAN(IT,2)=NC
        ENDIF
      ENDDO
C
      IF(LRGL2.LT.(LRGLAM-1).OR.LRGL2.GT.LRGLAM)RETURN
C
C  INITIALISATIONS FOR LRGL2.GE.(LRGLAM-1)
C  ***************************************
C
C  INITIALISE TOPA, TOPB
C
      DO I=1,INDM
        TOPA(I)=TZERO
        TOPB(I)=TZERO
      ENDDO
C
C  PRINT CHANNEL LIST
C
      WRITE(6,600)LRGLAM
      DO I=1,INDM
        WRITE(6,610)I,NTOP(I,1),NTOP(I,2),LITLAM(I)
      ENDDO
C
C  CASE OF LRGL2.EQ.(LRGLAM-1)
C  ***************************
C
      IF(LRGL2.EQ.(LRGLAM-1))THEN
        WRITE(6,620)
C
C  TOP-UP IN SMALL L (BYPASSED BY BP - NOT NEEDED)
C
        DO 70 I=1,INDM
          IF(LITLAM(I).NE.LRGLAM)GOTO 70
          IT1=NTOP(I,1)
          IF(IT1.LT.0)GO TO 70
          IT2=NTOP(I,2)
          IF(NCONAT(IT1)*NCONAT(IT2).EQ.0)GO TO 70
          DELE=ENAT(IT2)-ENAT(IT1)
          IF(DELE.LT.TOLE)GO TO 70
          IF(LLCH(NTCHAN(IT1,2)).EQ.LRGLAM)THEN
            TOPA(I)=ONE/(DBLE(LRGLAM**2)*DELE)
            NTOPA(I,1)=NTCHAN(IT1,2)
            NTOPA(I,2)=NTCHAN(IT2,1)
            WRITE(6,630)I,NTOPA(I,1),NTOPA(I,2),TOPA(I)
          ENDIF
          DELE=-DELE
          IF(LLCH(NTCHAN(IT2,2)).EQ.LRGLAM)THEN
            TOPB(I)=ONE/(DBLE(LRGLAM**2)*DELE)
            NTOPB(I,1)=NTCHAN(IT1,1)
            NTOPB(I,2)=NTCHAN(IT2,2)
            WRITE(6,631)I,NTOPB(I,1),NTOPB(I,2),TOPB(I)
          ENDIF
   70   CONTINUE
        RETURN
      ENDIF
C
C  CASE OF LRGL2.EQ.LRGLAM
C  ***********************
C
      IF(LRGL2.EQ.LRGLAM)THEN
      WRITE(6,620)
C
C  TOP-UP IN SMALL L (LS AND BP)
C
      DO 100 I=1,INDM
        LAM=LITLAM(I)
        IT1=NTOP(I,1)
        IF(IT1.LT.0)GO TO 100
        IT2=NTOP(I,2)
        IF(NCONAT(IT1).EQ.0.OR.NCONAT(IT2).EQ.0)GOTO 100
        DO 152 I1=NTCHAN(IT1,2),NTCHAN(IT1,1),-1
        DO 151 I2=NTCHAN(IT2,2),NTCHAN(IT2,1),-1
          IF(NSPN2.EQ.0.AND.KFLAG.GE.0.AND.KJ(I1).NE.KJ(I2))GO TO 151
          LL1=LLCH(I1)
          LL2=LLCH(I2)
          DELE=MAX(ENAT(IT2)-ENAT(IT1),TOLE)
        IF(LL1.EQ.LAM.AND.LL2.EQ.LL1-1)THEN
          NTOPA(I,1)=I1
          NTOPA(I,2)=I2
          IF(NSPN2.NE.0)THEN          !LS-NRB
            TOPA(I)=ONE/(DBLE(LAM*LAM)*DELE*
     +              WSQ(LAT(IT1),LAT(IT2),LL1,LL2,LRGLAM,ISIGN))
          ELSEIF(KFLAG.GE.0)THEN      !JK-NRB
            W=DBLE(LRGL2+1)/DBLE(2*KJ(I1)+2)
            TOPA(I)=ONE/(DBLE(LAM*LAM)*DELE*
     +              W*WSQ2(LAT(IT1),LAT(IT2),2*LL1,2*LL2,KJ(I1),ISIGN))
          ELSE                        !JJ-NRB
            JV1=2*(L2P(I1)/2)+1       !2J-VALENCE
            JV2=2*(L2P(I2)/2)+1       !2J-VALENCE
            IF(JV1.EQ.JV2)THEN
              W=DBLE(JV2+1)/(DBLE((JV2+2)*JV2))
            ELSE
              JV3=MIN(JV1,JV2)
              W=DBLE((JV3+3)*(JV3+1))/DBLE(2*(JV3+2))
            ENDIF
            W=W/DBLE(2*MAX(LL1,LL2))
c            write(6,*)ll1,ll2,jv1,jv2,w
            TOPA(I)=ONE/(DBLE(LAM*LAM)*DELE*
     +              W*WSQ2(LAT(IT1),LAT(IT2),JV1,JV2,LRGL2,ISIGN))
          ENDIF
          WRITE(6,630)I,NTOPA(I,1),NTOPA(I,2),TOPA(I)
          GO TO 100
        ENDIF
        DELE=-DELE
        IF(LL2.EQ.LAM.AND.LL1.EQ.LL2-1)THEN
          NTOPB(I,2)=I2
          NTOPB(I,1)=I1
          IF(NSPN2.NE.0)THEN          !LS-NRB
            TOPB(I)=ONE/(DBLE(LAM*LAM)*DELE*
     +              WSQ(LAT(IT1),LAT(IT2),LL1,LL2,LRGLAM,ISIGN))
          ELSEIF(KFLAG.GE.0)THEN      !JK-NRB
            W=DBLE(LRGL2+1)/DBLE(2*KJ(I1)+2)
            TOPB(I)=ONE/(DBLE(LAM*LAM)*DELE*
     +              W*WSQ2(LAT(IT1),LAT(IT2),2*LL1,2*LL2,KJ(I1),ISIGN))
          ELSE                        !JJ-NRB
            JV1=2*(L2P(I1)/2)+1       !2J-VALENCE
            JV2=2*(L2P(I2)/2)+1       !2J-VALENCE
            IF(JV1.EQ.JV2)THEN
              W=DBLE(JV2+1)/(DBLE((JV2+2)*JV2))
            ELSE
              JV3=MIN(JV1,JV2)
              W=DBLE((JV3+3)*(JV3+1))/DBLE(2*(JV3+2))
            ENDIF
            W=W/DBLE(2*MAX(LL1,LL2))
c            write(6,*)ll1,ll2,jv1,jv2,w
            TOPB(I)=ONE/(DBLE(LAM*LAM)*DELE*
     +              W*WSQ2(LAT(IT1),LAT(IT2),JV1,JV2,LRGL2,ISIGN))
          ENDIF
          WRITE(6,631)I,NTOPB(I,1),NTOPB(I,2),TOPB(I)
          GO TO 100
        ENDIF
  151   CONTINUE
  152   CONTINUE
  100 CONTINUE
C
C  TOP-UP IN LARGE L (LS ONLY)
C
C NRB: THIS IS NEGLIGIBLE, SO WON'T BOTHER WITH BP VERSION .
C (IF BOTHERED THEN TOP-UP AT LRGLAM .EQ. LRGL2-2 SO THE LAST
C  LRGL2 IS THEN CYCLED THRU TO TOP-UP REMAINING K/J.)
C
      IF(NSPN2.EQ.0)RETURN
C
      WRITE(6,640)
      DO 200 I=1,INDM
      IT1=NTOP(I,1)
      IF(IT1.LT.0)GO TO 200
      IT2=NTOP(I,2)
C
      IF(NTCHAN(IT1,1).EQ.0.OR.NTCHAN(IT2,1).EQ.0)THEN
        MTOPA(I,1)=0
        MTOPA(I,2)=-1
        MTOPB(I,1)=0
        MTOPB(I,2)=-1
        GOTO 200
      ENDIF
C
      L=LLCH(NTCHAN(IT2,1))+1
      DO 110 N=NTCHAN(IT1,1),NTCHAN(IT1,2)
      IF(LLCH(N).EQ.L)THEN
        MTOPA(I,1)=N
        GOTO 120
      ENDIF
  110 CONTINUE
  120 IF(LLCH(NTCHAN(IT1,2)).GT.LITLAM(I))THEN
        MTOPA(I,2)=NTCHAN(IT1,2)-1
      ELSE
        MTOPA(I,2)=NTCHAN(IT1,2)
      ENDIF
      IF(MTOPA(I,2).LT.MTOPA(I,1))THEN
        MTOPA(I,1)=0
        MTOPA(I,2)=-1
      ENDIF
C
      L=LLCH(NTCHAN(IT1,1))+1
      DO 130 N=NTCHAN(IT2,1),NTCHAN(IT2,2)
      IF(LLCH(N).EQ.L)THEN
        MTOPB(I,1)=N
        GOTO 140
      ENDIF
  130 CONTINUE
  140 IF(LLCH(NTCHAN(IT2,2)).GT.LITLAM(I))THEN
        MTOPB(I,2)=NTCHAN(IT2,2)-1
      ELSE
        MTOPB(I,2)=NTCHAN(IT2,2)
      ENDIF
      IF(MTOPB(I,2).LT.MTOPB(I,1))THEN
        MTOPB(I,1)=0
        MTOPB(I,2)=-1
      ENDIF
C
      LAT1=LAT(IT1)
      LAT2=LAT(IT2)
C
      KTOPA(I)=NTCHAN(IT2,1)
      LL1=-2
      IF(MTOPA(I,1).GT.0)LL1=LL1+LLCH(MTOPA(I,1))!ARRAY OUT OF BOUNDS
C IF(MTOPA(I,1).EQ.0)THEN NN.EQ.0 AND THE LOOP IS SKIPPED
      LL2=LLCH(KTOPA(I))-2
      M=0
      NN=MTOPA(I,2)-MTOPA(I,1)+1
      DO 160 N=1,NN
      LL1=LL1+2
      LL2=LL2+2
      MAXL=LAT2+LL2
      IF(MAXL.GT.LRGL2)THEN
        F=0.
        W=1./WSQ(LAT1,LAT2,LL1,LL2,LRGL2,ISIGN)
        DO 150 L=LRGL2+1,MAXL
  150   F=F+W*WSQ(LAT1,LAT2,LL1,LL2,L,ISIGN)
        M=M+1
        IF(M.LE.MXF)THEN
          FTOPA(I,M)=F
          I1=MTOPA(I,1)+M-1
          I2=KTOPA(I)+M-1
          WRITE(6,650)I,I1,I2,FTOPA(I,M)
        ENDIF
      ELSE
        KTOPA(I)=KTOPA(I)+1
        MTOPA(I,1)=MTOPA(I,1)+1
      ENDIF
  160 CONTINUE
C      IF(M.GT.MXF)THEN                          !DROP SILENTLY AS SMALL
C        WRITE(6,661)M
Cc        STOP '***ERROR: DIMENSION EXCEEDED IN TOP1'
C      ENDIF
C
      KTOPB(I)=NTCHAN(IT1,1)
      LL1=LLCH(KTOPB(I))-2
      LL2=-2
      IF(MTOPB(I,1).GT.0)LL2=LL2+LLCH(MTOPB(I,1))  !ARRAY OUT OF BOUNDS
C IF(MTOPB(I,1).EQ.0)THEN NN.EQ.0 AND THE LOOP IS SKIPPED
      NN=MTOPB(I,2)-MTOPB(I,1)+1
      M=0
      DO 180 N=1,NN
      LL1=LL1+2
      LL2=LL2+2
      MAXL=LAT1+LL1
      IF(MAXL.GT.LRGL2)THEN
        F=0.
        W=1./WSQ(LAT1,LAT2,LL1,LL2,LRGL2,ISIGN)
        DO 170 L=LRGL2+1,MAXL
  170   F=F+W*WSQ(LAT1,LAT2,LL1,LL2,L,ISIGN)
        M=M+1
        IF(M.LE.MXF)THEN
          FTOPB(I,M)=F
          I1=KTOPB(I)+M-1
          I2=MTOPB(I,1)+M-1
          WRITE(6,651)I,I1,I2,FTOPB(I,M)
        ENDIF
      ELSE
        KTOPB(I)=KTOPB(I)+1
        MTOPB(I,1)=MTOPB(I,1)+1
      ENDIF
  180 CONTINUE
C      IF(M.GT.MXF)THEN                          !DROP SILENTLY AS SMALL
C        WRITE(6,661)M
Cc        STOP '***ERROR: DIMENSION EXCEEDED IN TOP1'
C      ENDIF
  200 CONTINUE
      ENDIF
C
      RETURN
C
  600 FORMAT(//10X,'TOP-UP FOR (LARGE L).GT.',I2,
     +  ', (SMALL L).GT.LITLAM'//
     +  15X,'ALLOWED TRANSITIONS ARE'//
     +  15X,'INDEX  TARGET STATES     LITLAM')
  610 FORMAT(I18,I9,I5,I12)
  620 FORMAT(/15X,'TOP-UP IN SMALL L FOR'/
     + 15X,'INDEX     CHANNELS')
  630 FORMAT(I18,I9,I5,10X,'TOPA = ',1PE12.4)
  631 FORMAT(I18,I9,I5,10X,'TOPB = ',1PE12.4)
  640 FORMAT(/15X,'TOP-UP IN LARGE L FOR'/15X,'INDEX     CHANNELS')
  650 FORMAT(I18,I9,I5,9X,'FTOPA = ',1PE12.4)
  651 FORMAT(I18,I9,I5,9X,'FTOPB = ',1PE12.4)
  661 FORMAT(/'***INCREASE INTERNAL PARAMETER MXF TO ***',I3)
C
      END
C**********************************************************
C
      SUBROUTINE TOP2
C
C NRB:
C APPLY MULIPOLE TOP-UP (LS AND BP)
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2)
      PARAMETER (MXF=5)         !(MZLMX+1)/2)
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
C
      COMMON/CEN/ETOT,MXE,NWT,NZ
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
C  ***  NOTE CHANGE OF CC TO CCT IN /CHAN/ ***
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/CTOP/LRGLAM,LITLAM(MXTST),NTOP(MXTST,2),NTCHAN(MZTAR,2),
     + INDM,TOPA(MXTST),TOPB(MXTST),NTOPA(MXTST,2),NTOPB(MXTST,2),
     + MTOPA(MXTST,2),MTOPB(MXTST,2),FTOPA(MXTST,MXF),FTOPB(MXTST,MXF),
     + KTOPA(MXTST),KTOPB(MXTST),LRGLMN
      COMMON/NRBRCT/
     X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF)
     X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF)
     X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF)
     X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF)
     X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF)
     X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF)
     X,RMAT(MZCHF,MZCHF)
      COMMON/NRBTOP/ITST(MXTST),JTST(MXTST),KTST(MZTAR,MZTAR)
     X             ,OMST(MXTST),ITOP
C
      NTAROP=ITARG(NCHOP)
C
C DIPOLE TOP-UP IN SMALL L (LS AND BP)
C
        IF(LRGL2.EQ.(LRGLAM-1).OR.LRGL2.EQ.LRGLAM)THEN
C
          DO 3000 I=1,INDM
          IT2=NTOP(I,2)
          IF(IT2.LT.0)GO TO 3000
          IF(IT2.GT.NTAROP)GOTO 3000
          IT1=NTOP(I,1)
        IF(NCONAT(IT1)*NCONAT(IT2).EQ.0)GO TO 3000
          IF(TOPA(I).NE.TZERO)THEN
            K=KTST(IT1,IT2)
            I1=NTOPA(I,1)
            I2=NTOPA(I,2)
            OMST(K)=OMST(K)+RK(I1,I2)*(1+(LITLAM(I)**2)*
     X      EPS(I2))*TOPA(I)
          ENDIF
          IF(TOPB(I).NE.TZERO)THEN
            K=KTST(IT1,IT2)
            I1=NTOPB(I,1)
            I2=NTOPB(I,2)
            OMST(K)=OMST(K)+RK(I1,I2)*(1+(LITLAM(I)**2)*
     X      EPS(I1))*TOPB(I)
          ENDIF
 3000     CONTINUE
        ENDIF
C
C DIPOLE TOP-UP IN LARGE L (LS ONLY, SEE TOP1)
C
        IF(LRGL2.EQ.LRGLAM.AND.NSPN2.NE.0)THEN
C
          DO 4000 I=1,INDM
          IT2=NTOP(I,2)
          IF(IT2.LT.0)GO TO 4000
          IF(IT2.GT.NTAROP)GOTO 4000
          IT1=NTOP(I,1)
        IF(NCONAT(IT1)*NCONAT(IT2).EQ.0)GO TO 4000
          K=KTST(IT1,IT2)
          I1=MTOPA(I,1)-1
          I2=KTOPA(I)-1
          NN=MTOPA(I,2)-MTOPA(I,1)+1
          NN=MIN(NN,MXF)                      !C.F. TOP1
          DO 4100 N=1,NN
          I1=I1+1
          I2=I2+1
 4100     OMST(K)=OMST(K)+RK(I1,I2)*FTOPA(I,N)
          I1=KTOPB(I)-1
          I2=MTOPB(I,1)-1
          NN=MTOPB(I,2)-MTOPB(I,1)+1
          NN=MIN(NN,MXF)                      !C.F. TOP1
          DO 4200 N=1,NN
          I1=I1+1
          I2=I2+1
 4200     OMST(K)=OMST(K)+RK(I1,I2)*FTOPB(I,N)
 4000     CONTINUE
        ENDIF
C
C NRB:
C QUADRUPOLE, OCTUPOLE TOP-UP (LS AND BP)
C
        IF(LRGL2.EQ.LRGLAM)THEN
          TXTRP=DBLE(LRGL2)
          IF(NSPN2.EQ.0)TXTRP=TXTRP/TWO
          IF(IPRINT.GE.0)WRITE(6,801)ETOT
C
          DO 5000 I=1,INDM
            IT2=NTOP(I,2)
            IF(IT2.GT.0)GO TO 5000
            IT2=-IT2
            IF(IT2.GT.NTAROP)GO TO 5000
            IT1=NTOP(I,1)
            IT1=-IT1
            IF(NCONAT(IT1)*NCONAT(IT2).EQ.0)GO TO 5000
            K=KTST(IT1,IT2)
            IF(K.EQ.0)GO TO 5000
            TK2MIN=ETOT-ENAT(IT2)
            TK2MAX=ETOT-ENAT(IT1)
C
C INTERPOLATE BETWEEN DEGENERATE AND NON-DEGENERATE LIMITS WHEN
C           L.LT.2*TK2MIN/(TK2MAX-TK2MIN)
C
            IF(ITOP.EQ.-1)THEN
              AQ=TK2MIN/TK2MAX
              O1=ONE+TXTRP/DBLE(LITLAM(I)-1)
              O1=O1/TWO
              IF(AQ.GT.0.99)THEN
                OMST(K)=OMST(K)*O1
                IF(IPRINT.GE.0)WRITE(6,803)IT1,IT2,AQ,O1
                GO TO 5000
              ENDIF
              O2=ONE/(ONE-AQ)
              BQ=AQ*O2
              IF(TXTRP.GT.TWO*BQ)THEN
                OMST(K)=OMST(K)*O2
                IF(IPRINT.GE.0)WRITE(6,804)IT1,IT2,BQ,O2
                GO TO 5000
              ENDIF
              T=TXTRP/(BQ*TWO)
              O3=O2*T+O1*(ONE-T)
              OMST(K)=OMST(K)*O3
              IF(IPRINT.GE.0)WRITE(6,802)IT1,IT2,AQ,BQ,O1,O2,O3
            ELSE
C
C INTERPOLATE BETWEEN DEGENERATE AND NON-DEGENERATE LIMITS WHEN
C        ENERGY-RATIO EXCEEDS J-RATIO
C
              AQ=TK2MIN/TK2MAX
              BQ=TXTRP/(TXTRP+1)
              BQ=BQ**(2*LITLAM(I)-1)
              O1=ONE/(ONE-AQ)
              IF(AQ.LT.BQ)THEN
                OMST(K)=OMST(K)*O1
                IF(IPRINT.GE.0)WRITE(6,803)IT1,IT2,AQ,O1
              ELSE
                O2=ONE+TXTRP/DBLE(LITLAM(I)-1)
                O2=O2/TWO
                O3=O1*((ONE-AQ)/(ONE-BQ))**2
     X                       +O2*(AQ-BQ)*(TWO-AQ-BQ)/(ONE-BQ)**2
                OMST(K)=OMST(K)*O3
                IF(IPRINT.GE.0)WRITE(6,802)IT1,IT2,AQ,BQ,O1,O2,O3
              ENDIF
            ENDIF
 5000     CONTINUE
        ENDIF
C
        RETURN
C
  801 FORMAT(//'2**LAM-POLE TOP-UP',3X,'I1',3X,'I2',6X,'AQ',8X,'BQ'
     X,8X,'O1',8X,'O2',8X,'O3'/F9.5)
  802 FORMAT(18X,2I5,5F10.3)
  803 FORMAT(18X,2I5,F10.3,10X,F10.3)
  804 FORMAT(18X,2I5,10X,F10.3,10X,F10.3)
C
        END
C
C     ******************************************************************
C
      SUBROUTINE VERT(V,LV,N,W,IERR)
C
C      ________________________________________________________
C     |                                                        |
C     |                INVERT A GENERAL MATRIX                 |
C     |                                                        |
C     |    INPUT:                                              |
C     |                                                        |
C     |         V     --ARRAY CONTAINING MATRIX                |
C     |                                                        |
C     |         LV    --LEADING (ROW) DIMENSION OF ARRAY V     |
C     |                                                        |
C     |         N     --DIMENSION OF MATRIX STORED IN ARRAY V  |
C     |                                                        |
C     |         W     --INTEGER WORK ARRAY WITH AT LEAST N-1   |
C     |                      ELEMENTS                          |
C     |                                                        |
C     |    OUTPUT:                                             |
C     |                                                        |
C     |         V     --INVERSE                                |
C     |                                                        |
C     |    BUILTIN FUNCTIONS: ABS                              |
C     |________________________________________________________|
C
      REAL*8 V(LV,*),S,T
      REAL*8 TZERO,ONE
      INTEGER W(*),I,J,K,L,M,N,P,IERR
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
C
      IERR=0
C
      IF ( N .EQ. 1 ) GOTO 110
      L = 0
      M = 1
10    IF ( L .EQ. N ) GOTO 90
      K = L
      L = M
      M = M + 1
C     ---------------------------------------
C     |*** FIND PIVOT AND START ROW SWAP ***|
C     ---------------------------------------
      P = L
      IF ( M .GT. N ) GOTO 30
      S = ABS(V(L,L))
      DO 20 I = M,N
           T = ABS(V(I,L))
           IF ( T .LE. S ) GOTO 20
           P = I
           S = T
20    CONTINUE
      W(L) = P
30    S = V(P,L)
      V(P,L) = V(L,L)
      IF ( S .EQ. TZERO ) GOTO 120
C     -----------------------------
C     |*** COMPUTE MULTIPLIERS ***|
C     -----------------------------
      V(L,L) = -ONE
      S = ONE/S
      DO 40 I = 1,N
40         V(I,L) = -S*V(I,L)
      J = L
50    J = J + 1
      IF ( J .GT. N ) J = 1
      IF ( J .EQ. L ) GOTO 10
      T = V(P,J)
      V(P,J) = V(L,J)
      V(L,J) = T
      IF ( T .EQ. TZERO ) GOTO 50
C     ------------------------------
C     |*** ELIMINATE BY COLUMNS ***|
C     ------------------------------
      IF ( K .EQ. 0 ) GOTO 70
      DO 60 I = 1,K
60         V(I,J) = V(I,J) + T*V(I,L)
70    V(L,J) = S*T
      IF ( M .GT. N ) GOTO 50
      DO 80 I = M,N
80         V(I,J) = V(I,J) + T*V(I,L)
      GOTO 50
C     -----------------------
C     |*** PIVOT COLUMNS ***|
C     -----------------------
90    L = W(K)
      DO 100 I = 1,N
           T = V(I,L)
           V(I,L) = V(I,K)
100        V(I,K) = T
      K = K - 1
      IF ( K .GT. 0 ) GOTO 90
      RETURN
110   IF ( V(1,1) .EQ. TZERO ) GOTO 120
      V(1,1) = ONE/V(1,1)
      RETURN
120   IERR=1
      RETURN
      END
C
C     ******************************************************************
C
      SUBROUTINE VERTS(V,LV,N,W,IERR)
C
C      ________________________________________________________
C     |                                                        |
C     |       INVERT A SYMMETRIC MATRIX WITHOUT PIVOTING       |
C     |                                                        |
C     |    INPUT:                                              |
C     |                                                        |
C     |        V     --ARRAY CONTAINING MATRIX                 |
C     |                (ONLY THE LOWER HALF NEED BE DEFINED)   |
C     |                                                        |
C     |        LV    --LEADING (ROW) DIMENSION OF ARRAY V      |
C     |                                                        |
C     |        N     --MATRIX DIMENSION                        |
C     |                                                        |
C     |        W     --WORK ARRAY WITH LENGTH AT LEAST N       |
C     |                                                        |
C     |    OUTPUT:                                             |
C     |                                                        |
C     |        V     --INVERSE (IN LOWER HALF ONLY)            |
C     |________________________________________________________|
C
      REAL*8 V(*),W(*),S,T
      INTEGER G,H,I,J,K,L,M,N,LV,IERR
      REAL*8 TZERO,ONE
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
C
      IERR=0
C
C     ----------------
CNRB |*** PACK V ***|
C     ----------------
      H=LV-N
      I=0
      M=0
      L=N
      G=(N*(N+1))/2
2     IF(L.EQ.G)GO TO 4
      K=L+1
      M=M+1
      L=L+N-M
      I=I+H+M
      DO J=K,L
        V(J)=V(I+J)
      ENDDO
      GO TO 2
C
4     H = N
      K = 1
10    IF ( H .EQ. 1 ) GOTO 40
C     --------------------------
C     |*** SAVE PIVOT ENTRY ***|
C     --------------------------
      S = V(K)
      K = K + H
      G = K
      H = H - 1
      M = H
      IF ( S .EQ. TZERO ) GOTO 50
      J = 0
20    J = J - M
      M = M - 1
      L = G + M
      T = V(G+J)/S
C     ---------------------------
C     |*** ELIMINATE BY ROWS ***|
C     ---------------------------
      DO 30 I = G,L
30         V(I) = V(I) - T*V(I+J)
      G = L + 1
      IF ( M .GT. 0 ) GOTO 20
      GOTO 10
40    IF ( V(K) .NE. TZERO ) GOTO 60
      IERR=2
      RETURN
50    IERR=1
      RETURN
C     ------------------------------------------
C     |*** SOLVE FOR ROWS OF INVERSE MATRIX ***|
C     ------------------------------------------
60    G = N + N
      DO 150 M = 1,N
           L = ((G-M)*(M-1))/2
           H = L
           K = M
           DO 70 I = M,N
70              W(I) = TZERO
           W(M) = ONE
80         IF ( K .EQ. N ) GOTO 100
           T = W(K)/V(K+L)
           J = L
           L = L + N - K
           K = K + 1
           IF ( T .EQ. TZERO ) GOTO 80
           DO 90 I = K,N
90              W(I) = W(I) - T*V(I+J)
           GOTO 80
C     -----------------------------------
C     |*** BACK SUBSTITUTION BY ROWS ***|
C     -----------------------------------
100        W(N) = W(N)/V(K+L)
110        IF ( K .EQ. M ) GOTO 130
           J = K
           K = K - 1
           L = L + K - N
           T = W(K)
           DO 120 I = J,N
120             T = T - W(I)*V(I+L)
           W(K) = T/V(K+L)
           GOTO 110
130        DO 140 I = M,N
140             V(I+H) = W(I)
150   CONTINUE
C     ------------------
CNRB  |*** UNPACK V ***|
C     ------------------
      H=LV-N
      I=(N-1)*H+(N*(N-1))/2
      M=N-1
      L=(N*(N+1))/2
      K=L
200   IF(I.EQ.0)RETURN
      DO J=L,K,-1
        V(I+J)=V(J)
      ENDDO
      I=I-H-M
      L=K-1
      M=M-1
      K=K-N+M
      GO TO 200
C
      END
C
C**********************************************************
C
      REAL*8 FUNCTION WSQ(A,B,C,D,F,ISIGN)
C
C  CALCULATES 3*(2*F+1)*W(A,B,C,D,1,F)**2 WHERE W IS RACAH COEFFICIENT.
C NRB:
C  ISIGN IS THE SIGN OF W BEFORE SQUARING.
C
      IMPLICIT INTEGER(A-N)
      IMPLICIT REAL*8 (W)
C
C
      ISIGN=(-1)**(F-A-C)
C
      IF(B-A)10,20,30
C
   10 IF(D-C)11,12,13
   20 IF(D-C)21,22,23
   30 IF(D-C)31,32,33
C
   11 WSQ=.75*DBLE((2*F+1)*(B+D+F+2)*(B+D+F+3)*(B+D-F+1)*(B+D-F+2))/
     +    DBLE((B+1)*(2*B+1)*(2*B+3)*(D+1)*(2*D+1)*(2*D+3))
      RETURN
   12 WSQ=.75*DBLE((2*F+1)*(B+D+F+2)*(-B+D+F)*(B-D+F+1)*(B+D-F+1))/
     +    DBLE((B+1)*(2*B+1)*(2*B+3)*D*(D+1)*(2*D+1))
      ISIGN=-ISIGN
      RETURN
   13 WSQ=.75*DBLE((2*F+1)*(-B+D+F-1)*(-B+D+F)*(B-D+F+1)*(B-D+F+2))/
     +    DBLE((B+1)*(2*B+1)*(2*B+3)*D*(2*D-1)*(2*D+1))
      RETURN
C
   21 WSQ=.75*DBLE((2*F+1)*(B+D+F+2)*(-B+D+F+1)*(B-D+F)*(B+D-F+1))/
     +    DBLE(B*(B+1)*(2*B+1)*(D+1)*(2*D+1)*(2*D+3))
      ISIGN=-ISIGN
      RETURN
   22 G=-(B*(B+1)+D*(D+1)-F*(F+1))
      IF(G.LT.0)ISIGN=-ISIGN
      WSQ=.75*DBLE((2*F+1)*G*G)/                !(2*F+1) IS NOT SQUARED-NRB
     +    DBLE(B*(B+1)*(2*B+1)*D*(D+1)*(2*D+1))
      RETURN
   23 WSQ=.75*DBLE((2*F+1)*(B+D+F+1)*(-B+D+F)*(B-D+F+1)*(B+D-F))/
     +    DBLE(B*(B+1)*(2*B+1)*D*(2*D-1)*(2*D+1))
      RETURN
C
   31 WSQ=.75*DBLE((2*F+1)*(-B+D+F+1)*(-B+D+F+2)*(B-D+F-1)*(B-D+F))/
     +    DBLE(B*(2*B-1)*(2*B+1)*(D+1)*(2*D+1)*(2*D+3))
      RETURN
   32 WSQ=.75*DBLE((2*F+1)*(B+D+F+1)*(-B+D+F+1)*(B-D+F)*(B+D-F))/
     +    DBLE(B*(2*B-1)*(2*B+1)*D*(D+1)*(2*D+1))
      RETURN
   33 WSQ=.75*DBLE((2*F+1)*(B+D+F)*(B+D+F+1)*(B+D-F-1)*(B+D-F))/
     +    DBLE(B*(2*B-1)*(2*B+1)*D*(2*D-1)*(2*D+1))
      RETURN
C
      END
C**********************************************************
C
      REAL*8 FUNCTION WSQ2(A,B,C,D,F,ISIGN)
C
C  CALCULATES 3*(2F+1)*W(A,B,C,D,1,F)**2 WHERE W IS RACAH COEFFICIENT.
C NRB:
C  ISIGN IS THE SIGN OF W BEFORE SQUARING,
C*** AND *** A,B,C,D,E,F ARE INPUT TWICE THEIR ACTUAL VALUE.
C
      IMPLICIT INTEGER(A-N)
      IMPLICIT REAL*8 (W)
C
C
      ISIGN=(-1)**((F-A-C)/2)
C
      IF(B-A)10,20,30
C
   10 IF(D-C)11,12,13
   20 IF(D-C)21,22,23
   30 IF(D-C)31,32,33
C
   11 WSQ2=.75*DBLE((F+1)*(B+D+F+4)*(B+D+F+6)*(B+D-F+2)*(B+D-F+4))/
     +    DBLE((B+2)*(B+1)*(B+3)*(D+2)*(D+1)*(D+3))/4.
      RETURN
   12 WSQ2=.75*DBLE((F+1)*(B+D+F+4)*(-B+D+F)*(B-D+F+2)*(B+D-F+2))/
     +    DBLE((B+2)*(B+1)*(B+3)*D*(D+2)*(D+1))/2.
      ISIGN=-ISIGN
      RETURN
   13 WSQ2=.75*DBLE((F+1)*(-B+D+F-2)*(-B+D+F)*(B-D+F+2)*(B-D+F+4))/
     +    DBLE((B+2)*(B+1)*(B+3)*D*(D-1)*(D+1))/4.
      RETURN
C
   21 WSQ2=.75*DBLE((F+1)*(B+D+F+4)*(-B+D+F+2)*(B-D+F)*(B+D-F+2))/
     +    DBLE(B*(B+2)*(B+1)*(D+2)*(D+1)*(D+3))/2.
      ISIGN=-ISIGN
      RETURN
   22 G=-(B*(B+2)+D*(D+2)-F*(F+2))
      IF(G.LT.0)ISIGN=-ISIGN
      WSQ2=.75*DBLE((F+1)*G*G)/                !(F+1) IS NOT SQUARED-NRB
     +    DBLE(B*(B+2)*(B+1)*D*(D+2)*(D+1))
      RETURN
   23 WSQ2=.75*DBLE((F+1)*(B+D+F+2)*(-B+D+F)*(B-D+F+2)*(B+D-F))/
     +    DBLE(B*(B+2)*(B+1)*D*(D-1)*(D+1))/2.
      RETURN
C
   31 WSQ2=.75*DBLE((F+1)*(-B+D+F+2)*(-B+D+F+4)*(B-D+F-2)*(B-D+F))/
     +    DBLE(B*(B-1)*(B+1)*(D+2)*(D+1)*(D+3))/4
      RETURN
   32 WSQ2=.75*DBLE((F+1)*(B+D+F+2)*(-B+D+F+2)*(B-D+F)*(B+D-F))/
     +    DBLE(B*(B-1)*(B+1)*D*(D+2)*(D+1))/2.
      RETURN
   33 WSQ2=.75*DBLE((F+1)*(B+D+F)*(B+D+F+2)*(B+D-F-2)*(B+D-F))/
     +    DBLE(B*(B-1)*(B+1)*D*(D-1)*(D+1))/4.
      RETURN
C
      END
C***************************************************************
C
      SUBROUTINE ZAINVB
C
CNRB:
C  COMPUTE ZK=-ZA**(-1)*ZB
C  USE KAB'S PARTITIONING, BUT SOLVE ZA*ZK=-ZB INSTEAD.
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (MNPEXT=MZMNP+MZCHF)
      PARAMETER (LWORK=MZCHF*MZCHF)
      PARAMETER (MWORK=MZCHF*MZCHF)
C
      PARAMETER (TWO=2.0)
      PARAMETER (ZERO=(0.0,0.0))
      PARAMETER (ZONE=(1.0,0.0))
C
C  ***  NOTE CHANGE OF CC TO CCT IN /CHAN/ ***
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/NRBKHI/ZKHICC(MZDEG,MZDEG),ZKHIOC(MZCHF,MZDEG),ZVAL(MZDEG)
CBL  X,ZVL(MZDEG,MZDEG),ZVR(MZDEG,MZDEG),RWORK(2*MZDEG)
      COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT
      COMMON/NRBPH1/ZCOEF(MNPEXT,MZCHF),OMEGPR(MZMET,MZMSH),EPHMIN,
     1              EPHMAX,IPHOTO,NODAMP
      COMMON/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF),
     X          ZA(MZCHF,MZCHF),ZB(MZCHF,MZCHF)
      COMMON/NRBPH7/ZBB(MZDIP,MZCHF),ZDIP(MZDIP,MZCHF)
     X,ZD(MZCHF,MZCHF),ZE(MZCHF,MZCHF),ZF(MZCHF,MZCHF)
     X,IDEC(MZEPI*MZMET),JDEC(MZDEC),IPIV(MZCHF),NDEC0
      COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN
      COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK)
C
      DIMENSION IPIV3(MZCHF),IPIVA(MZCHF)
      DIMENSION ZTEMP1(MZCHF,MZCHF),ZTEMP2(MZCHF,MZCHF),
     X          ZTEMP3(MZCHF,MZCHF),ZTEMP4(MZCHF,MZCHF)
      EQUIVALENCE (ZTEMP1,ZR),(ZTEMP2,ZKHICC),(ZTEMP3,ZKHIOC)
     X           ,(ZTEMP4,ZWORK)
C
      IF(MZDEG.LT.MZCHF)THEN
        WRITE(6,*)'SR.ZAINV: SET MZDEG=MZCHF IN PARAM FILE'
        STOP 'SR.ZAINV: SET MZDEG=MZCHF IN PARAM FILE'
      ENDIF
C
      NHOLD=NCHOP
CTEST IF(IQDT.GT.0) NCHOP=NCHF/2            !MAKE USE OF SYMMETRY OF K
      NCC=NCHF-NCHOP                        !=0 IF IQDT>0, UNLESS ABOVE
C
      DO I=1,NCHF
        IF(IOMIT(I).GT.0)ZA(I,I)=ZONE
      ENDDO
C
      IF(NCC.GT.0) THEN
C
C  KOO=-[AOO-AOC*ACC**(-1)*ACO]**(-1)*[BOO-AOC*ACC**(-1)*BCO]
C
        DO J=1,NCC
          JJ=NCHOP+J
          DO I=1,NCHOP
            ZTEMP4(J,I)=ZA(I,JJ)                      !TRANSPOSE
          ENDDO
          DO I=1,NCC
            ZTEMP3(J,I)=ZA(JJ,NCHOP+I)
          ENDDO
        ENDDO
C
CSTRTNBL
CNBL    CALL ZLU(ZTEMP3,MZCHF,NCC,IERR)
CNBL    IF (IERR.NE.0) THEN
CNBL      WRITE(6,600)IERR
CNBL      STOP ' ERROR IN ZLU'
CNBL    END IF
CNBL    CALL ZLUBT(ZTEMP3,ZTEMP4,MZCHF,NCHOP,IERR)    !TRANSPOSE
CNBL    IF (IERR.NE.0) THEN
CNBL      WRITE(6,601)IERR
CNBL      STOP ' ERROR IN ZLUBT'
CNBL    END IF
CENDNBL
C
CSTRTBL
        CALL ZGETRF(NCC,NCC,ZTEMP3,MZCHF,IPIV3,INFO)
        IF(INFO.NE.0)THEN
          WRITE(6,602)INFO
          STOP ' ERROR IN ZGETRF'
        ENDIF
        CALL ZGETRS('T',NCC,NCHOP,ZTEMP3,MZCHF,IPIV3,ZTEMP4,MZCHF,INFO)
        IF(INFO.NE.0)THEN
          WRITE(6,603)INFO
          STOP ' ERROR IN ZGETRS'
        ENDIF
CENDBL
C
C TRANSPOSE BACK
C
        DO I=1,NCHOP
          DO J=1,NCC
            ZTEMP2(I,J)=ZTEMP4(J,I)
          ENDDO
        ENDDO
        DO I=1,NCHOP
          DO J=1,NCC
            ZTEMP4(I,J)=ZTEMP2(I,J)
          ENDDO
        ENDDO
C
        DO J=1,NCHOP
          DO I=1,NCC
            ZTEMP2(I,J)=ZA(NCHOP+I,J)                 !ACO
          ENDDO
        ENDDO
C
CSTRTNBL
CNBL    DO J=1,NCHOP
CNBL      DO I=1,NCHOP
CNBL        ZTEMP1(I,J)=ZERO
CNBL      ENDDO
CNBL      DO K=1,NCC
CNBL        DO I=1,NCHOP
CNBL          ZTEMP1(I,J)=ZTEMP1(I,J)+ZTEMP4(I,K)*ZTEMP2(K,J)
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CENDNBL
C
CSTRTBL
        CALL ZGEMM('N','N',NCHOP,NCHOP,NCC,ZONE,
     X             ZTEMP4,MZCHF,ZTEMP2,MZCHF,ZERO,ZTEMP1,MZCHF)
CENDBL
C
        DO J=1,NCHOP
          DO I=1,NCHOP
            ZA(I,J)=ZA(I,J)-ZTEMP1(I,J)
          ENDDO
        ENDDO
        DO J=1,NCHOP
          DO I=1,NCC
            ZTEMP1(I,J)=ZB(NCHOP+I,J)
          ENDDO
        ENDDO
C
CSTRTNBL
CNBL    DO J=1,NCHOP
CNBL      DO I=1,NCHOP
CNBL        ZTEMP2(I,J)=ZERO
CNBL      ENDDO
CNBL      DO K=1,NCC
CNBL        DO I=1,NCHOP
CNBL          ZTEMP2(I,J)=ZTEMP2(I,J)+ZTEMP4(I,K)*ZTEMP1(K,J)
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CENDNBL
C
CSTRTBL
        CALL ZGEMM('N','N',NCHOP,NCHOP,NCC,ZONE,
     X             ZTEMP4,MZCHF,ZTEMP1,MZCHF,ZERO,ZTEMP2,MZCHF)
CENDBL
C
        DO J=1,NCHOP
          DO I=1,NCHOP
            ZB(I,J)=ZB(I,J)-ZTEMP2(I,J)
          ENDDO
        ENDDO
        DO J=1,NCHOP
          DO I=1,NCC
            ZTEMP4(NCHOP+I,J)=ZA(NCHOP+I,J)           !HOLD ACO
          ENDDO
        ENDDO
C
      ENDIF
C
C ENTRY POINT FOR ALL CHANNELS OPEN
C
      DO J=1,NCHOP
        DO I=1,NCHOP
          ZK(I,J)=-ZB(I,J)
        ENDDO
      ENDDO
C
CSTRTNBL
CNBL  CALL ZLU(ZA,MZCHF,NCHOP,IERR)                   !A DESTROYED
CNBL  IF (IERR.NE.0) THEN
CNBL    WRITE(6,600)IERR
CNBL    STOP ' ERROR IN ZLU'
CNBL  END IF
CNBL  CALL ZLUB(ZA,ZK,MZCHF,NCHOP,IERR)
CNBL  IF (IERR.NE.0) THEN
CNBL    WRITE(6,601)IERR
CNBL    STOP ' ERROR IN ZLUB'
CNBL  END IF
CENDNBL
C
CSTRTBL
      CALL ZGETRF(NCHOP,NCHOP,ZA,MZCHF,IPIVA,INFO)
      IF(INFO.NE.0)THEN
        WRITE(6,602)INFO
        STOP ' ERROR IN ZGETRF'
      ENDIF
      CALL ZGETRS('N',NCHOP,NCHOP,ZA,MZCHF,IPIVA,ZK,MZCHF,INFO)
      IF(INFO.NE.0)THEN
        WRITE(6,603)INFO
        STOP ' ERROR IN ZGETRS'
      ENDIF
CENDBL
C
C  SYMMETRISE OPEN-OPEN PART OF REACTANCE MATRIX
C
      DO I=1,NCHOP-1
         DO J=I+1,NCHOP
            ZK(I,J)=(ZK(I,J)+ZK(J,I))/TWO
            ZK(J,I)=ZK(I,J)
         ENDDO
      ENDDO
C
      IF(NCC.EQ.0)RETURN
C
C
      IF(IRAD.GT.0.OR.IPERT.LT.0.OR.IQDT.GT.0.OR.IPHOTO*NDEC0.NE.0)THEN
C
C  KCO=-ACC**(-1)*[BCO+ACO*KOO]
C
        DO J=1,NCHOP
          DO I=1,NCC
            ZTEMP1(I,J)=ZTEMP4(NCHOP+I,J)             !ACO
            ZTEMP2(I,J)=ZB(NCHOP+I,J)
          ENDDO
        ENDDO
C
CSTRTNBL
CNBL    DO J=1,NCHOP
CNBL      DO K=1,NCHOP
CNBL        DO I=1,NCC
CNBL          ZTEMP2(I,J)=ZTEMP2(I,J)+ZTEMP1(I,K)*ZK(K,J)
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
C
CNBL    CALL ZLUB(ZTEMP3,ZTEMP2,MZCHF,NCHOP,IERR)
CNBL    IF (IERR.NE.0) THEN
CNBL      WRITE(6,601)IERR
CNBL      STOP ' ERROR IN ZLUB'
CNBL    END IF
CENDNBL
C
CSTRTBL
        CALL ZGEMM('N','N',NCC,NCHOP,NCHOP,ZONE,
     X             ZTEMP1,MZCHF,ZK,MZCHF,ZONE,ZTEMP2,MZCHF)
        CALL ZGETRS('N',NCC,NCHOP,ZTEMP3,MZCHF,IPIV3,ZTEMP2,MZCHF,INFO)
        IF(INFO.NE.0)THEN
          WRITE(6,603)INFO
          STOP ' ERROR IN ZGETRS'
        ENDIF
CENDBL
C
        DO J=1,NCHOP
          DO I=1,NCC
            ZK(NCHOP+I,J)=-ZTEMP2(I,J)
          ENDDO
        ENDDO
C
C  COPY CLOSED-OPEN TO OPEN-CLOSED
C
        DO J=NCHOP+1,NCHF
          DO I=1,NCHOP
            ZK(I,J)=ZK(J,I)
          ENDDO
        ENDDO
C
      ENDIF
C
      IF(IQDT.GT.0.AND.IPERT.GT.0)THEN                !IQDT>0 TEST ONLY
C
C  KOC=-[AOO-AOC*ACC**(-1)*ACO]**(-1)*[BOC-AOC*ACC**(-1)*BCC]
C
        DO J=1,NCC
          DO I=1,NCC
            ZTEMP1(I,J)=ZB(NCHOP+I,NCHOP+J)
          ENDDO
        ENDDO
        DO J=1,NCC
          DO I=1,NCHOP
            ZTEMP2(I,J)=ZB(I,NCHOP+J)
          ENDDO
        ENDDO
C
CSTRTNBL
CNBL    DO J=1,NCC
CNBL      DO K=1,NCC
CNBL        DO I=1,NCHOP
CNBL          ZTEMP2(I,J)=ZTEMP2(I,J)-ZTEMP4(I,K)*ZTEMP1(K,J)
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CNBL    CALL ZLUB(ZA,ZTEMP2,MZCHF,NCC,IERR)
CNBL    IF (IERR.NE.0) THEN
CNBL      WRITE(6,601)IERR
CNBL      STOP ' ERROR IN ZLUB'
CNBL    END IF
CENDNBL
C
CSTRTBL
        CALL ZGEMM('N','N',NCHOP,NCC,NCC,-ZONE,
     +             ZTEMP4,MZCHF,ZTEMP1,MZCHF,ZONE,ZTEMP2,MZCHF)
        CALL ZGETRS('N',NCHOP,NCC,ZA,MZCHF,IPIVA,ZTEMP2,MZCHF,INFO)
        IF(INFO.NE.0)THEN
          WRITE(6,603)INFO
          STOP ' ERROR IN ZGETRS'
        ENDIF
CENDBL
C
        DO J=1,NCC
          DO I=1,NCHOP
            ZK(I,NCHOP+J)=-ZTEMP2(I,J)
          ENDDO
        ENDDO
C
C  SYMMETRIZE "CLOSED"-OPEN AND OPEN-"CLOSED" PART OF REACTANCE MATRIX
C
        DO J=NCHOP+1,NCHF
          DO I=1,NCHOP
            ZK(I,J)=(ZK(I,J)+ZK(J,I))/TWO
            ZK(J,I)=ZK(I,J)
          ENDDO
        ENDDO
C
      ENDIF
C
      IF(IQDT.GT.0)THEN                               !TEST
C
C  KCC=-ACC**(-1)*[BCC+ACO*KOC]
C
        DO J=1,NCHOP
          DO I=1,NCC
            ZTEMP1(I,J)=ZTEMP4(NCHOP+I,J)             !ACO
          ENDDO
        ENDDO
        DO J=1,NCC
          DO I=1,NCHOP
            ZTEMP2(I,J)=ZK(I,NCHOP+J)
          ENDDO
        ENDDO
        DO J=1,NCC
          DO I=1,NCC
            ZTEMP4(I,J)=ZB(NCHOP+I,NCHOP+J)
          ENDDO
        ENDDO
C
CSTRTNBL
CNBL    DO J=1,NCC
CNBL      DO K=1,NCHOP
CNBL        DO I=1,NCC
CNBL          ZTEMP4(I,J)=ZTEMP4(I,J)+ZTEMP1(I,K)*ZTEMP2(K,J)
CNBL        ENDDO
CNBL      ENDDO
CNBL    ENDDO
CNBL    CALL ZLUB(ZTEMP3,ZTEMP4,MZCHF,NCC,IERR)
CNBL    IF (IERR.NE.0) THEN
CNBL      WRITE(6,601)IERR
CNBL      STOP ' ERROR IN ZLUB'
CNBL    END IF
CENDNBL
C
CSTRTBL
        CALL ZGEMM('N','N',NCC,NCC,NCHOP,ZONE,
     X             ZTEMP1,MZCHF,ZTEMP2,MZCHF,ZONE,ZTEMP4,MZCHF)
        CALL ZGETRS('N',NCC,NCC,ZTEMP3,MZCHF,IPIV3,ZTEMP4,MZCHF,INFO)
        IF(INFO.NE.0)THEN
          WRITE(6,603)INFO
          STOP ' ERROR IN ZGETRS'
        ENDIF
CENDBL
C
        DO J=1,NCC
          DO I=1,NCC
            ZK(NCHOP+I,NCHOP+J)=-ZTEMP4(I,J)
          ENDDO
        ENDDO
C
C  SYMMETRISE "CLOSED"-"CLOSED" PART OF REACTANCE MATRIX
C
        DO I=NCHOP+1,NCHF
           DO J=I+1,NCHF
              ZK(I,J)=(ZK(I,J)+ZK(J,I))/TWO
              ZK(J,I)=ZK(I,J)
           ENDDO
        ENDDO
C
      ENDIF
C
      NCHOP=NHOLD
      RETURN
C
CN600 FORMAT(' SR.ZAINVB: ZLU RETURNED WITH INFO =',I2)
CN601 FORMAT(' SR.ZAINVB: ZLUB RETURNED WITH INFO =',I2)
  602 FORMAT(//10X,10('*'),' SR.ZAINVB: ZGETRF RETURNED WITH INFO =',I2)
  603 FORMAT(//10X,10('*'),' SR.ZAINVB: ZGETRS RETURNED WITH INFO =',I2)
      END
C******************************************************************
C
      SUBROUTINE ZEIGEN(A,VAL,N,DELTA)
C
C  DIAGONALISATION OF COMPLEX SYMMETRIC MATRIX
C  USING METHOD DESCRIBED BY M.J.SEATON, COMPUTER JOURNAL, VOL.12,
C  PAGE 156, 1969.
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMPLEX*16 A,X,VAL,C,S,H,P,Q,CIM,ZERO,ZONE
c
      logical bflag
C
      INCLUDE 'PARAM'
C
      PARAMETER (ZERO=(0.0,0.0))
      PARAMETER (ZONE=(1.0,0.0))
      PARAMETER (CIM=(0.0,1.0))
      PARAMETER (TZERO=0.0)
      PARAMETER (QUART=0.25)
      PARAMETER (HALF=0.5)
      PARAMETER (TWO=2.0)
C
      DIMENSION A(MZDEG,MZDEG),X(MZDEG,MZDEG),VAL(MZDEG)
C
      DATA IROTM/20/
C
      SQ(H)=H* CONJG(H)
C
C TEST FOR QUICK RETURN
C
      IF(N.LE.0)RETURN
C
      IF(N.EQ.1)THEN
        VAL(1)=A(1,1)
        A(1,1)=ZONE
        RETURN
      ENDIF
C
      IF(N.EQ.2)THEN
        Q=A(1,2)
        P = (A(1,1)-A(2,2))*HALF
        FL= ABS(P*P+Q*Q)
        V=-QUART*LOG(SQ(P-CIM*Q)/FL)
        T= CONJG(P)*Q+CONJG(Q)*P
        U=-QUART * ATAN2(T/FL,(SQ(P)-SQ(Q))/FL)
        S= SIN(U)*COSH(V) +CIM*COS(U)*SINH(V)
        C= COS(U)*COSH(V) -CIM*SIN(U)*SINH(V)
        H=(S*P+C*Q)*S*TWO
        VAL(1)=A(1,1)-H
        VAL(2)=A(2,2)+H
        A(1,1)=C
        A(1,2)=S
        A(2,1)=-S
        A(2,2)=C
        RETURN
      ENDIF
C
C GENERAL CASE
C
      DELTA2=DELTA*DELTA
      NM1=N-1
C
C INITIAL D1,D2 AND X
C
      D1=TZERO
      H=ZERO
      DO I=1,N
        X(I,I)=ZONE
        D1=D1+SQ(A(I,I))
        H=H+A(I,I)
      ENDDO
      D1=D1-SQ(H)/DBLE(N)
C
      D2=TZERO
      DO I=1,NM1
        IP1=I+1
        DO J=IP1,N
          X(I,J)=ZERO
          X(J,I)=ZERO
          D2=D2+SQ(A(I,J))
        ENDDO
      ENDDO
c
c identity test
c
      bflag=.true.
      if(abs(d1).lt.delta2.and.d2.lt.delta2)then
c        write(6,*)d1,d2
        if(d1.eq.tzero)return                !must return
        bflag=.false.
      endif
C
      D1 = (N-1)*(D1*HALF+D2)*DELTA2/DBLE((N+1))
C
C BEGIN ROTATIONS
C
      DO 1010 IROT=1,IROTM
      DO 1000 IP=1,NM1
      IPP1=IP+1
      DO 1000 IQ=IPP1,N
C
C ROTATION CONSTANTS
C
      Q=A(IP,IQ)
      P = (A(IP,IP)-A(IQ,IQ))*HALF
      FL = ABS(P*P+Q*Q)
      BETA = LOG(SQ(P-CIM*Q)/FL)*HALF
      T=( CONJG(P)*Q+P* CONJG(Q))/FL
      D=(SQ(P)-SQ(Q))/FL
      U=-QUART*ATAN2(T,D)
C
      T=TZERO
      D=TZERO
      DO I=1,N
        IF(I.NE.IP.AND.I.NE.IQ)THEN
          D=D+SQ(A(IP,I))+SQ(A(IQ,I))
          T=T+SQ(A(IP,I)+CIM*A(IQ,I))
        ENDIF
      ENDDO
      T=D-T
      FN= SQRT(D*D-T*T)
      GAMMA=LOG((D+T)/FN)
C
C ITERATION FOR V
C
      V0=-HALF*(BETA+GAMMA)
      DO ITERV=1,100
        V=V0-(FL*SINH((V0+BETA)*TWO)+FN*SINH(V0+GAMMA))/
     *    (TWO*FL*COSH((V0+BETA)*TWO)+FN*COSH(V0+GAMMA))
        IF(ABS(V-V0).LT.DELTA*0.1) GO TO 580
        V0=V
      ENDDO
      WRITE(6,5010) DELTA
C
C NEW A,X AND D2
C
  580 V=HALF*V
      S= SIN(U)*COSH(V) +CIM*COS(U)*SINH(V)
      C= COS(U)*COSH(V) -CIM*SIN(U)*SINH(V)
      H = (S*P+C*Q)*S*TWO
      A(IP,IP)=A(IP,IP)-H
      A(IQ,IQ)=A(IQ,IQ)+H
      A(IP,IQ)=(C*C-S*S)*Q+TWO*C*S*P
      D2=D2-SQ(A(IQ,IP))+SQ(A(IP,IQ))
      A(IQ,IP)=A(IP,IQ)
C
      DO I=1,N
        H=X(I,IP)
        X(I,IP)=H*C-X(I,IQ)*S
        X(I,IQ)=H*S+X(I,IQ)*C
        IF(I.NE.IP.AND.I.NE.IQ)THEN
          H=A(IP,I)
          A(IP,I)=C*H-A(IQ,I)*S
          A(IQ,I)=S*H+A(IQ,I)*C
          D2=D2-SQ(A(I,IP))-SQ(A(I,IQ))+SQ(A(IP,I))+SQ(A(IQ,I))
          A(I,IP)=A(IP,I)
          A(I,IQ)=A(IQ,I)
        ENDIF
      ENDDO
C
C TEST CONVERGENCE
      IF(D2.LT.D1) GO TO 610
C
C END ROTATIONS
C
 1000 CONTINUE
C
C  RECALCULATE D2
C
      D2=TZERO
      DO I=1,NM1
        IP1=I+1
        DO J=IP1,N
          D2=D2+SQ(A(I,J))
        ENDDO
      ENDDO
C
 1010 CONTINUE
c
      if(bflag)
     xWRITE(6,5020)IROTM,DELTA
C
C EIGENVALUES AND EIGENVECTORS
C
  610 DO I=1,N
        VAL(I)=A(I,I)
        DO J=1,N
          A(I,J)=X(I,J)
        ENDDO
      ENDDO
C
      RETURN
C
 5010 FORMAT(//10X,'*** SUBROUTINE ZEIGEN ***'//
     + ' WARNING - NO CONVERGENCE IN ITERATIONS FOR V'/
     + ' ACCURACY PARAMETER DELTA = ',1PE9.2/
     + ' NEXT VALUE OF AVERAGED OMEGA MAY BE INCORRECT'//)
 5020 FORMAT(//11X,'*** SUBROUTINE ZEIGEN ***'
     + /' NO CONVERGENCE FOR IROTM =',I3/' DELTA =',1PE11.2/
     +  ' NEXT VALUE OF AVERAGED OMEGA MAY BE INCORRECT'//)
C
      END
C******************************************************************
C
      SUBROUTINE ZLU(A,LA,N,IERR)
C
C      ________________________________________________________
C     |                                                        |
C     |LU FACTOR A GENERAL COMPLEX MATRIX WITH PARTIAL PIVOTING|
C     |                                                        |
C     |    INPUT:                                              |
C     |                                                        |
C     |         A     --COMPLEX ARRAY CONTAINING MATRIX        |
C     |                 (LENGTH AT LEAST 3 + N(N+1))           |
C     |                                                        |
C     |         LA    --LEADING (ROW) DIMENSION OF ARRAY A     |
C     |                                                        |
C     |         N     --DIMENSION OF MATRIX STORED IN A        |
C     |                                                        |
C     |    OUTPUT:                                             |
C     |                                                        |
C     |         A     --LU FACTORED MATRIX                     |
C     |________________________________________________________|
C
      COMPLEX*16 A(*),T
      REAL*8 R,S,TZERO
      INTEGER E,F,G,H,I,J,K,L,LA,M,N,O,P,IERR
C
      PARAMETER (TZERO=0.0)
C
      IERR=0
C
C     ----------------
C     |*** PACK A ***|
C     ----------------
      H = LA - N
      IF ( H .EQ. 0 ) THEN  ! CASE DIM A = N*N
        IERR=1
        RETURN
      ENDIF
      IF ( H .LT. 0 ) THEN
        IERR=2
        RETURN
      ENDIF
      I = 0
      K = 1
      L = N
      O = N*N
2     IF ( L .EQ. O ) GO TO 4
      I = I + H
      K = K + N
      L = L + N
      DO 3  J = K,L
3          A(J) = A(I+J)
      GOTO 2
C
4     R = TZERO
      O = N + 1
      P = O + 1
      L = 5 + N*P
      I = -N - 3
C     ---------------------------------------------
C     |*** INSERT PIVOT ROW AND COMPUTE 1-NORM ***|
C     ---------------------------------------------
10    L = L - O
      IF ( L .EQ. 4 ) GOTO 30
      S = TZERO
      DO 20 K = 1,N
           J = L - K
           T = A(I+J)
           A(J) = T
20         S = S + ABS(T)
      IF ( R .LT. S ) R = S
      I = I + 1
      GOTO 10
30    A(1) = 1239
      A(2) = N
      A(3) = R
      I = 5 - P
      K = 1
40    I = I + P
      IF ( K .EQ. N ) GOTO 110
      E = N - K
      M = I + 1
      H = I
      L = I + E
C     ---------------------------------------
C     |*** FIND PIVOT AND START ROW SWAP ***|
C     ---------------------------------------
      DO 50 J = M,L
50         IF ( ABS(A(J)) .GT. ABS(A(H)) ) H = J
      G = H - I
      J = I - K
      A(J) = G + K
      T = A(H)
      A(H) = A(I)
      A(I) = T
      K = K + 1
      IF ( ABS(T) .EQ. TZERO ) GOTO 100
C     -----------------------------
C     |*** COMPUTE MULTIPLIERS ***|
C     -----------------------------
      DO 60 J = M,L
60         A(J) = A(J)/T
      F = I + E*O
70    J = K + L
      H = J + G
      T = A(H)
      A(H) = A(J)
      A(J) = T
      L = E + J
      IF ( ABS(T) .EQ. TZERO ) GOTO 90
      H = I - J
C     ------------------------------
C     |*** ELIMINATE BY COLUMNS ***|
C     ------------------------------
      M = J + 1
      DO 80 J = M,L
80         A(J) = A(J) - T*A(J+H)
90    IF ( L .LT. F ) GOTO 70
      GOTO 40
100   A(1) = -1239
      GOTO 40
110   IF ( ABS(A(I)) .EQ. TZERO ) A(1) = -1239
      RETURN
      END
C******************************************************************
C
      SUBROUTINE ZLUB(A,B,LB,NB,IERR)
C      ________________________________________________________
C     |                                                        |
C     |       SOLVE A GENERAL COMPLEX LU FACTORED SYSTEM       |
C     |                                                        |
C     |    INPUT:                                              |
C     |                                                        |
C     |         A     --ZLU'S OUTPUT                           |
C     |                                                        |
C     |         B     --RIGHT SIDE (DESTROYED)                 |
C     |                                                        |
C     |         LB    --LEADING (ROW) DIMENSION OF ARRAY B     |
C     |                                                        |
C     |         NB    --DIMENSION OF MATRIX STORED IN B        |
C     |                                                        |
C     |    OUTPUT:                                             |
C     |                                                        |
C     |         B     --SOLUTION                               |
C     |________________________________________________________|
C
      REAL*8 TZERO,ONE
      COMPLEX*16 A(*),B(LB,*),T
      INTEGER I,J,K,L,M,N,LB,NB,IB,I1,IERR
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
C
      IERR=0
C
      I1 = NINT(DBLE(A(1)))
      IF ( ABS(I1) .NE. 1239 ) THEN
        IERR=1         !ERROR, MUST FACTOR BEFORE SOLVING
        RETURN
      ENDIF
C     -----------------------------
C     |*** FORWARD ELIMINATION ***|
C     -----------------------------
      DO 20 IB = 1,NB
      N = NINT(DBLE(A(2)))
      M = N + 1
      J = 4 - M
      IF ( I1 .LT. 0 ) GOTO 80
      K = 1
30    J = J + M
      IF ( ABS(A(J+K)) .EQ. TZERO ) GOTO 80
      IF ( K .EQ. N ) GOTO 50
      L = NINT(DBLE(A(J)))
      T = B(L,IB)
      B(L,IB) = B(K,IB)
      B(K,IB) = T
      K = K + 1
      IF ( ABS(T) .EQ. TZERO ) GOTO 30
      DO 40 I = K,N
40         B(I,IB) = B(I,IB) - T*A(I+J)
      GOTO 30
C     --------------------------------------
C     |*** BACK SUBSTITUTION BY COLUMNS ***|
C     --------------------------------------
50    T = B(K,IB)/A(J+K)
60    B(K,IB) = T
      IF ( K .EQ. 1 ) GO TO 20
      K = K - 1
      DO 70 I = 1,K
70         B(I,IB) = B(I,IB) - T*A(I+J)
      J = J - M
      GOTO 50
C     -----------------------------
C     |*** COMPUTE NULL VECTOR ***|
C     -----------------------------
80    K = 0
90    K = K + 1
      J = J + M
      IF ( ABS(A(J+K)) .NE. TZERO ) GOTO 90
      DO 100 I = 1,N
100        B(I,IB) = TZERO
      T = ONE
      GOTO 60
 20   CONTINUE
      RETURN
      END
C******************************************************************
C
      SUBROUTINE ZLUBS(A,B,LB,NB,IERR)
C      ________________________________________________________
C     |                                                        |
C     |    SOLVE A COMPLEX LU FACTORED SYMMETRIC SYSTEM        |
C     |                 WITHOUT PIVOTING                       |
C     |                                                        |
C     |    INPUT:                                              |
C     |                                                        |
C     |         A     --ZLUS'S OUTPUT                          |
C     |                                                        |
C     |         B     --RIGHT SIDE (DESTROYED)                 |
C     |                                                        |
C     |         LB    --LEADING (ROW) DIMENSION OF ARRAY B     |
C     |                                                        |
C     |         NB    --DIMENSION OF MATRIX STORED IN B        |
C     |                                                        |
C     |    OUTPUT:                                             |
C     |                                                        |
C     |         B     --SOLUTION                               |
C     |________________________________________________________|
C
      COMPLEX*16 A(*),B(LB,*),T
      REAL*8 TZERO,ONE
      INTEGER I,J,K,L,N,LB,NB,IB,I1,IERR,KB,NB0
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
C
      IERR=0
      NB0=ABS(NB)
C
      I1 = NINT(DBLE(A(1)))
      IF ( ABS(I1) .NE. 1237 ) THEN
        IERR=1         !ERROR, MUST FACTOR BEFORE SOLVING
        RETURN
      ENDIF
C     -----------------------------
C     |*** FORWARD ELIMINATION ***|
C     -----------------------------
      DO 20 IB = 1,NB0
      KB=1
      IF(NB.LT.0)KB=IB
      N = NINT(DBLE(A(2)))
      L = 3
      K = 1
      IF ( I1 .LT. 0 ) GOTO 80
30    IF ( K .EQ. N ) GOTO 50
      T = B(K,IB)/A(K+L)
      J = L
      L = L + N - K
      K = K + 1
      IF ( ABS(T) .EQ. TZERO ) GOTO 30
      DO 40 I = K,N
40         B(I,IB) = B(I,IB) - T*A(I+J)
      GOTO 30
C     -----------------------------------
C     |*** BACK SUBSTITUTION BY ROWS ***|
C     -----------------------------------
50    B(N,IB) = B(N,IB)/A(K+L)
60    IF ( K .EQ. KB ) GO TO 20
      J = K
      K = K - 1
      L = L + K - N
      T = B(K,IB)
      DO 70 I = J,N
70         T = T - B(I,IB)*A(I+L)
      B(K,IB) = T/A(K+L)
      GOTO 60
C     -----------------------------
C     |*** COMPUTE NULL VECTOR ***|
C     -----------------------------
80    IF ( ABS(A(K+L)) .EQ. TZERO ) GOTO 90
      L = L + N - K
      K = K + 1
      GOTO 80
90    DO 100 I = 1,N
100        B(I,IB) = TZERO
      B(K,IB) = ONE
      GOTO 60
 20   CONTINUE
      IF(NB.LT.0)THEN
        DO J=1,IB
          DO I=J,IB
            B(J,I)=B(I,J)
          ENDDO
        ENDDO
      ENDIF
      RETURN
      END
C******************************************************************
C
      SUBROUTINE ZLUBT(A,B,LB,NB,IERR)
C      ________________________________________________________
C     |                                                        |
C     |          SOLVE THE TRANSPOSE OF A GENERAL COMPLEX      |
C     |                 LU FACTORED SYSTEM                     |
C     |                                                        |
C     |    INPUT:                                              |
C     |                                                        |
C     |         A     --ZLU'S OUTPUT                           |
C     |                                                        |
C     |         B     --RIGHT SIDE (DESTROYED)                 |
C     |                                                        |
C     |         LB    --LEADING (ROW) DIMENSION OF ARRAY B     |
C     |                                                        |
C     |         NB    --DIMENSION OF MATRIX STORED IN B        |
C     |                                                        |
C     |    OUTPUT:                                             |
C     |                                                        |
C     |         B     --SOLUTION                               |
C     |________________________________________________________|
C
      REAL*8 TZERO,ONE
      COMPLEX*16 A(*),B(LB,*),T
      INTEGER I,J,K,L,M,N,LB,NB,IB,I1,IERR
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
C
      IERR=0
C
      I1 = NINT(DBLE(A(1)))
      IF ( ABS(I1) .NE. 1239 ) THEN
        IERR=1         !ERROR, MUST FACTOR BEFORE SOLVING
        RETURN
      ENDIF
C
      DO 10 IB = 1,NB
      N = NINT(DBLE(A(2)))
      M = N + 1
      IF ( I1 .LT. 0 ) GOTO 80
      T = TZERO
      J = 4
      K = 1
C     -------------------------
C     |*** SKIP OVER ZEROS ***|
C     -------------------------
20    IF ( ABS(B(K,IB)) .NE. TZERO ) GOTO 30
      K = K + 1
      IF ( K .LE. N ) GOTO 20
      GO TO 10
C     ---------------------------
C     |*** FORE SUBSTITUTION ***|
C     ---------------------------
30    J = J - M + M*K
40    B(K,IB) = (B(K,IB)-T)/A(J+K)
      IF ( K .EQ. N ) GOTO 60
      T = TZERO
      J = J + M
      DO 50 I = 1,K
50         T = T + A(I+J)*B(I,IB)
      K = K + 1
      GOTO 40
C     ---------------------------
C     |*** BACK SUBSTITUTION ***|
C     ---------------------------
60    IF ( K .EQ. 1 ) GO TO 10
      J = J - M
      T = B(K-1,IB)
      DO 70 I = K,N
70         T = T - B(I,IB)*A(I+J)
      K = K - 1
      I = NINT(DBLE(A(J)))
      B(K,IB) = B(I,IB)
      B(I,IB) = T
      GOTO 60
C     -----------------------------
C     |*** COMPUTE NULL VECTOR ***|
C     -----------------------------
80    I = 5 + N + M*N
      L = M
90    I = I - M - 1
      L = L - 1
      IF ( ABS(A(I)) .NE. TZERO ) GOTO 90
      K = L
      J = I - K
      DO 100 I = 1,N
100        B(I,IB) = TZERO
      B(K,IB) = ONE
110   IF ( K .EQ. N ) GOTO 60
      T = TZERO
      J = J + M
      DO 120 I = L,K
120        T = T - A(I+J)*B(I,IB)
      K = K + 1
      B(K,IB) = T/A(J+K)
      GOTO 110
10    CONTINUE
      RETURN
      END
C******************************************************************
C
      SUBROUTINE ZLUS(A,LA,N,W,IERR)
C
C      ________________________________________________________
C     |                                                        |
C     |  LU FACTOR A SYMMETRIC COMPLEX MATRIX WITHOUT PIVOTING |
C     |                                                        |
C     |    INPUT:                                              |
C     |                                                        |
C     |        A     --COMPLEX ARRAY CONTAINING MATRIX         |
C     |                (ONLY THE LOWER HALF NEED BE DEFINED)   |
C     |                                                        |
C     |        LA    --LEADING (ROW) DIMENSION OF ARRAY A      |
C     |                                                        |
C     |        N     --MATRIX DIMENSION                        |
C     |                                                        |
C     |        W     --REAL WORK ARRAY WITH LENGTH AT LEAST N  |
C     |                                                        |
C     |    OUTPUT:                                             |
C     |                                                        |
C     |        A     --INVERSE (IN LOWER HALF ONLY)            |
C     |________________________________________________________|
C
      COMPLEX*16 A(*),Y,Z
      INTEGER G,H,I,J,K,L,M,N
      REAL*8 R,S,T,W(*),TZERO
C
      PARAMETER (TZERO=0.0)
C
      IERR=0
C
C     ----------------
CNRB |*** PACK A ***|
C     ----------------
      H=LA-N
      I=0
      M=0
      L=N
      G=(N*(N+1))/2
2     IF(L.EQ.G)GO TO 4
      K=L+1
      M=M+1
      L=L+N-M
      I=I+H+M
      DO J=K,L
        A(J)=A(I+J)
      ENDDO
      GO TO 2
C
C     ------------------------
C     |*** COMPUTE 1-NORM ***|
C     ------------------------
4     DO 10 I = 1,N
10         W(I) = TZERO
      I = -N
      K = 0
      R = TZERO
      S = TZERO
20    I = I + N - K
      K = K + 1
      J = K
      S = ABS(A(I+J))
30    IF ( J .EQ. N ) GOTO 40
      J = J + 1
      T = ABS(A(I+J))
      S = S + T
      W(J) = W(J) + T
      GOTO 30
40    S = S + W(K)
      IF ( R .LT. S ) R = S
      IF ( K .LT. N ) GOTO 20
      J = 3 + (N+N*N)/2
C     -----------------------------------
C     |*** SHIFT MATRIX DOWN 3 SLOTS ***|
C     -----------------------------------
50    A(J) = A(J-3)
      J = J - 1
      IF ( J .GT. 3 ) GOTO 50
      A(1) = 1237
      A(2) = N
      A(3) = R
      H = N
      K = 4
60    IF ( H .EQ. 1 ) GOTO 90
C     --------------------------
C     |*** SAVE PIVOT ENTRY ***|
C     --------------------------
      Z = A(K)
      K = K + H
      G = K
      H = H - 1
      M = H
      IF ( ABS(Z) .EQ. TZERO ) GOTO 100
      J = 0
70    J = J - M
      M = M - 1
      L = G + M
      Y = A(G+J)/Z
C     ---------------------------
C     |*** ELIMINATE BY ROWS ***|
C     ---------------------------
      DO 80 I = G,L
80         A(I) = A(I) - Y*A(I+J)
      G = L + 1
      IF ( M .GT. 0 ) GOTO 70
      GOTO 60
90    IF ( ABS(A(K)) .NE. TZERO ) RETURN
      A(1) = -1237
      RETURN
100   A(1) = -1237
      GOTO 60
      END
C***************************************************************
C
      SUBROUTINE ZMQDTK
C
C NRB:
C  CALCULATION OF K-PHYS FROM K-UNPHYS IN QDT, ALL CHANNELS OPEN.
C  DR N CUT-OFF AT NCUTOFF; EXCITATION IS THEN **UNDAMPED** ABOVE NCUTOFF.
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      LOGICAL QDT
C
      INCLUDE 'PARAM'
C
      PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2)
      PARAMETER (MNPEXT=MZMNP+MZCHF)
      PARAMETER (LWORK=MZCHF*MZCHF)
      PARAMETER (MWORK=MZCHF*MZCHF)
C
      PARAMETER (ZERO=(0.0,0.0))
      PARAMETER (ZONE=(1.0,0.0))
      PARAMETER (ZI=(0.0,1.0))
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
      PARAMETER (QUART=0.25)
      PARAMETER (BIG=170.0)
C
      CHARACTER ELAS*3
C
      COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC
      COMMON/CDEC/ARAD(MXTST),ARDEC(MZTAR),SLIN(MXTST),IRDEC,IEND
     X,IPAR(MZTAR),NEWAR
      COMMON/CEN/ETOT,MXE,NWT,NZ
C  ***  NOTE CHANGE OF CC TO CCT IN /CHAN/ ***
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR)
     5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/COMEGA/OMEGA(MXTST),IE,NOMWRT
      COMMON/CQDT/R2ST(MZCHF),QDT,NQ
      COMMON/NRBDR/PDR(MZCHF),OMEGDR(MZMET,MZMSH),NDRMET
      COMMON/NRBHYB/FNUHYB,NCHCL,ICHCL(MZCHF),NCHHYB,ICHHYB(MZCHF)
      COMMON/NRBKHI/ZKHICC(MZDEG,MZDEG),ZKHIOC(MZCHF,MZDEG),ZVAL(MZDEG)
CBL  X,ZVL(MZDEG,MZDEG),ZVR(MZDEG,MZDEG),RWORK(2*MZDEG)
      COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT
      COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN
      COMMON/NRBRCT/
     X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF)
     X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF)
     X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF)
     X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF)
     X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF)
     X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF)
     X,RMAT(MZCHF,MZCHF)
      COMMON/NRBSCL/ZFSCL(MZCHF),FSCL(MZCHF)
      COMMON/NRBSKP/ISKP(MZMSH),ISKP0,LINC,ELAS
      COMMON/NRBPH1/ZCOEF(MNPEXT,MZCHF),OMEGPR(MZMET,MZMSH),EPHMIN,
     1              EPHMAX,IPHOTO,NODAMP
      COMMON/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF),
     X          ZA(MZCHF,MZCHF),ZB(MZCHF,MZCHF)
      COMMON/NRBPH7/ZBB(MZDIP,MZCHF),ZDIP(MZDIP,MZCHF)
     X,ZD(MZCHF,MZCHF),ZE(MZCHF,MZCHF),ZF(MZCHF,MZCHF)
     X,IDEC(MZEPI*MZMET),JDEC(MZDEC),IPIV(MZCHF),NDEC0
      COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK)
      COMMON/TYPE/NTYP1,NTYP2I,NTYP2OF,NTYP2OR,NMIN
      COMMON/ZCOUL/ZFS(MZPTS,MZCHF),ZFSP(MZCHF),ZFC(MZPTS,MZCHF)
     1 ,ZFCP(MZCHF),ZFKNU(MZCHF)
      COMMON/AUGER/AAUGER(MZTAR),IAUGER
      COMMON/NRBZED/TZED,LPRTSW
C
      DIMENSION P(MZCHF,MZCHF),Q(MZCHF,MZCHF)
     X         ,POLD(MZCHF,MZCHF),QOLD(MZCHF,MZCHF)
      DIMENSION ZKHICO(MZDEG,MZCHF)
C
      EQUIVALENCE (P,CSP),(Q,CC),(POLD,DSP),(QOLD,DC)
      EQUIVALENCE (ZKHICO,ZKHIOC)
C
C
      IF(IOMSW.LT.0)THEN
        NCC=NCHCL
      ELSE
        NCC=NCHF-NCHOP
        DO N=1,NCC
          ICHCL(N)=NCHOP+N
        ENDDO
      ENDIF
C
      IF(NCC.GT.MZDEG)THEN
        WRITE(6,610)NCC
        STOP 'INCREASE MZDEG'
      ENDIF
C
      xeps=.75
      PI=ACOS(-ONE)
      TPI=TWO*PI
      CONST=TPI
      IF(TZED.GT.TZERO)CONST=TPI/DBLE((NZED-NELC)**2)
      IONE=1
      IF(ELAS.EQ.'YES')IONE=0
C
C INITIALIZE KCC
C
      DO N2=1,NCC
        DO N1=1,NCC
          ZKHICC(N1,N2)=DCMPLX(P(ICHCL(N1),ICHCL(N2))
     X                        ,Q(ICHCL(N1),ICHCL(N2)))
        ENDDO
      ENDDO
C
C ZKCC-ZFDEC         (ZFDEC=-TAN(PI*NU))
C
      ITARGN=0
      DO N=1,NCC
        NNN=ICHCL(N)
C
C RADIATIVE DECAYS; RECALCULATE ARDEC (DEPENDS ON ETOT) IF NECESS.
C
        IF(IRDEC*NEWAR.GT.0.AND..NOT.QDT
     X                     .AND.ITARG(NNN).NE.ITARGN)THEN
          ITARGN=ITARG(NNN)
          KVEC=((ITARG(NNN)-IONE)*(ITARG(NNN)-1-IONE))/2
          ARDEC(ITARG(NNN))=TZERO
          DO JLOOP=1,ITARG(NNN)-1
            KVEC=KVEC+1
            IF(ETOT-(ENAT(ITARG(NNN))-ENAT(JLOOP)).LE.ENAT(1))THEN
              ARDEC(ITARG(NNN))=ARDEC(ITARG(NNN))+ARAD(KVEC)
            ENDIF
          ENDDO
          ARDEC(ITARG(NNN))=ARDEC(ITARG(NNN))*CONST
        ENDIF
C
        IF(TZED.EQ.TZERO)THEN
            ZFDEC=ZI
            ZFDEC=ZFDEC/ZFSCL(NNN)**2  !COMPLEX FACTOR
            ZFDEC=ZFDEC/FSCL(NNN)**2   !ENERGY FACTOR
            ZFDEC=-ZFDEC
        ELSE
          IF(IRDEC.EQ.0.OR.FKNU(NNN).GT.NCUTOFF
     x      .or. llch(nnn).gt.0.and.fknu(nnn).lt.llch(nnn)+xeps
     X      .OR.(NTYP1.EQ.0.AND.IAUGER.LE.0))THEN
C NONE
            ZFKNU(NNN)=FKNU(NNN)
            PINU=FKNU(NNN)*PI
            ZFDEC=-DCMPLX(TAN(PINU),TZERO)
          ELSE
            TR=ONE/FKNU(NNN)**2
            TI=TZERO
            IF(NTYP1.GT.0)TI=-ARDEC(ITARG(NNN))/TPI
            IF(IAUGER.GT.0)TI=TI-AAUGER(ITARG(NNN))    !A.U. HERE
            ZFKNU(NNN)=DCMPLX(ONE,TZERO)/SQRT(DCMPLX(TR,TI))
            IF(DIMAG(ZFKNU(NNN)).LT.BIG)THEN
              ZSIN=SIN(PI*ZFKNU(NNN))
              ZCOS=COS(PI*ZFKNU(NNN))
              ZTAN=ZSIN/ZCOS
            ELSE
              ZTAN=DCMPLX(TZERO,ONE)
            ENDIF
            ZFDEC=-ZTAN
          ENDIF
        ENDIF
C
        IF(IOMIT(NNN).LT.0)ZFDEC=-ZFDEC
        ZKHICC(N,N)=ZKHICC(N,N)-ZFDEC
      ENDDO
C
      DO N=1,NCC
        IF(IOMIT(ICHCL(N)).GT.0)ZKHICC(N,N)=ZONE
      ENDDO
C
C INITIALIZE KCO
C
      DO N2=1,NCHOP
        DO N1=1,NCC
          IF(FKNU(ICHCL(N1)).LE.NCUTOFF)THEN
            ZKHICO(N1,N2)=DCMPLX(P(ICHCL(N1),N2),Q(ICHCL(N1),N2))
          ELSE
            ZKHICO(N1,N2)=TZERO
          ENDIF
        ENDDO
      ENDDO
C
CSTRTNBL
CNBL  CALL ZLUS(ZKHICC,MZDEG,NCC,WORK,IERR)
CNBL  IF (IERR.NE.0) THEN
CNBL    WRITE(6,600)
CNBL    STOP 'ERROR IN ZLUS'
CNBL  END IF
CNBL  CALL ZLUBS(ZKHICC,ZKHICO,MZDEG,NCHOP,IERR)
CNBL  IF (IERR.NE.0) THEN
CNBL    WRITE(6,601)
CNBL    STOP 'ERROR IN ZLUBS'
CNBL  END IF
CENDNBL
C
CSTRTBL
      CALL ZSYTRF('L',NCC,ZKHICC,MZDEG,IPIV,ZWORK,MWORK,INFO)
      IF (INFO.NE.0) THEN
         WRITE(6,602) INFO
         STOP
      ENDIF
      CALL ZSYTRS('L',NCC,NCHOP,ZKHICC,MZDEG,IPIV,ZKHICO,MZDEG,INFO)
      IF (INFO.NE.0) THEN
         WRITE(6,603) INFO
         STOP
      ENDIF
CENDBL
C
C
C CLOSE-OFF (SOME) OPEN CHANNELS TO FORM PHYSICAL K-MATRIX
C (THERE MAY BE NO SUBSEQUENT CALL TO SQDT)
C
      DO K=1,NCC
        K1=NCHOP+K
        KI=ICHCL(K)
        IF(FKNU(KI).LE.NCUTOFF)THEN
          DO I=1,NCHOP
            ZK(I,K1)=-DCMPLX(P(I,KI),Q(I,KI))          !KOC
          ENDDO
        ELSE
          DO I=1,NCHOP
            ZK(I,K1)=ZERO
          ENDDO
        ENDIF
      ENDDO
C
CSTRTNBL
CNBL  DO J=1,NCHOP
CNBL    DO I=1,J
CNBL      ZK(I,J)=DCMPLX(P(I,J),Q(I,J))
CNBL    ENDDO
CNBL    DO K=1,NCC
CNBL      K1=NCHOP+K
CNBL      DO I=1,J
CNBL        ZK(I,J)=ZK(I,J)+ZK(I,K1)*ZKHICO(K,J)
CNBL      ENDDO
CNBL    ENDDO
CNBL  ENDDO
C
C SYMMETRIZE
C
CNBL  DO J=1,NCHOP
CNBL    DO I=1,J
CNBL      ZK(J,I)=ZK(I,J)
CNBL    ENDDO
CNBL  ENDDO
CENDNBL
C
CSTRTBL
      DO J=1,NCHOP
        DO I=1,NCHOP
          ZK(I,J)=DCMPLX(P(I,J),Q(I,J))
        ENDDO
      ENDDO
C
      CALL ZGEMM('N','N',NCHOP,NCHOP,NCC,ZONE,ZK(1,NCHOP1),MZCHF
     X           ,ZKHICO,MZCHF,ZONE,ZK,MZCHF)
CENDBL
C
C
C STORE ORIGINAL P,Q
C
      DO J=1,NCHF
        DO I=1,NCHF
          POLD(I,J)=P(I,J)
          QOLD(I,J)=Q(I,J)
        ENDDO
      ENDDO
C
C DETERMINE PHYSICAL DIPOLE MATRIX FOR PARTIAL PHOTORECOMBINATION/IONIZATION
C (AND, OPTIONALLY, PHOTOABSORPTION)
C
      IF(NDEC0.GT.0)THEN
C
        IF(IPHOTO.GE.1000)CALL PIABSK
C
        IPHOTO0=MOD(IPHOTO,1000)
C
        IF(IPHOTO0.NE.0)THEN
C
          DO K=1,NCC
            KI=ICHCL(K)
            DO I=1,NDEC0
              ZBB(I,K)=-ZDIP(I,KI)
            ENDDO
          ENDDO
CSTRTNBL
CNBL      DO J=1,NCHOP
CNBL        DO K=1,NCC
CNBL          DO I=1,NDEC0
CNBL            ZDIP(I,J)=ZDIP(I,J)+ZBB(I,K)*ZKHICO(K,J)
CNBL          ENDDO
CNBL        ENDDO
CNBL      ENDDO
CENDNBL
C
CSTRTBL
          CALL ZGEMM('N','N',NDEC0,NCHOP,NCC,ZONE,ZBB,MZDIP
     X               ,ZKHICO,MZCHF,ZONE,ZDIP,MZDIP)
CENDBL
C
        ENDIF
C
      ENDIF
C
      RETURN
  600 FORMAT(' SR.ZMQDTK: ZLUS RETURNED WITH INFO =',I6)
  601 FORMAT(' SR.ZMQDTK: ZLUBS RETURNED WITH INFO =',I6)
  602 FORMAT(//10X,10('*'),' SR.ZMQDTK: ZSYTRF RETURNED WITH INFO =',I6)
  603 FORMAT(//10X,10('*'),' SR.ZMQDTK: ZSYTRS RETURNED WITH INFO =',I6)
  610 FORMAT(//10X,10('*'),' SR.ZMQDTK: NUMBER OF MQDT CLOSED',
     X ' CHANNELS, NCC = ',I4/20X,' LARGER THAN DIMENSION',
     X ' VALUE OF DEG = MZDEG'//)
      END
C***************************************************************
C
      SUBROUTINE ZNUMT(E,C,R1,HP,N1,N2,I)
C
C  NUMEROV INTEGRATION OF COULOMB FUNCTIONS.
C  THE INTERVAL HP IS POSITIVE.
C  INTEGRATION FROM TABULAR POINT N1 TO TABULAR POINT N2.
C  FUNCTIONS THETA,THETP STORED IN FS,FSP
C  FUNCTIONS THETAD,THETADP STORED IN FC,FCP
C  STARTS WITH FUNCTIONS AND DERIVATIVES AT N1 STORED IN FS, FSP, FC, FCP
C  CALCULATES FUNCTIONS AT ALL POINTS TO N2 AND THE DERIVATIVE AT THE
C  POINT N2.
C NRB:
C  ASSUMES OUTWARD INTEGRATION OF THETA,THETADOT CORRECTLY NORMALIZED
C  AND FINAL DERIVATIVE NOT NEEDED.
C
      IMPLICIT COMPLEX*16 (A-H,O-Z)
      REAL*8 C,R1,HP,ONE,TWO,THREE,FOUR,SIX,TEN,TWELVE
     X      ,P1,P2,P3,P4,P5,P6,P7,P8,TZED
C
      INCLUDE 'PARAM'
C
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
      PARAMETER (THREE=3.0)
      PARAMETER (FOUR=4.0)
      PARAMETER (SIX=6.0)
      PARAMETER (SEVEN=7.0)
      PARAMETER (TEN=10.0)
      PARAMETER (TWELVE=12.0)
      PARAMETER (P1=ONE/30.)
      PARAMETER (P2=ONE/40.)
      PARAMETER (P3=SEVEN/15.)
      PARAMETER (P4=TWO/15.)
      PARAMETER (P5=ONE/360.)
      PARAMETER (P6=ONE/20.)
      PARAMETER (P7=ONE/120.)
      PARAMETER (P8=ONE/TWELVE)
C
      COMMON/ZCOUL/FS(MZPTS,MZCHF),FSP(MZCHF),FC(MZPTS,MZCHF)
     1 ,FCP(MZCHF),ZFKNU(MZCHF)
      COMMON/ZCTHET/BB(MZCHF,MZTET),BG(MZCHF,MZTET),MSUM(MZCHF)
      COMMON/NRBZED/TZED,LPRTSW
C
      V(X)=EQ+X*(Q2*TZED-X*CQ)
C
      N21=ABS(N2)-N1
C
C  RENORMALISE FOR CASE OF N2.EQ.N1
C
      IF(N21.NE.0)GOTO 5
      W=FS(N1,I)*FCP(I)-FSP(I)*FC(N1,I)
      IF(W.EQ.0.0)RETURN
      W1=ONE/SQRT(W)
      FS(N1,I)=FS(N1,I)*W1
      FC(N1,I)=FC(N1,I)*W1
      FSP(I)=FSP(I)*W1
      FCP(I)=FCP(I)*W1
      BB(I,2)=BB(I,2)*W1
      NM=MSUM(I)
      DO M=3,NM
        BB(I,M)=BB(I,M)*W1
        BG(I,M)=BG(I,M)*W1
      ENDDO
      RETURN
C
C  INTEGRATIONS FOR N2.NE.N1
C
   5  IP=IABS(N21)
      IS=N21/IP
      H=HP*IS
      K=N1
      IP=IP-1
C
      F1=FS(N1,I)
      F1P=FSP(I)
      G1=FC(N1,I)
      G1P=FCP(I)
C
C  FUNCTIONS AT K=(N1+IS)
C
      Q=H*H
      EQ=E*Q
      Q2=TWO*Q
      CQ=C*Q
C
C      Q=0.0          !FOR XI SOLUTION
C
      X1=ONE/R1
      CX=C*X1
      HX=H*X1
      A1=-TWO*HX*HX*H
      U1P=A1*(ONE*tzed-CX)
      A1=-A1*HX
      U1PP=A1*(TWO*tzed-THREE*CX)
      A1=-A1*HX*SIX
      U1PPP=A1*(ONE*tzed-TWO*CX)
      U1=V(X1)
C
      R2=R1+H
      X2=ONE/R2
      U2=V(X2)
C
      A2=ONE+U2*P1
      B1=ONE+U1*(P2*U1-P3)-P4*U1P-P2*U1PP
     1 +P5*(FOUR*U1*U1P-U1PPP)
      C1=H*(ONE+U1*(P5*U1-P4)
     1 -P6*U1P-P7*U1PP)
      B2=P1*Q
      D1=Q*(-P3+P2*U1+P5*U1P)    !FOR XI DELETE P2*U1
      E1=H*Q*(-P4+P5*U1)
C
      F2=(B1*F1+C1*F1P)/A2
      G2=(B1*G1+C1*G1P+D1*F1+E1*F1P-B2*F2)/A2
      K=K+IS
      FS(K,I)=F2
      FC(K,I)=G2
C
C
      U3=U2
      U2=U1
      F3=F2
      F2=F1
      G3=G2
      G2=G1
      X3=X2
      IF(IP.EQ.0)GOTO 20
C
C  CONTINUE INTEGRATION
C
      EQ=EQ*P8
      Q2=Q2*P8
      CQ=CQ*P8
      U2=U2*P8
      U3=U3*P8
      Q=Q*P8
      R3=R2
C
      DO M=1,IP
        U1=U2
        U2=U3
        F1=F2
        F2=F3
        G1=G2
        G2=G3
        R3=R3+H
        X3=ONE/R3
        U3=V(X3)
        D3=ONE/(ONE+U3)
        D2=(TWO-TEN*U2)*D3
        D1=(ONE+U1)*D3
        F3=D2*F2-D1*F1
        G3=D2*G2-D1*G1-Q*D3*(F3+TEN*F2+F1)
        K=K+IS
        FC(K,I)=G3
        FS(K,I)=F3
      ENDDO
C
      U2=TWELVE*U2
      U3=TWELVE*U3
      EQ=TWELVE*EQ
      Q2=TWELVE*Q2
      CQ=TWELVE*CQ
      Q=TWELVE*Q
C
   20 IF(N1.LT.ABS(N2))RETURN
C
C  CALCULATE FINAL DERIVATIVE
C
      H=-H
      CX=C*X3
      HX=H*X3
      A1=-TWO*HX*HX*H
      U3P=A1*(ONE*tzed-CX)
      A1=-A1*HX
      U3PP=A1*(TWO*tzed-THREE*CX)
      A1=-A1*HX*SIX
      U3PPP=A1*(ONE*tzed-TWO*CX)
      A2=ONE+U2*P1
      B3=ONE+U3*(P2*U3-P3)-P4*U3P-P2*U3PP
     1 +P5*(FOUR*U3*U3P-U3PPP)
      C3=H*(ONE+U3*(P5*U3-P4)-P6*U3P
     1 -P7*U3PP)
      B2=P1*Q
      D3=Q*(-P3+P2*U3+P5*U3P)     !FOR XI DELETE P2*U3
      E3=H*Q*(-P4+P5*U3)
      F3P=(A2*F2-B3*F3)/C3
      G3P=(A2*G2-B3*G3+B2*F2-D3*F3-E3*F3P)/C3
C
C  RE-NORMALISE CLOSED-CHANNEL FUNCTIONS
C
      AMAX=ONE/MAX(ABS(F3),ABS(G3),ABS(F3P),ABS(G3P))
      AF3=F3*AMAX
      AG3=G3*AMAX
      AF3P=F3P*AMAX
      AG3P=G3P*AMAX
      W1=AF3*AG3P-AF3P*AG3
      W1=AMAX/SQRT(W1)
      FSP(I)=F3P*W1
      FCP(I)=G3P*W1
      IPMX=IP+2
      IF(N2.LT.0)IPMX=MZPTS
      DO J=1,IPMX
        FS(J,I)=FS(J,I)*W1
        FC(J,I)=FC(J,I)*W1
      ENDDO
C
C  RE-NORMALISE COEFFICIENTS
C
      BB(I,2)=BB(I,2)*W1
      NM=MSUM(I)
      DO M=3,NM
        BB(I,M)=BB(I,M)*W1
        BG(I,M)=BG(I,M)*W1
      ENDDO
C
      RETURN
      END
C***************************************************************
C
      SUBROUTINE ZPETFSC
C
C NRB;
C PERTURB S AND C WHERE F=S+C*K
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (ZONE=(1.0,0.0))
      PARAMETER (ZERO=(0.0,0.0))
C
      COMMON/CALP/ASS(MZCHF,MZCHF),ASC(MZCHF,MZCHF),ACS(MZCHF,MZCHF)
     1 ,ACC(MZCHF,MZCHF)
C  ***  NOTE CHANGE OF CC TO CCT IN /CHAN/ ***
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/NRBHYB/FNUHYB,NCHCL,ICHCL(MZCHF),NCHHYB,ICHHYB(MZCHF)
      COMMON/NRBRCT/
     X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF)
     X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF)
     X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF)
     X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF)
     X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF)
     X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF)
     X,RMAT(MZCHF,MZCHF)
      COMMON/NRBGAM/ZGAM(MZCHF),GAM(MZCHF)
      COMMON/NRBPH2/ZS(MZCHF),ZSP(MZCHF),ZC(MZCHF),ZCP(MZCHF)
      COMMON/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF),
     X          ZA(MZCHF,MZCHF),ZB(MZCHF,MZCHF)
      COMMON/NRBPH5/ZCS(MZCHF,MZCHF),ZCSP(MZCHF,MZCHF),ZCC(MZCHF,MZCHF)
     1 ,ZCCP(MZCHF,MZCHF)
C
C
C  CALCULATE PERTURBED FUNCTIONS
C
C     OPEN-OPEN
C
        DO J=1,NCHOP
          DO I=1,NCHOP
            ZCS(I,J)=S(I)*ACS(I,J)-C(I)*ASS(I,J)
            ZCSP(I,J)=SP(I)*ACS(I,J)-CP(I)*ASS(I,J)
            ZCC(I,J)=S(I)*ACC(I,J)-C(I)*ASC(I,J)
            ZCCP(I,J)=SP(I)*ACC(I,J)-CP(I)*ASC(I,J)
CSTGF            CSPP(I,J)=SPP(I)*ACS(I,J)-CPP(I)*ASS(I,J)
CSTGF            CCPP(I,J)=SPP(I)*ACC(I,J)-CPP(I)*ASC(I,J)
CSTGF            DS(I,J)=CS(I,J)
CSTGF            DC(I,J)=CC(I,J)
CSTGF            DSP(I,J)=CSP(I,J)
CSTGF            DCP(I,J)=CCP(I,J)
          ENDDO
        ENDDO
        DO I=1,NCHOP
          ZCS(I,I)=ZCS(I,I)+S(I)-ZGAM(I)*C(I)        !ZGAM=0, IQDT=1,2
          ZCSP(I,I)=ZCSP(I,I)+SP(I)-ZGAM(I)*CP(I)
          ZCC(I,I)=ZCC(I,I)+C(I)
          ZCCP(I,I)=ZCCP(I,I)+CP(I)
CSTGF          CSPP(I,I)=CSPP(I,I)+SPP(I)
CSTGF          CCPP(I,I)=CCPP(I,I)+CPP(I)
        ENDDO
C
        IF(NCHOP.EQ.NCHF)GOTO 270      !IQDT=1,2
C
C     CLOSED-OPEN
C
        DO J=1,NCHOP
          DO I=NCHOP1,NCHF
            ZCS(I,J)=ZC(I)*ASS(I,J)-ZS(I)*ACS(I,J)
            ZCSP(I,J)=ZCP(I)*ASS(I,J)-ZSP(I)*ACS(I,J)
            ZCC(I,J)=ZC(I)*ASC(I,J)-ZS(I)*ACC(I,J)
            ZCCP(I,J)=ZCP(I)*ASC(I,J)-ZSP(I)*ACC(I,J)
CSTGF            CSPP(I,J)=CPP(I)*ASS(I,J)-SPP(I)*ACS(I,J)
CSTGF            CCPP(I,J)=CPP(I)*ASC(I,J)-SPP(I)*ACC(I,J)
CSTGF            DS(I,J)=CS(I,J)
CSTGF            DC(I,J)=CC(I,J)
CSTGF            DSP(I,J)=CSP(I,J)
CSTGF            DCP(I,J)=CCP(I,J)
          ENDDO
        ENDDO
C
C     OPEN-CLOSED
C
        DO J=NCHOP1,NCHF
          DO I=1,NCHOP
            ZCC(I,J)=S(I)*ACS(I,J)-C(I)*ASS(I,J)
            ZCCP(I,J)=SP(I)*ACS(I,J)-CP(I)*ASS(I,J)
CSTGF            CCPP(I,J)=SPP(I)*ACS(I,J)-CPP(I)*ASS(I,J)
CSTGF            DC(I,J)=CC(I,J)
CSTGF            DCP(I,J)=CCP(I,J)
          ENDDO
        ENDDO
C
C     CLOSED-CLOSED
C
        DO J=NCHOP1,NCHF
          DO I=NCHOP1,NCHF
            ZCC(I,J)=ZC(I)*ASS(I,J)-ZS(I)*ACS(I,J)
            ZCCP(I,J)=ZCP(I)*ASS(I,J)-ZSP(I)*ACS(I,J)
CSTGF            CCPP(I,J)=CPP(I)*ASS(I,J)-SPP(I)*ACS(I,J)
CSTGF            DC(I,J)=CC(I,J)
CSTGF            DCP(I,J)=CCP(I,J)
          ENDDO
        ENDDO
        DO I=NCHOP1,NCHF
          ZCC(I,I)=ZCC(I,I)+ZS(I)+ZGAM(I)*ZC(I)
          ZCCP(I,I)=ZCCP(I,I)+ZSP(I)+ZGAM(I)*ZCP(I)
        ENDDO
C
  270   CONTINUE
        IF(NCHHYB.GT.0)THEN
          DO N=1,NCHHYB
            I=ICHHYB(N)
            ZCC(I,I)=ZS(I)+ZGAM(I)*ZC(I)         !SINCE ALPHA=0
            ZCCP(I,I)=ZSP(I)+ZGAM(I)*ZCP(I)
            ZCS(I,I)=ZERO
            ZCSP(I,I)=ZERO
          ENDDO
        ENDIF
C
C  CALCULATE MATRICES A AND B
C
        DO J=1,NCHF
          DO I=1,NCHF
            ZA(I,J)=ZCC(I,J)
          ENDDO
CSTRTNBL
CNBL    DO K=1,NCHF
CNBL      DO I=1,NCHF
CNBL        ZA(I,J)=ZA(I,J)-ZR(I,K)*ZCCP(K,J)
CNBL      ENDDO
CNBL    ENDDO
CENDNBL
        ENDDO
        DO J=1,NCHOP
          DO I=1,NCHF
            ZB(I,J)=ZCS(I,J)
          ENDDO
CSTRTNBL
CNBL    DO K=1,NCHF
CNBL      DO I=1,NCHF
CNBL        ZB(I,J)=ZB(I,J)-ZR(I,K)*ZCSP(K,J)
CNBL      ENDDO
CNBL    ENDDO
CENDNBL
        ENDDO
CSTRTBL
        CALL ZGEMM('N','N',NCHF,NCHF,NCHF,-ZONE,ZR,MZCHF,ZCCP,MZCHF,
     X    ZONE,ZA,MZCHF)
        CALL ZGEMM('N','N',NCHF,NCHOP,NCHF,-ZONE,ZR,MZCHF,ZCSP,MZCHF,
     X    ZONE,ZB,MZCHF)
CENDBL
C
        RETURN
        END
C***************************************************************
C
      SUBROUTINE ZPHIN(I,ZR,N1,N2,ZAI,ZPI)
C
C  COMPUTES AMPLITUDE ZAI AND PHASE ZPI OF COULOMB FUNCTION ZPHI
C  FOR COMPLEX-RADIAL CO-ORDINATE ZR.
C  USES DATA IN ARRAY D WHICH IS HELD IN COMMON/CJWBK/
C  AND SHOULD HAVE BEEN COMPUTED IN SUBROUTINE INJWBK.
C  THE STRUCTURE OF ZPHI IS SIMILAR TO THAT OF SUBROUTINE JWBK.
CNRB
C  NEUTRAL CASE ADDED
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (MX15N=15*MZCHF)
C
      COMMON/CJWBK/D(MX15N)
      COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC
      COMMON/NRBZED/TZED,LPRTSW
C
      DIMENSION ZAI(30),ZPI(30),ZR(30)
C
C
      NP = 0
C
      JKB=(I-1)*15
      E=D(JKB+1)
      C=D(JKB+4)
C
      IF(TZED.EQ.0)THEN
        FK=D(JKB+2)
        IF(C.EQ.0)THEN
          DO N=N1,N2
            NP=NP+1
            ZAI(NP)=1.0/SQRT(FK)
            ZPI(NP)=FK*ZR(NP)
          ENDDO
        ELSE
          DO N=N1,N2
            NP=NP+1
            ZX=1./ZR(NP)
            ZXSQ=ZX*ZX
            ZW=E-C*ZXSQ
            ZA1=0.0625*(ZX/ZW)**3
            ZCC=ZA1*(D(JKB+14)*ZXSQ+D(JKB+12))*ZX
            ZWH=SQRT(ZW)
            Z=ZR(NP)*ZWH
            ZSQ=Z*Z
            ZP=(ZSQ-0.125-.2083333*C/ZSQ)/Z+D(JKB+15)
            ZA1=1./(ZR(NP)*FK)
            ZS=D(JKB+5)*ZA1
            ZG=Z*ZA1
            ZP=ZP+D(JKB+6)*(0.,-1.)*LOG(ZG+(0.,1.)*ZS)
            ZPI(NP)=ZP
            ZAI(NP)=(1.-ZCC)/SQRT(ZWH)
          ENDDO
        ENDIF
        RETURN
      ENDIF
C
      IF(E.GT.0) THEN
        IF(C.GT.0) THEN
          DO N=N1,N2
            NP = NP+1
            ZX=1./ZR(NP)
            ZW=E+ZX*(2.-C*ZX)
            ZWH=SQRT(ZW)
            Z=ZR(NP)*ZWH
            FK=D(JKB+2)
            ZRK=ZR(NP)*FK
            ZRMC=ZR(NP)-C
            ZALP=Z+ZRK
            CK=D(JKB+10)
C  COMPUTE PHASE
            ZP=Z+D(JKB+15)
C  LOG TERM
            ZB=FK*ZALP
            IF(ABS(ZB).GT.ACJWBK) THEN
              ZP=ZP+D(JKB+3)*LOG(1.+ZB)
            ELSE
              ZB=-ZB
              ZP=ZP+ZALP*((((.2*ZB+.25)*ZB+.33333333)*ZB+.5)*ZB+1.)
            END IF
C  ARCTAN TERM
            ZA1=1./(ZR(NP)*D(JKB+7))
            ZS=D(JKB+5)*(Z-FK*ZRMC)*ZA1
            ZG=(CK*Z+ZRMC)*ZA1
            ZP=ZP+D(JKB+6)*(0.,-1.)*LOG(ZG+(0.,1.)*ZS)
C  CAP PHI TERM
            ZP=ZP+((5.*ZRMC/(Z*Z))-(Z*D(JKB+9)+ZRK*D(JKB+8)+CK)/
     X        (ZALP*D(JKB+7)))/(24.*Z)
C  COMPLETE CALCULATION OF ZPHI
            ZA1=.0625*(ZX/ZW)**3
            ZCC=ZA1*(((D(JKB+14)*ZX+D(JKB+13))*ZX+D(JKB+12))*ZX+
     X        D(JKB+11))
            ZPI(NP)=ZP
            ZAI(NP)=(1.-ZCC)/SQRT(ZWH)
          ENDDO
        ELSE
C  CASE OF C.EQ.0 AND E.GT.0
C
          DO N=N1,N2
            NP = NP+1
            ZX=1./ZR(NP)
            ZW=2.*ZX+E
            ZWH=SQRT(ZW)
            Z=ZR(NP)*ZWH
            FK=D(JKB+2)
            ZRK=ZR(NP)*FK
            ZALP=Z+ZRK
C  COMPUTE PHASE
            ZP=Z+D(JKB+15)
            ZB=FK*ZALP
            IF(ABS(ZB).GT.ACJWBK) THEN
              ZP=ZP+D(JKB+3)*LOG(1.+ZB)
            ELSE
              ZB=-ZB
              ZP=ZP+ZALP*((((.2*ZB+.25)*ZB+.33333333)*ZB+.5)*ZB+1.)
            END IF
            ZP=ZP+1/(4.*ZALP)+(5.*ZR(NP)/(Z*Z)-2.*(Z+ZALP)/ZALP)/(24.*Z)
C  COMPLETE CALCULATION OF ZPHI
            ZA1=.0625*(ZX/ZW)**3
            ZCC=ZA1*(-4.*E-3.*ZX)
            ZPI(NP)=ZP
            ZAI(NP)=(1.-ZCC)/SQRT(ZWH)
          ENDDO
        ENDIF
      ELSE
        IF(C.EQ.0) THEN
          DO N=N1,N2
            NP = NP+1
            ZX=1./ZR(NP)
            ZW=2.*ZX
            ZWH=SQRT(ZW)
            Z=ZR(NP)*ZWH
            ZP=2.*Z*(1.+.046875*ZX)+D(JKB+15)
            ZWMQ=1./SQRT(ZWH)
            ZET=(1.+.0234375*ZX)*ZWMQ
            ZAI(NP)=ZET
            ZPI(NP)=ZP
          ENDDO
        ELSE
C
C  CASE OF E.EQ.0 AND C.GT.0
C
          DO N=N1,N2
            NP = NP+1
            ZX=1./ZR(NP)
            ZW=ZX*(2.-C*ZX)
            ZWH=SQRT(ZW)
            Z=ZR(NP)*ZWH
            ZRMC=ZR(NP)-C
C  COMPUTE PHASE
            ZP=2.*Z+D(JKB+15)
            ZA1=1./ZR(NP)
            ZS=D(JKB+5)*Z*ZA1
            ZG=ZRMC*ZA1
            ZP=ZP+D(JKB+6)*(0.,-1.)*LOG(ZG+(0.,1.)*ZS)
            ZP=ZP-(3.*ZR(NP)+C)/(24.*(ZRMC+ZR(NP))*Z)
C  COMPLETE CALCULATION OF ZPHI
            ZA1=.0625*(ZX/ZW)**3
            ZCC=((D(JKB+14)*ZX+D(JKB+13))*ZX-3.)*ZX*ZA1
            ZAI(NP)=(1.-ZCC)/SQRT(ZWH)
            ZPI(NP)=ZP
          ENDDO
        ENDIF
      ENDIF
      RETURN
      END
C***************************************************************
C
      SUBROUTINE ZPQ
C
C NRB:
C  CALCULATE MATRICES P AND Q,
C    TRANSMISSION MATRIX  IS -2*I*(P+I*Q), I=SQRT(-1)
C    NOTE: WITH A COMPLEX ZK IT IS SLIGHTLY FASTER TO SOLVE AX=B.
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (LWORK=MZCHF*MZCHF)
      PARAMETER (MWORK=MZCHF*MZCHF)
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ZERO=(0.0,0.0))
      PARAMETER (ZONE=(1.0,0.0))
      PARAMETER (ZI=(0.0,1.0))
C
C  ***  NOTE CHANGE OF CC TO CCT IN /CHAN/ ***
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/NRBRCT/
     X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF)
     X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF)
     X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF)
     X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF)
     X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF)
     X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF)
     X,RMAT(MZCHF,MZCHF)
      COMMON/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF),
     X          ZA(MZCHF,MZCHF),ZB(MZCHF,MZCHF)
      COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN
      COMMON/NRBSCL/ZFSCL(MZCHF),FSCL(MZCHF)
      COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK)
      COMMON/NRBZED/TZED,LPRTSW
C
      DIMENSION IPIV(MZCHF)
      DIMENSION P(MZCHF,MZCHF),Q(MZCHF,MZCHF)
C
      EQUIVALENCE (P,CSP),(Q,CC)
C
C
C  FIRST, UNSCALE K-MX IF NECESSARY
C
      IF(TZED.EQ.TZERO.AND.IQDT.GT.0)THEN
        DO J=1,NCHOP          !NCHF IF IOPEN SCALE
          DO I=1,NCHOP        !      DITTO
            ZK(I,J)=ZFSCL(I)*FSCL(I)*ZK(I,J)*FSCL(J)*ZFSCL(J)
          ENDDO
        ENDDO
      ENDIF
C
C  ZA=(I+ZK)**(-1)
C
      DO J=1,NCHOP
        DO I=1,NCHOP
          ZA(I,J)=ZK(I,J)
          ZB(I,J)=ZK(I,J)                !INITIALIZE
        ENDDO
      ENDDO
      DO I=1,NCHOP
        ZA(I,I)=ZA(I,I)+ZI
      ENDDO
C
CSTRTNBL
CNBL  CALL ZLUS(ZA,MZCHF,NCHOP,WORK,IERR)
CNBL  IF (IERR.NE.0) THEN
CNBL    WRITE(6,600)
CNBL    STOP 'ERROR IN ZLUS'
CNBL  END IF
CNBL  CALL ZLUBS(ZA,ZB,MZCHF,-NCHOP,IERR)            !COMPUTE HALF ONLY
CNBL  IF (IERR.NE.0) THEN
CNBL    WRITE(6,601)
CNBL    STOP 'ERROR IN ZLUBS'
CNBL  END IF
CENDNBL
CSTRTBL
      CALL ZSYTRF('L',NCHOP,ZA,MZCHF,IPIV,ZWORK,MWORK,INFO)
      IF (INFO.NE.0) THEN
         WRITE(6,602) INFO
         STOP 'FAILURE IN BLAS ROUTINE ZSYTRF'
      ENDIF
      CALL ZSYTRS('L',NCHOP,NCHOP,ZA,MZCHF,IPIV,ZB,MZCHF,INFO)
      IF (INFO.NE.0) THEN
         WRITE(6,603) INFO
         STOP 'FAILURE IN BLAS ROUTINE ZSYTRS'
      ENDIF
CENDBL
C
      DO J=1,NCHOP
        DO I=1,NCHOP
          P(I,J)=-DIMAG(ZB(I,J))
          Q(I,J)=DBLE(ZB(I,J))
        ENDDO
      ENDDO
C
      RETURN
C
  600 FORMAT(' SR.ZPQ: ZLUS RETURNED WITH INFO =',I6)
  601 FORMAT(' SR.ZPQ: ZLUBS RETURNED WITH INFO =',I6)
  602 FORMAT(//10X,10('*'),' SR. ZPQ: ZSYTRF RETURNED WITH INFO =',I6)
  603 FORMAT(//10X,10('*'),' SR. ZPQ: ZSYTRI RETURNED WITH INFO =',I6)
C
      END
C***********************************************************************
C
C A FULL BLAS IMPLEMENTATION OF THIS ZRMAT SUBROUTINE IS AVAILABLE, BUT,
C IT HAS *NOT* BEEN TESTED, CONTACT NRB IF YOU WANT TO BE THE GUINEA PIG
C
C***********************************************************************
C
      SUBROUTINE ZRMAT
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (MNPEXT=MZMNP+MZCHF)
      PARAMETER (LWORK=MZCHF*MZCHF)
      PARAMETER (MWORK=MZCHF*MZCHF)
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
      PARAMETER (THREE=3.0)
      PARAMETER (ZERO=(0.0,0.0))
C
      COMMON/CEN/ETOT,MXE,NWT,NZ
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CINPUT/
     1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2,
     2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG
      COMMON/CINPTX/BSTO,RA,
     4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR),
     5 WMAT(MZMNP,MZCHF),VALUE(MZMNP)
      COMMON/PART/EIGENS(MZNRG,MZLP1),ENDS(MZNRG,MZLP1),SI(MZCHF),
     X            TRACE,NRANG1(MZLP1),NRANG2,IPRCENT
      COMMON/NRBRCT/
     X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF)
     X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF)
     X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF)
     X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF)
     X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF)
     X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF)
     X,RMAT(MZCHF,MZCHF)
      COMMON/NRBPH1/ZCOEF(MNPEXT,MZCHF),OMEGPR(MZMET,MZMSH),EPHMIN,
     1              EPHMAX,IPHOTO,NODAMP
      COMMON/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF),
     X          ZA(MZCHF,MZCHF),ZB(MZCHF,MZCHF)
      COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK)
      COMMON/GAUGE/IGAUGE
      COMMON/TYPE/NTYP1,NTYP2I,NTYP2OF,NTYP2OR,NMIN
      COMMON/RADDEC/EDEC(MZDEC),DDEC(MNPEXT,MZDEC),NDEC
C
      DIMENSION A1(MZDEC,MZDEC),B1(MZDEC,MZDEC),C1(MZDEC,MZCHF)
     X,C2(MZDEC,MZDEC)
      DIMENSION WDEC(MZDEC,MZCHF),TEMP(MZDEC),A2(MZDEC,MZCHF)
      DIMENSION TEMP1(MZMNP),TEMP2(MZMNP)
CBL   DIMENSION IPIV(MZDEC)
C
CSTGFDAMP ONLY      EQUIVALENCE (A2(1,1),C1(1,1))        !NOT STGBF0DAMP
C
      IF(NTYP2I.EQ.0.OR.NDEC.EQ.0.OR.NODAMP.GT.0)THEN
        DO J=1,NCHF
          DO I=1,NCHF
            ZR(I,J)=DCMPLX(RMAT(I,J),TZERO)
          ENDDO
        ENDDO
        IF(IPHOTO*NDEC.EQ.0)RETURN
C
        DO K=1,MNP2
          TEMP1(K)=ONE/(VALUE(K)-ETOT)         !-EZERO NO PARTITION HERE
        ENDDO
        DO J=1,NCHF
          DO I=1,MNP2
            ZCOEF(I,J)=DCMPLX(WMAT(I,J)*TEMP1(I),TZERO)
          ENDDO
        ENDDO
        RETURN
      ENDIF
C
      CC3=137.0360
      CC3=CC3*CC3*CC3
      IF(NSPN2.EQ.0)THEN
        FACT=SQRT(TWO/(THREE*(LRGL2+1)*CC3))
      ELSE
        FACT=SQRT(TWO/(THREE*(TWO*LRGL2+1)*CC3))
      ENDIF
      AZ=MAX(NZED-NELC,1)
      FACTL=FACT*AZ**2/TWO
      FACTV=FACT
      IF(IGAUGE.EQ.0)THEN
        DO J=1,NDEC
          TEMP(J)=FACTL*SQRT((ETOT-EDEC(J))**3)
        ENDDO
      ELSE
        DO J=1,NDEC
          TEMP(J)=FACTV*SQRT((ETOT-EDEC(J)))
        ENDDO
      ENDIF
C
C NRB:THE FOLLOWING MATRIX OPERATIONS ARE OPTIMIZED FOR A SCALAR MACHINE
C
      DO I=1,NCHF
        DO J=1,NDEC
          WDEC(J,I)=TZERO
        ENDDO
      ENDDO
C
      DO K=1,MNP2
        TEMP1(K)=ONE/(VALUE(K)-ETOT)           !-EZERO NO PARTITION HERE
      ENDDO
C
      DO I=1,NCHF
        DO K=1,MNP2
          TEMP2(K)=TEMP1(K)*WMAT(K,I)
        ENDDO
        DO J=1,NDEC                                          !NOT I,NCHF
          DO K=1,MNP2
            WDEC(J,I)=WDEC(J,I)+TEMP2(K)*DDEC(K,J)*TEMP(J)
          ENDDO
        ENDDO
      ENDDO
C
      DO J=1,NDEC
        DO I=1,NDEC
          A1(I,J)=TZERO
        ENDDO
      ENDDO
C
      DO J=1,NDEC
        DO K=1,MNP2
          TEMP2(K)=TEMP1(K)*DDEC(K,J)
        ENDDO
        DO I=1,NDEC
          VIJ=TEMP(I)*TEMP(J)
          DO K=1,MNP2
            A1(I,J)=A1(I,J)+DDEC(K,I)*TEMP2(K)*VIJ
          ENDDO
        ENDDO
      ENDDO
C
      DO J=1,NDEC
        DO I=1,NDEC
          B1(I,J)=TZERO
        ENDDO
          B1(J,J)=ONE
        DO K=1,NDEC
          DO I=1,J
            B1(I,J)=B1(I,J)+A1(I,K)*A1(K,J)
          ENDDO
        ENDDO
      ENDDO
C
      DO J=1,NDEC
        DO I=1,J
          B1(J,I)=B1(I,J)
        ENDDO
      ENDDO
C
CSTRTNBL
      CALL VERTS(B1,MZDEC,NDEC,WORK,IERR)
      IF (IERR.NE.0) THEN
        WRITE(6,100)
        STOP 'STOP BECAUSE NO INVERSE FOUND IN SR.ZRMAT'
      END IF
CENDNBL
CSTRTBL
CBL   CALL DSYTRF('L',NDEC,B1,MZDEC,IPIV,WORK,LWORK,INFO)
CBL   IF (INFO.NE.0) THEN
CBL      WRITE(6,602) INFO
CBL      STOP 'FAILURE IN BLAS ROUTINE DSYTRF'
CBL   ENDIF
CBL   CALL DSYTRI('L',NDEC,B1,MZDEC,IPIV,WORK,INFO)
CBL   IF (INFO.NE.0) THEN
CBL      WRITE(6,603) INFO
CBL      STOP 'FAILURE IN BLAS ROUTINE DSYTRI'
CBL   ENDIF
CENDBL
C
      DO J=1,NDEC
        DO I=J,NDEC
          B1(J,I)=B1(I,J)
        ENDDO
      ENDDO
C
      DO J=1,NCHF
        DO I=1,NDEC
          C1(I,J)=TZERO
        ENDDO
        DO K=1,NDEC
          DO I=1,NDEC
            C1(I,J)=C1(I,J)+B1(I,K)*WDEC(K,J)
          ENDDO
        ENDDO
      ENDDO
C
      DO J=1,NCHF
        DO I=1,J
          SUM=TZERO
          DO K=1,NDEC
            SUM=SUM+WDEC(K,I)*C1(K,J)
          ENDDO
          ZR(I,J)=DCMPLX(RMAT(I,J),SUM)
        ENDDO
      ENDDO
C
      DO J=1,NDEC
        DO I=1,NDEC
          C2(I,J)=TZERO
        ENDDO
        DO K=1,NDEC
          DO I=1,NDEC
            C2(I,J)=C2(I,J)+A1(I,K)*B1(K,J)
          ENDDO
        ENDDO
      ENDDO
C
      DO J=1,NCHF
        DO I=1,NDEC
          A2(I,J)=TZERO
        ENDDO
        DO K=1,NDEC
          DO I=1,NDEC
            A2(I,J)=A2(I,J)+C2(I,K)*WDEC(K,J)
          ENDDO
        ENDDO
      ENDDO
C
      DO J=1,NCHF
        DO I=1,J
          SUM=TZERO
          DO K=1,NDEC
            SUM=SUM-WDEC(K,I)*A2(K,J)
          ENDDO
          ZR(I,J)=ZR(I,J)+SUM
        ENDDO
      ENDDO
C
      DO J=1,NCHF
        DO I=1,J
          ZR(J,I)=ZR(I,J)
        ENDDO
      ENDDO
C
      IF(IPHOTO.EQ.0)RETURN
C
      DO J=1,NCHF
        DO I=1,MNP2
          ZCOEF(I,J)=DCMPLX(WMAT(I,J)*TEMP1(I),TZERO)
        ENDDO
      ENDDO
      DO J=1,NCHF
        DO K=1,NDEC
          VR=TEMP(K)*A2(K,J)
          VI=TEMP(K)*C1(K,J)
          DO I=1,MNP2
            SUM=DDEC(I,K)*TEMP1(I)
            ZCOEF(I,J)=ZCOEF(I,J)+DCMPLX(-SUM*VR,SUM*VI)
          ENDDO
        ENDDO
      ENDDO
C
      RETURN
  100 FORMAT(' SR.ZRMAT: MATRIX HAS NO INVERSE IN VERTS')
CB602 FORMAT(//10X,10('*'),' SR.ZRMAT: DSYTRF RETURNED WITH INFO =',I2)
CB603 FORMAT(//10X,10('*'),' SR.ZRMAT: DSYTRI RETURNED WITH INFO =',I2)
      END
C**********************************************************
C
      SUBROUTINE ZTHETA(R,I,ZT,ZTP,ZTD,ZTDP,ICONV,ENERGY,GAMMA)
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (ZI=(0.0,1.0))
      PARAMETER (ZERO=(0.0,0.0))
      PARAMETER (ZONE=(1.0,0.0))
      PARAMETER (ZTWO=(2.0,0.0))
C
      COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF)
     1  ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1
      COMMON/CPOT/BW(MZCHF,MZCHF),LAMP(MZCHF,MZCHF)
      COMMON/CEN/ETOT,MXE,NWT,NZ
      COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC
      COMMON/ZCTHET/ZBB(MZCHF,MZTET),ZBG(MZCHF,MZTET),MMSUM(MZCHF)
      COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW
      COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2
      COMMON/NRBZED/TZED,LPRTSW
C
      LOGICAL FLAG
C
      FNU=FKNU(I)
      ZFNU=ZONE/SQRT(ENERGY*ZONE-GAMMA*ZI/ZTWO)
      LL=LLCH(I)
      M=FNU+LL+12
      ZR=R
C
      IF(M.LE.MZTET)GOTO 10
      IF(TZED.EQ.0)THEN
      M=MZTET       !SHOULD CONVERGE AT M=LL
      GO TO 10
      ENDIF
      WRITE(6,700)I,M
      GOTO 102
C
   10 ZF1=ZONE/ZFNU
      ZF2=ZF1*ZF1
      ZX=ZTWO*ZR*ZF1
      ZY=ZONE/ZX
      FL=DBLE(LL)
      ZFL=FL
C
      ZR1=ZONE/ZR
      ZA=TZED*ZFNU*ZR1-ZF1
      ZB=TZED*LOG(R)+ZR*ZF2
      ZC=TZED*ZR1+ZF2
      ZD=-ZR1
      ZE=ZFNU**3/ZTWO
C
      ZBB(I,1)=ZFNU
      ZBB(I,2)=ZONE
      ZBG(I,1)=ZE
      ZBG(I,2)=ZF2
C
      ZYN=ZONE
      ZA1=ZFL-ZFNU*TZED
      ZA2=ZFL+ZFNU*TZED+ZONE
      ZBN=-ZTWO*ZFNU-ZONE
C
      ZBET=ZONE
      ZGAM=ZERO
      ZW0=ZC
C
      ZS=ZONE
      ZU=ZERO
      ZCX=ZERO
      ZCY=ZERO
C
C
      N=0
      FLAG=.FALSE.
      DO 20 MN=3,M
      N=N+1
      ZA1=ZA1+ZONE
      ZA2=ZA2-ZONE
      ZBN=ZBN+ZTWO
      ZCN=ZA1*ZA2
      ZDN=ZBN*TZED+ZF1*ZCN
      ZGAM=ZCN*ZGAM+ZDN*ZBET
      ZBET=ZCN*ZBET
      ZYN=ZYN*ZY
      ZU=ZU+ZBET*ZYN
      ZCY=ZCY+ZGAM*ZYN
      AN=DBLE(N)
      ZAN=ZONE/AN
      ZGAM=ZGAM*ZAN
      ZBET=ZBET*ZAN
      ZS=ZS+ZBET*ZYN
      ZCX=ZCX+ZGAM*ZYN
      ZW1=ZC*ZS*ZS+ZD*(ZS*ZCY-ZU*ZCX)
      ZBB(I,MN)=ZBET
      ZBG(I,MN)=ZGAM
      ZAC0=(ZW1-ZW0)/ZW1
      AC0=ABS(ZAC0)
      IF(ABS(ZAC0).LT.ABS(AC))THEN
        IF(FLAG)THEN
          GO TO 30
        ELSE
          FLAG=.TRUE.
        END IF
      ELSE
        FLAG=.FALSE.
      END IF
   20 ZW0=ZW1
C-NRB
      IF(ABS(ZR*ZF1).GT.150.)THEN
      ZT=ZERO
      ZTP=ZERO
      ZTD=ZERO
      ZTDP=ZERO
      ICONV=0
      RETURN
      ENDIF
C-NRB
C
C  NOT CONVERGED
      GOTO 100
C
C  SUMMATIONS CONVERGED
C  30 P=EXP(-R*F1)*R**ZFNU
C
   30 ZP=EXP(-ZR*ZF1/ZTWO)
      IF(TZED.GT.0)ZP=ZP*ZR**(ZFNU/ZTWO)
      IF(ABS(ZP).GT.1.D-100)THEN
      ZCFACT=ZONE/ZP
      ELSE
      ZCFACT=ZERO
      ENDIF
      ZBB(I,2)=ZBB(I,2)*ZCFACT
      DO 40 J=3,N+2
      ZBB(I,J)=ZBB(I,J)*ZCFACT
      ZBG(I,J)=ZBG(I,J)*ZCFACT
   40 CONTINUE
C
      ZT=ZP*ZS
      ZTP=ZP*(ZA*ZS+ZD*ZU)
      ZTD=ZP*ZE*(ZB*ZS+ZCX)
      ZTDP=ZP*ZE*((ZA*ZB+ZC)*ZS+ZB*ZD*ZU+ZA*ZCX+ZD*ZCY)
      N2=N+2
      MMSUM(I)=N2
      ICONV=0
      RETURN
C
C RELAX TEST FOR ENERGIES CASE A POSSIBLY NEGATIVE IN SC
  100 IF(FNU.GE.DBLE(LL+1))GO TO 101
C
C PROCEED BUT PRINT WARNING
      IF(ABS(AC0).GT.1.E2*AC.AND.NCHOP.GT.0)WRITE(6,650)EPS(I),LL,AC0,AC
      GO TO 30
C
C  USE SUBROUTINE SC AND SET IPERT = 0
  101 IF(TZED.GT.0)WRITE(6,610)N
      IF(TZED.EQ.0)THEN
      WRITE(6,611)
      STOP 'FAILURE FOR NEUTRAL ZTHETA - TOO CLOSE TO THRESHOLD?'
      ENDIF
  102 IF(NPERT.GT.0)THEN
      WRITE(6,750)IABS(IPERT)+2,IABS(IPERT)
      STOP 750
      ENDIF
      CALL SC(EPS(I),LLCH(I),RZERO,AC,FSA,FSPA,FCA,FCPA,IERR)
      ZSINF=SIN(3.141592654*ZFNU)
      ZCOSF=COS(3.141592654*ZFNU)
      ZT=FCA*ZSINF-FSA*ZCOSF
      ZTP=FCPA*ZSINF-FSPA*ZCOSF
      IPERT=0
      ICONV=1
      RETURN
C
  700 FORMAT(//10X,30('*')/10X,'SUBROUTINE ZTHETA'/
     1 10X,'FOR I=',I3,' REQUIRE M=',I3/
     2 10X,'WHICH IS LARGER THAN MAXIMUM VALUE OF MZTET ALLOWED BY '
     3 ,'DIMENSIONS'/10X,'USING SUBROUTINE SC WITH IPERT = 0'/10X,
     4 30('*'))
  750 FORMAT(//'SUBROUTINE ZTHETA EXECUATION HALTED BECAUSE IPERT='
     X,I3,' RESET IPERT=',I3,' OR FIX INDICATED PROBLEM')
  650 FORMAT(//10X,30('*')//10X,'SUBROUTINE ZTHETA'//
     X' SUMMATIONS NOT CONVERGED FOR E .LT. -(L+1)**(-2): E,L='
     X,F10.6,I5//' CHECK ACCURACY AC0 WITH REQUIRED AC: AC0,AC='
     X,2F10.6//10X,30('*'))
  610 FORMAT(//10X,30('*')//10X,'SUBROUTINE ZTHETA'//
     1' SUMMATIONS NOT CONVERGED WITH ',I3,' TERMS'/
     2 /10X,'USING SUBROUTINE SC WITH IPERT = 0'/10X,30('*'))
  611 FORMAT(//10X,30('*')//10X,'SUBROUTINE ZTHETA'//
     1'FAILURE FOR NEUTRAL CASE - TOO CLOSE TO THRESHOLD?'/
     2 10X,30('*'))
      END
C***************************************************************
C
      SUBROUTINE ZTHETAS(I,ZA1,ZA2,ZA3,ZB,ZG,N1,N2,ZTA,ZTDA,ZTP)
C
C  CALCULATES THETA AND THETAD FOR CHANNEL I AND COMPLEX-ZR
C     THETA = ZTA*CEXP(ZTP)
C     THETAD = ZTDA**CEXP(ZTP)
C     ZTP = FNUI*LOG(ZR) - ZR/FNUI
CNRB
C  NEUTRAL CASE ADDED
C
      IMPLICIT REAL*8 (A-H,O-Y)
      IMPLICIT COMPLEX*16 (Z)
C
      INCLUDE 'PARAM'
C
      COMMON/CTHET/BB(MZCHF,MZTET),BG(MZCHF,MZTET),MSUM(MZCHF)
      COMMON/CBLK/XLAG(30),WLAG(30),XLEG(15),WLEG(15)
      COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2
      COMMON/NRBZED/TZED,LPRTSW
C
      DIMENSION ZTP(30),ZTA(30),ZTDA(30)
C
C
      X=RTWO
      MI=MSUM(I)
      FNUI=BB(I,1)
      E=BG(I,1)
      F2=BG(I,2)
      NP = 0
      DO N=N1,N2
        NP = NP + 1
        U=XLAG(N)
        ZET=ZA1*(SQRT(ZA2+ZA3*U)-1.)
        ZMUM=-.5*ZET/(ZB*(1.+ZET*ZG))
        ZET=ZET*ZET
        ZR=ZET*X
        Z=2.*ZR/FNUI
        ZY=1./Z
        ZAS=1.
        ZS=BB(I,2)
        ZX=0.
        DO M=3,MI
          ZAS=ZAS*ZY
          ZX=ZX+BG(I,M)*ZAS
          ZS=ZS+BB(I,M)*ZAS
        ENDDO
C
        ZDLR=LOG(ZR)*TZED
        ZTP(NP)=(FNUI*ZDLR-.5*Z)
        ZTA(NP)=ZS
        ZTDA(NP)=E*((ZDLR+ZR*F2)*ZS+ZX)
      ENDDO
C
      RETURN
      END
C
C     ******************************************************************
C
      SUBROUTINE ZVERTS(V,LV,N,W,IERR)
C
C      ________________________________________________________
C     |                                                        |
C     |   INVERT A SYMMETRIC COMPLEX MATRIX WITHOUT PIVOTING   |
C     |                                                        |
C     |    INPUT:                                              |
C     |                                                        |
C     |        V     --ARRAY CONTAINING MATRIX                 |
C     |                (ONLY THE LOWER HALF NEED BE DEFINED)   |
C     |                                                        |
C     |        LV    --LEADING (ROW) DIMENSION OF ARRAY V      |
C     |                                                        |
C     |        N     --MATRIX DIMENSION                        |
C     |                                                        |
C     |        W     --WORK ARRAY WITH LENGTH AT LEAST N       |
C     |                                                        |
C     |    OUTPUT:                                             |
C     |                                                        |
C     |        V     --INVERSE (IN LOWER HALF ONLY)            |
C     |________________________________________________________|
C
      COMPLEX*16 V(*),W(*),S,T
      INTEGER G,H,I,J,K,L,M,N,LV,IERR
      REAL*8 TZERO,ONE
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
C
      IERR=0
C
C     ----------------
CNRB |*** PACK V ***|
C     ----------------
      H=LV-N
      I=0
      M=0
      L=N
      G=(N*(N+1))/2
2     IF(L.EQ.G)GO TO 4
      K=L+1
      M=M+1
      L=L+N-M
      I=I+H+M
      DO J=K,L
        V(J)=V(I+J)
      ENDDO
      GO TO 2
C
4     H = N
      K = 1
10    IF ( H .EQ. 1 ) GOTO 40
C     --------------------------
C     |*** SAVE PIVOT ENTRY ***|
C     --------------------------
      S = V(K)
      K = K + H
      G = K
      H = H - 1
      M = H
      IF ( ABS(S) .EQ. TZERO ) GOTO 50
      J = 0
20    J = J - M
      M = M - 1
      L = G + M
      T = V(G+J)/S
C     ---------------------------
C     |*** ELIMINATE BY ROWS ***|
C     ---------------------------
      DO 30 I = G,L
30         V(I) = V(I) - T*V(I+J)
      G = L + 1
      IF ( M .GT. 0 ) GOTO 20
      GOTO 10
40    IF ( ABS(V(K)) .NE. TZERO ) GOTO 60
      IERR=2
      RETURN
50    IERR=1
      RETURN
C     ------------------------------------------
C     |*** SOLVE FOR ROWS OF INVERSE MATRIX ***|
C     ------------------------------------------
60    G = N + N
      DO 150 M = 1,N
           L = ((G-M)*(M-1))/2
           H = L
           K = M
           DO 70 I = M,N
70              W(I) = TZERO
           W(M) = ONE
80         IF ( K .EQ. N ) GOTO 100
           T = W(K)/V(K+L)
           J = L
           L = L + N - K
           K = K + 1
           IF ( ABS(T) .EQ. TZERO ) GOTO 80
           DO 90 I = K,N
90              W(I) = W(I) - T*V(I+J)
           GOTO 80
C     -----------------------------------
C     |*** BACK SUBSTITUTION BY ROWS ***|
C     -----------------------------------
100        W(N) = W(N)/V(K+L)
110        IF ( K .EQ. M ) GOTO 130
           J = K
           K = K - 1
           L = L + K - N
           T = W(K)
           DO 120 I = J,N
120             T = T - W(I)*V(I+L)
           W(K) = T/V(K+L)
           GOTO 110
130        DO 140 I = M,N
140             V(I+H) = W(I)
150   CONTINUE
C     ------------------
CNRB  |*** UNPACK V ***|
C     ------------------
      H=LV-N
      I=(N-1)*H+(N*(N-1))/2
      M=N-1
      L=(N*(N+1))/2
      K=L
200   IF(I.EQ.0)RETURN
      DO J=L,K,-1
        V(I+J)=V(J)
      ENDDO
      I=I-H-M
      L=K-1
      M=M-1
      K=K-N+M
      GO TO 200
C
      END