!
! This is Russell Hulse's Atomic Data Package.
!
! 12/01 RGA -- make fortran 90 compliant
!              split AD** common blocks into separate adpak_mod module
!              converted data statements to fortran 90 initialization
!              add ad_reset() and ad_erate() subroutines
!
!==================================================================
!
SUBROUTINE ADCE
!
!     REV: 10/10/82 FOR NEW AD PACKAGE
!
!     CALCULATE CORONAL EQUILIBRIUM (INCLUDING CHARGE
!     EXCHANGE RECOMBINATION, IF PRESENT) USING THE IONIZATION,
!     RECOMBINATION, AND RADIATION RATES
!     STORED IN THE APPROPRIATE ARRAYS BY PREVIOUS CALLS
!     TO ADSET, ADERC, AND ADBCXR.
!
  use iso_c_binding, only: fp => c_double
  use adpak_mod
  save
  real(fp) :: ZIONT(100), ZRECT(100), ZRADT(100)
  real(fp) :: ZFRCMX,ZPSUM
  integer JSPC,JQ,II,ICNTR,IPASS,IQFRAC
!
!     FILL TOTAL IONIZATION, RECOMBINATION, AND RADIATION ARRAYS
!
  DO JSPC = 1, NSPC
!
     ZIONT(JSPC) = RCLION(JSPC)
     ZRECT(JSPC) = RRAREC(JSPC) + RDIREC(JSPC) + RCXREC(JSPC)
     ZRADT(JSPC) = RADRRC(JSPC) + RADDRC(JSPC) + RADCLX(JSPC)&
                                + RADBRM(JSPC) + RADBCX(JSPC)
!
  enddo
!
!
!     FIRST GUESS AT MAXIMUM SPECIES
!
  DO  JQ = 1 , NSPC
     IF(ZRECT(JQ) .GE. ZIONT(JQ))GO TO 21
  enddo
  JQ = NSPC
21 ICNTR = JQ
!W    WRITE(IOUT,23)ICNTR
23 FORMAT(1X,'ICNTR 1ST GUESS =',I3)
  IPASS = 1
!
!     INITIALIZE CEFRAC ARRAY
!
25 CEFRAC(1:NSPC) = 0._fp
  CEFRAC(ICNTR) = 1._fp
!
!     IF ICNTR IS FULLY STRIPPED WORK DOWN IN IONIZ ONLY
!
  IF(ICNTR.EQ.NSPC)GO TO 35
!
!     WORK UP FROM ICNTR SPECIES (TOWARDS HIGHER IONIZ STATES)
!
  II = ICNTR + 1
!
  DO JQ = II,NSPC
     CEFRAC(JQ) = CEFRAC(JQ-1) * ZIONT(JQ-1) / ZRECT(JQ)
     IF(CEFRAC(JQ).LT.1.E-10_fp*CEFRAC(ICNTR)) GO TO 32
  enddo
!
!     IF ICNTR IS NEUTRAL WE'RE DONE
!
32 IF(ICNTR.EQ.1)GO TO 42
!
!     WORK DOWN FROM ICNTR SPECIESccccccccccccccc/ccccccccc/ccccccccc/cc//
!
35 II = ICNTR - 1
  DO J = 1,II
     JQ = II - J + 1
     CEFRAC(JQ) = CEFRAC(JQ+1) * ZRECT(JQ+1) / ZIONT(JQ)
     IF(CEFRAC(JQ).LT.1.E-10_fp*CEFRAC(ICNTR)) exit
  enddo
!
!
42  IF(IPASS.EQ.2)GO TO 49
!
!     END OF FIRST PASS - FIND NEW MAX SPECIES AND ITERATE
!
  IPASS = 2
  ZFRCMXS = 0._fp
  DO JQ = 1, NSPC
     IF(CEFRAC(JQ).LT.ZFRCMX) cycle
     ZFRCMX = CEFRAC(JQ)
     IQFRAC = JQ
  enddo
  ICNTR = IQFRAC
  GO TO 25
!
!
!
49 ZPSUM = 0._fp
  DO JQ = 1, NSPC
     ZPSUM = ZPSUM + CEFRAC(JQ)
  enddo
!
!     NORMALIZE SPECIES FRACTIONS AND COMPUTE RADIATION RATE
!
!
  CERAD = 0._fp
!
  DO JQ = 1, NSPC
     CEFRAC(JQ) = CEFRAC(JQ) / ZPSUM
     IF(ZRADT(JQ) .LE. 0._fp) cycle
     IF(CEFRAC(JQ) .GT. 1.E-37_fp / ZRADT(JQ))&
          CERAD = CEFRAC(JQ) * ZRADT(JQ) + CERAD
!
  enddo
!
!     COMPUTE <Z>
!
  CEAVGZ = 0._fp
  DO JQ = 2,NSPC
     CEAVGZ = CEAVGZ + DBLE(JQ-1) * CEFRAC(JQ)
  enddo
!
!
  RETURN
END SUBROUTINE ADCE
SUBROUTINE ADSET(KNUCZ,IER)
!
!     rev: 12/01 RGA -- added error code as a return value
!     REV: 10/10/82 FOR NEW AD PACKAGE
!
!     SETUP BASIC ATOMIC STRUCTURE DATA FOR CHOSEN ELEMENT
!     (SHELL POPULATIONS, ENERGIES, ETC.)
!
!     return IER=0 if no errors
!
  use adpak_mod
  save
  integer ier, KNUCZ 
!
  IER=0
  NUCZ = KNUCZ
!
  CALL ADAPN
!
  IF(LADEN .NE. 0 .AND. LADEN .NE. 1) goto 10
  IF(LADEN .EQ. 0) CALL ADMAYR
  IF(LADEN .EQ. 1) CALL ADMORE
!
  IF(LADTIP .NE. 0 .AND. LADTIP .NE. 1) goto 10
  LTIPOK = 0
  IF(LADTIP .EQ. 1) CALL ADTIP(LTIPOK)
!
  CALL ADFNM
!
  RETURN
10 write(LADPOUT,'(A)') "!ADPAK::ADSET(): Argument are incorrect "&
        // "for adpak setup"
  IER=1
  RETURN
END SUBROUTINE ADSET

SUBROUTINE ADAPN
!
!     REV: 10/9/82 FOR NEW AD PACKAGE
!
!     REV: 6/15/78
!
!     INPUT : NUCZ
!     OUTPUT : NSPC, APN, AQN, NVALNC
!
!     ASSIGN THE NUMBER OF ELECTRONS PER SHELL FOR EACH
!     IONIC SPECIES.  APN(JQ,JN) = NUMBER OF ELECTRONS IN
!     SHELL JN FOR SPECIES WITH CHARGE JQ-1, WHILE AQN(JQ,JN) =
!     (2.*JN**2 - APN(JQ,JN))/(2.*JN**2) IS THE FRACTIONAL VACANCY.
!     THE SHELLS ARE FILLED IN SIMPLE CONSECUTIVE ASCENDING ORDER.
!     ALSO, THE PRINCIPAL QUANTUM NUMBER OF THE HIGHEST
!     OCCUPIED ('VALENCE') SHELL FOR EACH SPECIES IS STORED
!     IN NVALNC(JQ).
!
!     NOTE:  FOR THE FULLY IONIZED SPECIES NVALNC IS DEFAULTED TO 1.
!     ALSO: NSPC = NUCZ + 1 IS SET BY THIS ROUTINE
!
!
  use adpak_mod
  save
  integer JQ, ICOUNT, IFULL, ISHELL 
!
!     SET MAXIMUM SPECIES INDEX NSPC = NUCZ + 1
!
  NSPC = NUCZ +1
!
!
  DO JQ = 1,NSPC
     ICOUNT = NUCZ-JQ+1
!
!
     DO JN = 1,10
        IFULL = 2*JN*JN
        ISHELL = MIN0 (ICOUNT,IFULL)
        ICOUNT = ICOUNT - ISHELL
        IF(ISHELL.GT.0) NVALNC(JQ) = JN
        APN(JQ,JN) = DBLE(ISHELL)
        AQN(JQ,JN) = DBLE(IFULL - ISHELL)/DBLE(IFULL)
!
!W    WRITE(LADPOUT,900)JQ,JN,APN(JQ,JN),NVALNC(JQ)
!W  900 FORMAT(1X,'JQ =',I3,' JN =',I3,'  APN=',F4.0,'  NVALNC=',I3)
!
     enddo
!
!
  enddo
!
!
  NVALNC(NSPC) = 1
!
  RETURN
END SUBROUTINE ADAPN
SUBROUTINE ADMORE
!
!     REV: 10/10/82 FOR NEW AD PACKAGE
!
!     REV: 1 SEPTEMBER 1981
!
!     INPUT : NUCZ, NSPC, APN, NVALNC
!     OUTPUT : EN, EIN, ENM, QN
!
!     EXCITATION ENERGIES AND IONIZATION POTENTIALS ARE
!     TABULATED FOR ALL OCCUPIED SHELLS FOR EACH SPECIES.  ENERGIES
!     ARE IN KEV, JQ = SPECIES INDEX = IONIC CHARGE + 1, AND
!     JN = SHELL INDEX.
!
!     USES THE R. MORE REVISED SHIELDING CONSTANTS (AND NEW
!     CALCULATION PROCEDURE) IN LIEU OF THE ORIGINAL 'XSNQ'
!     TREATMENT BASED ON THE H. MAYER SHIELDING CONSTANTS.
!     (ORIGINAL TREATMENT, REFS. 1-4; PRESENT TREATMENT, REF. 5).
!     CERTAIN ASPECTS OF THE FORMALISM (E.G. QN AND EN ARRAYS) ARE
!     'HISTORICAL' IN NATURE.
!
!
!          SIGMA(JN,JM)   R. MORE SHIELDING CONSTANTS
!
!          QN(JQ,JN)      EFFECTIVE NUCLEAR CHARGE AT SHELL JN
!                         CONSIDERING ALL ELECTRONS IN THE GROUND STATE
!                         ION, NOW COMPUTED FROM ZSEN (RATHER THAN
!                         THAN VICE-VERSA).  THIS IS *NOT* THE
!                         SAME AS QN IN MORE'S NOTATION, WHICH
!                         IS THE SHIELDED CHARGE DUE TO INNER
!                         SHIELDING ONLY.
!
!          EN(JQ,JN)      ENERGY LEVELS FOR RECOMBINATION OF THE
!                         GROUND STATE ION.
!
!          EIN(JQ,JN)     IONIZATION POTENTIAL FOR ELECTRON IN SHELL
!                         JN CALCULATED FROM THE DIFFERENCE IN TOTAL
!                         ION ENERGIES WITH AND WITHOUT AN ELECTRON
!                         REMOVED FROM SHELL JN.
!
!          ENM(JQ,JN,JM)  EXCITATION ENERGY FROM SHELL JN UP TO SHELL
!                         JM CALULATED FROM THE DIFFERENCE IN
!                         THE TOTAL ION ENERGIES OF OF THE GROUND
!                         STATE AND EXCITED STATE ELECTRON POPULATIONS.
!
!          ZBETOT(JQ)     TOTAL BINDING ENERGY FOR EACH ION.
!
!
!     REFERENCES:
!
!     1) POST ET AL., PPPL-1352 (CORRECTED)
!     2) LOKKE AND GRASBERGER, LLL REPORT UCRL-52276 (CORRECTED)
!     3) H. MAYER, 'METHODS OF OPACITY CALCULATIONS', LOS ALAMOS
!        SCIENTIFIC  LABORATORY LA-647 (1947).
!     4) XSNQ LISTING
!     5) R. MORE 'ATOMIC PHYSICS IN INERTIAL CONFINEMENT FUSION -
!        PART I' LLL REPORT UCRL-84991 (1981) (TO APPEAR
!        IN 'APPLIED ATOMIC COLLISION PHYSICS', VOLUME II,
!        ACADEMIC PRESS)
!
!     NOTE: THERE ARE DISCREPANCIES BETWEEN THESE REFERENCES FOR A FEW
!           OF THE H. MAYER SHIELDING CONSTANT VALUES.
!
!
  use iso_c_binding, only: fp => c_double
  use adpak_mod
  save
  integer JQ,JJQ,IVALNC,IHOLE,IEXCIT,JN,JM,IIJM,IIJN
!
  real(fp) :: ZSEN(10), ZBETOT(100), ZDUM(10)
  real(fp) :: ZBEIZ,ZBEEX,ZBEREC
!
!
!     MAIN SPECIES LOOP
!
  DO JQ = 1, NSPC
     JJQ = JQ
     IVALNC = NVALNC(JQ)
!
!     COMPUTE ZBETOT AND ZSEN
!
     IHOLE = 0
     IEXCIT = 0
     CALL ADSHEN(JJQ, IHOLE, IEXCIT, ZSEN, ZBETOT(JJQ))
!
!     COMPUTE EIN, ENM, AND EN FROM DIFFERENCES IN TOTAL
!     ION ENERGIES (RATHER FROM ZSEN'S) IN ORDER TO AGREE
!     WITH RESULTS IN MORE'S FIGURE III-7.  COMPUTE
!     QN FROM THE ZSEN IN ORDER TO HAVE THE APPROPRIATE LIMITING
!     INTEGRAL CHARGES AT HIGH N SHELLS.
!
!     CLEAR ARRAYS
!
     DO JN = 1, 5
!
        EIN(JQ,JN) = 0._fp
!
        DO JM = 1, 10
           ENM(JQ,JN,JM) = 0._fp
        enddo
     enddo
!
!     SKIP FULLY STRIPPED STATE
!
     IF(JQ.EQ.NSPC) GO TO 60
!
     DO JN = 1, IVALNC
!
        IHOLE = JN
        IEXCIT = 0
        CALL ADSHEN(JJQ, IHOLE, IEXCIT, ZDUM, ZBEIZ)
        EIN(JQ,JN) = ZBETOT(JQ) - ZBEIZ
!
        IIJM = IVALNC
        IF(JN .EQ. IVALNC .OR. AQN(JQ,IVALNC) .EQ. 0._fp) IIJM = IIJM+1
!
        DO JM = IIJM, 10
           IHOLE = JN
           IEXCIT = JM
           CALL ADSHEN(JJQ, IHOLE, IEXCIT, ZDUM, ZBEEX)
           ENM(JQ,JN,JM) = ZBETOT(JQ) - ZBEEX
        enddo
     enddo
!
!     CLEAR ARRAYS
!
60   EN(JQ,1:10) = 0._fp
     QN(JQ,1:10) = 0._fp
!
!     SKIP NEUTRAL STATE
!
     IF(JQ .EQ. 1) cycle
!
!     COMPUTE EN AND QN
!
     IIJN = IVALNC
     IF(AQN(JQ,IVALNC) .EQ. 0._fp) IIJN = IVALNC+1
!
     DO JN = IIJN, 10
        IHOLE = 0
        IEXCIT = JN
        CALL ADSHEN(JJQ, IHOLE, IEXCIT, ZDUM, ZBEREC)
        EN(JQ,JN) = ZBEREC - ZBETOT(JQ)
        QN(JQ,JN) = DBLE(JN) * SQRT(ZSEN(JN)/0.0136_fp)
     enddo
  enddo
!
  RETURN
END SUBROUTINE ADMORE
!
!---------------------------------------------------------------
!
SUBROUTINE ADSHEN(KQ, KHOLE, KEXCIT, PSEN, PBETOT)
!
!     REV: 10/10/82 FOR NEW AD PACKAGE
!
!     REV: 1 SEPTEMBER 1981
!
!     INPUT: NUCZ, KQ, KHOLE, KEXCIT, APN
!     OUTPUT: PSEN(10), PBETOT
!
!     COMPUTE SHELL ENERGIES USING NEW SHIELDING CONSTANTS
!     AND METHOD DUE TO R. MORE (UCRL-84991).
!
!     NUCZ = ION NUCLEAR CHARGE
!     KQ = SPECIES INDEX = IONIC CHARGE + 1
!     KHOLE, KEXCIT = ELECTRON REMOVED FROM SHELL KHOLE AND/OR
!                     ADDED (EXCITED) TO SHELL KEXCIT BEFORE
!                     ENERGIES ARE COMPUTED (KHOLE = 0 NO ELECTRON
!                     REMOVED, KEXCIT = 0 NO ELECTRON ADDED)
!     APN(100,10) = ARRAY OF SHELL POPULATIONS
!     PSEN = OUTPUT ARRAY OF SHELL ENERGIES (KEV) (DEFINED POSITIVE)
!     PBETOT = OUTPUT TOTAL ION ENERGY (DEFINED POSITIVE)
!

  use iso_c_binding, only: fp => c_double
  use adpak_mod
  save
  integer KQ, KHOLE, KEXCIT,JN,JNM1,JNP1,JM
  real(fp) :: PBETOT
!
  real(fp) :: SIGMOR(10,10) = reshape((/&  
       .3125_fp, 0.9380_fp, 0.9840_fp, 0.9954_fp, 0.9970_fp,&
       .9970_fp, 0.9990_fp, 0.9999_fp, 0.9999_fp, 0.9999_fp,&
       .2345_fp, 0.6038_fp, 0.9040_fp, 0.9722_fp, 0.9979_fp,&
       .9880_fp, 0.9900_fp, 0.9990_fp, 0.9990_fp, 0.9999_fp,&
       .1093_fp, 0.4018_fp, 0.6800_fp, 0.9155_fp, 0.9796_fp,&
       .9820_fp, 0.9860_fp, 0.9900_fp, 0.9920_fp, 0.9999_fp,&
       .0622_fp, 0.2430_fp, 0.5150_fp, 0.7100_fp, 0.9200_fp,&
       .9600_fp, 0.9750_fp, 0.9830_fp, 0.9860_fp, 0.9900_fp,&
       .0399_fp, 0.1597_fp, 0.3527_fp, 0.5888_fp, 0.7320_fp,&
       .8300_fp, 0.9000_fp, 0.9500_fp, 0.9700_fp, 0.9800_fp,&
       .0277_fp, 0.1098_fp, 0.2455_fp, 0.4267_fp, 0.5764_fp,&
       .7248_fp, 0.8300_fp, 0.9000_fp, 0.9500_fp, 0.9700_fp,&
       .0204_fp, 0.0808_fp, 0.1811_fp, 0.3184_fp, 0.4592_fp,&
       .6098_fp, 0.7374_fp, 0.8300_fp, 0.9000_fp, 0.9500_fp,&
       .0156_fp, 0.0624_fp, 0.1392_fp, 0.2457_fp, 0.3711_fp,&
       .5062_fp, 0.6355_fp, 0.7441_fp, 0.8300_fp, 0.9000_fp,&
       .0123_fp, 0.0493_fp, 0.1102_fp, 0.1948_fp, 0.2994_fp,&
       .4222_fp, 0.5444_fp, 0.6558_fp, 0.7553_fp, 0.8300_fp,&
       .0100_fp, 0.0400_fp, 0.0900_fp, 0.1584_fp, 0.2450_fp,&
       .3492_fp, 0.4655_fp, 0.5760_fp, 0.6723_fp, 0.7612_fp/),&
       (/10,10/) )

  real(fp) :: PSEN(*)
  real(fp) :: ZAPN(10), ZQ(10), ZEN0(10)
!
!
  ZAPN(1:10) = APN(KQ,1:10)
!
!     REMOVE ELECTRON FROM SHELL KHOLE
!
  IF(KHOLE .GT. 0 .and. khole.le.10) then
     if(ZAPN(KHOLE) .GT. 0._fp) ZAPN(KHOLE) = ZAPN(KHOLE) - 1.0_fp
  endif
!
!     ADD ELECTRON TO SHELL KEXCIT
!
  IF(KEXCIT .GT. 0) ZAPN(KEXCIT) = ZAPN(KEXCIT) + 1.0_fp
!
!     COMPUTE NUCLEAR CHARGE AS SHIELDED BY INNER ELECTRONS ONLY
!
  DO JN = 1, 10
!
     ZQ(JN) = DBLE(NUCZ) - 0.5_fp * SIGMOR(JN,JN) * ZAPN(JN)
!
     IF(JN .EQ. 1) cycle
     JNM1 = JN - 1
!
     DO JM = 1, JNM1
        ZQ(JN) = ZQ(JN) - SIGMOR(JN,JM) * ZAPN(JM)
     enddo
  enddo
!
!     COMPUTE POTENTIAL DUE TO OUTER ELECTRONS
!
  DO JN = 1, 10
     ZEN0(JN) = 0.0136_fp * SIGMOR(JN,JN) * ZAPN(JN)&
          * ZQ(JN) / (DBLE(JN**2))
!
     IF(JN .EQ. 10) cycle
     JNP1 = JN + 1
!
     DO JM = JNP1, 10
        ZEN0(JN) = ZEN0(JN) + 0.0272_fp * ZAPN(JM) * SIGMOR(JM,JN)&
             * ZQ(JM) / (DBLE(JM**2))
     enddo
  enddo
!
!
!     COMPUTE FINAL SHELL ENERGIES AND TOTAL ION BINDING ENERGY,
!     BOTH DEFINED POSITIVE.
!
  PBETOT = 0._fp
!
  DO JN = 1, 10
     PSEN(JN) = 0.0136_fp * ((ZQ(JN)/DBLE(JN))**2) - ZEN0(JN)
     PBETOT = PBETOT + 0.0136_fp * ZAPN(JN) * ((ZQ(JN)/DBLE(JN))**2) 
  enddo
  RETURN
END SUBROUTINE ADSHEN
SUBROUTINE ADMAYR
!
!     REV: 10/10/82 FOR NEW AD PACKAGE
!
!     REV: 6/15/78
!
!     INPUT : NUCZ, NSPC, APN
!     OUTPUT : SIGMA, QN, EN, EIN, ENM
!
!     COMPUTES ENERGY LEVELS FOR THE GROUND STATE IONIC SPECIES
!     AND FOR SPECIES WITH SINGLE INNER ELECTRON VACANCIES.
!     EXCITATION ENERGIES AND IONIZATION POTENTIALS ARE THUS
!     TABULATED FOR ALL OCCUPIED SHELLS FOR EACH SPECIES.  ENERGIES
!     ARE IN KEV, JQ = SPECIES INDEX = IONIC CHARGE + 1, AND
!     JN = SHELL INDEX.
!
!     FOR EACH CONFIGURATION AND SHELL OF INTEREST, THE EFFECTIVE
!     NUCLEAR CHARGE IS CALCULATED USING THE H. MAYER SHIELDING
!     CONSTANTS.  THE ENERGY LEVELS ARE THEN FOUND USING THIS EFFECTIVE
!     CHARGE IN THE PAULI APPROXIMATION TO THE DIRAC ENERGY LEVEL
!     FORMULA.  THE SHELL ENERGY IS TAKEN AS THE MEAN OF THE LOWEST
!     AND HIGHEST SUBSHELL ENERGIES FOR THAT N.
!
!
!          SIGMA(JN,JM)   H. MAYER SHIELDING CONSTANTS
!
!          QN(JQ,JN)      EFFECTIVE NUCLEAR CHARGE AT SHELL JN
!                         CONSIDERING ALL ELECTRONS IN THE GROUND STATE ION.
!
!          EN(JQ,JN)      ENERGY LEVELS FOR GROUND STATE ION
!                         (FORMERLY EQN(JQ,JN) IN PREVIOUS VERSIONS)
!
!          EIN(JQ,JN)     IONIZATION POTENTIAL FOR ELECTRON IN SHELL JN;
!                         USES SHIELDED CHARGE CALCULATED WITH ONE
!                         ELECTRON REMOVED FROM SHELL JN.
!
!          ENM(JQ,JN,JM)  EXCITATION ENERGY FROM SHELL JN UP TO SHELL JM;
!                         THE DIFFERENCE BETWEEN THE JN AND JM ENERGY LEVELS
!                         CALCULATED WITH THE JN SHELL ELECTRON REMOVED.
!
!
!
!     REFERENCES:
!
!     1) POST ET AL., PPPL-1352 (CORRECTED)
!     2) LOKKE AND GRASBERGER, LLL REPORT UCRL-52276 (CORRECTED)
!     3) H. MAYER, 'METHODS OF OPACITY CALCULATIONS', LOS ALAMOS
!        SCIENTIFIC  LABORATORY LA-647 (1947).
!     4) XSNQ LISTING
!
!     NOTE: THERE ARE DISCREPANCIES BETWEEN THESE REFERENCES FOR A FEW
!           SHIELDING CONSTANT VALUES.
!
!
!C    DIMENSION ZSIGMA(10,10)       !NOT USED.   M.DIESSO  16 NOV 1994
!
  use iso_c_binding, only: fp => c_double
  use adpak_mod
  save
!
  real(fp) :: SIGMAY(10,10) = reshape( (/&
       .625_fp, .938_fp, .981_fp,.987_fp, .994_fp, .997_fp,.999_fp,&
       1.00_fp, 1.00_fp, 1.00_fp,.235_fp, .690_fp, .893_fp,.940_fp,&
       .970_fp, .984_fp, .990_fp,.993_fp, .995_fp, 1.00_fp,.109_fp,&
       .397_fp, .702_fp, .850_fp,.920_fp, .955_fp, .970_fp,.980_fp,&
       .990_fp, 1.00_fp,.0617_fp,.235_fp, .478_fp, .705_fp,.830_fp,&
       .900_fp, .950_fp, .970_fp,.980_fp, .990_fp,.0398_fp,.155_fp,&
       .331_fp, .531_fp, .720_fp,.830_fp, .900_fp, .950_fp,.970_fp,&
       .980_fp,.0277_fp, .109_fp,.239_fp, .400_fp, .580_fp,.735_fp,&
       .830_fp, .900_fp, .950_fp,.970_fp,.0204_fp,.0808_fp,.178_fp,&
       .310_fp, .459_fp, .610_fp,.745_fp, .830_fp, .900_fp,.950_fp,& 
       .0156_fp,.0625_fp, .138_fp,.243_fp, .371_fp, .506_fp,.635_fp,&
       .750_fp, .830_fp, .900_fp,.0123_fp,.0494_fp,.111_fp,.194_fp,&
       .299_fp, .431_fp, .544_fp,.656_fp,  .760_fp,.830_fp,.010_fp,&
       .040_fp, .090_fp, .158_fp,.245_fp, .353_fp ,.460_fp,.576_fp,&
       .670_fp,  .765_fp/),(/10,10/) )
  integer JQ,IVALNC,JN,IN,IIJM,JM,IM
  real(fp) :: ZJN,ZQN,ZQNN,ZQNM
  real(fp) adpali
!
!
!
!
!     START MAIN SPECIES LOOP
!
!
  DO JQ = 1 , NSPC
!
     IVALNC = NVALNC(JQ)
!
!
!     COMPUTE QN AND EN
!
     DO JN = 1 , 10
        ZJN = DBLE(JN)
!
        ZQN = DBLE(NUCZ)
!
        DO JM = 1 , IVALNC
           ZQN = ZQN - SIGMAY(JN,JM) * APN(JQ,JM)
        enddo
!
        ZQN = ZQN + APN(JQ,JN) * SIGMAY(JN,JN) / (2._fp * ZJN**2)
!
        QN(JQ,JN) = ZQN
        IN = JN
        EN(JQ,JN) = ADPALI(ZQN,IN)
     enddo
!
!
!     CLEAR ARRAYS THEN COMPUTE EIN AND ENM
!
!
     EIN(JQ,1:5) = 0._fp
     ENM(JQ,1:5,1:10) = 0._fp
!
!     SKIP IONIZATION AND EXCITATION ENERGIES FOR FULLY STRIPPED ION
!
     IF(JQ .EQ. NSPC) cycle
!
!
     DO JN = 1 , IVALNC
        ZJN = DBLE(JN)
!
!     COMPUTE ZQNN = EFFECTIVE CHARGE AT SHELL JN WITH ONE ELECTRON
!     REMOVED FROM SHELL JN.
!
        ZQNN = QN(JQ,JN) + SIGMAY(JN,JN) * (1._fp - 1._fp/(2._fp*ZJN**2))
!
!     EIN(JQ,JN) = IONIZATION POTENTIAL FOR SHELL JN
!
        IN = JN
        EIN(JQ,JN) = ADPALI(ZQNN,IN)
!
!     COMPUTE ENM(JQ,JN,JM) FROM ZQNM, EFFECTIVE CHARGE AT SHELL
!     JM WITH ONE ELECTRON REMOVED FROM SHELL JN.
!
        IIJM = IVALNC
        IF(JN .EQ. IVALNC .OR.&
             AQN(JQ,IVALNC) .EQ. 0._fp) IIJM = IVALNC + 1
!
        DO JM = IIJM , 10
!
           ZQNM = QN(JQ,JM) + SIGMAY(JM,JN)
!
           IM = JM
           ENM(JQ,JN,JM) = EIN(JQ,JN) - ADPALI(ZQNM,IM)
!
        enddo
     enddo
!
!
!
!
  enddo
!
!
  RETURN
END SUBROUTINE ADMAYR
!
!
!------------------------------------------------------------------
!
!
real(fp) FUNCTION ADPALI(PQ,KN)
!
!     REV: 10/10/82 FOR NEW AD PACKAGE
!
!     REV: 6/15/78
!
!     EVALUATE THE PAULI APPROXIMATION TO THE
!     THE DIRAC ENERGY LEVEL EQUATION, TAKING THE MEAN OF THE
!     LOWEST AND HIGHEST SUBSHELL ENERGIES TO BE THE SHELL ENERGY.
!     ADPALI(PQ,KN) IS IN KEV,  PQ IS THE EFFECTIVE NUCLEAR
!     CHARGE (IN UNITS OF ELECTRONIC CHARGE) AND KN IS THE PRINCIPAL
!     QUANTUM NUMBER.
!
!
  use iso_c_binding, only: fp => c_double
  implicit none
  save
  real(fp) :: PQ,ZKN,ZALPHA
  integer KN
  ZALPHA = .007298_fp
!
!
  ZKN = DBLE(KN)
!
  ADPALI = .0136_fp * ( (PQ / ZKN)**2 ) *&
       (1._fp + ((ZALPHA*PQ)**2) * (0.5_fp - 1._fp/&
       (4._fp*ZKN))/ZKN)
!
!
  RETURN
END FUNCTION ADPALI
SUBROUTINE ADTIP(KTIPOK)
!
!     SUBSTITUTE TABULATED IONIZATION POTENTIALS FOR THOSE
!     CALCULATED BY SHIELDING CONSTANTS IN SETENM.  NOTE THAT THE
!     'NUMBER OF EQUIVALENT ELECTRONS' IS NOT CORRECTLY RE-DEFINED
!     TO ACCOMPANY THIS PROCEDURE, BUT THE APPROXIMATION IS STILL
!     AN IMPROVEMENT FOR NEAR-NEUTRAL SPECIES.
!
  use iso_c_binding, only: fp => c_double
  use adpak_mod
  save
!
  real(fp) :: ZTIP(100)
  integer JSPC,KTIPOK,IVALNC,JSPCP1
!
  ZTIP(1:100) = 0._fp
!
  IF(NUCZ .NE. 2) GO TO 3
!
!     HELIUM
!
  ZTIP(1) = 24.58E-3_fp
  ZTIP(2) = 54.4E-3_fp
!
  GO TO 100
3 IF(NUCZ .NE. 3) GO TO 4
!
!     LITHIUM
!
  ZTIP(1) = 5.4E-3_fp
  ZTIP(2) = 75.6E-3_fp
  ZTIP(3) = 122.4E-3_fp
!
  GO TO 100
!
4 IF(NUCZ .NE. 4) GO TO 5
!
!     BERYLLIUM
!
  ZTIP(1) = 9.32E-3_fp
  ZTIP(2) = 18.2E-3_fp
  ZTIP(3) = 153.9E-3_fp
  ZTIP(4) = 217.6E-3_fp
!
  GO TO 100
!
5 IF(NUCZ .NE. 5) GO TO 6
!
!     BORON
!
  ZTIP(1) = 8.296E-3_fp
  ZTIP(2) = 25.15E-3_fp
  ZTIP(3) = 37.9E-3_fp
  ZTIP(4) = 259.3E-3_fp
  ZTIP(5) = 340.0E-3_fp
!
  GO TO 100
!
6 IF(NUCZ .NE. 6) GO TO 8
!
!     CARBON
!
  ZTIP(1) = 11.3E-3_fp
  ZTIP(2) = 24.4E-3_fp
  ZTIP(3) = 47.9E-3_fp
  ZTIP(4) = 64.5E-3_fp
  ZTIP(5) = 0.392_fp
  ZTIP(6) = 0.490_fp
!
  GO TO 100
8 IF(NUCZ .NE. 8) GO TO 10
!
!     OXYGEN
!
  ZTIP(1) = 13.6E-3_fp
  ZTIP(2) = 35.1E-3_fp
  ZTIP(3) = 54.9E-3_fp
  ZTIP(4) = 77.4E-3_fp
  ZTIP(5) = 0.114_fp
  ZTIP(6) = 0.138_fp
  ZTIP(7) = 0.739_fp
  ZTIP(8) = 0.871_fp
!
  GO TO 100
10 IF(NUCZ .NE. 10) GO TO 13
!
!     NEON
!
  ZTIP(1) = 21.6E-3_fp
  ZTIP(2) = 41.0E-3_fp
  ZTIP(3) = 63.5E-3_fp
  ZTIP(4) = 97.1E-3_fp
  ZTIP(5) = 0.126_fp
  ZTIP(6) = 0.158_fp
  ZTIP(7) = 0.207_fp
  ZTIP(8) = 0.239_fp
  ZTIP(9) = 1.196_fp
  ZTIP(10) = 1.362_fp
!
  GO TO 100
13 IF(NUCZ .NE. 13) GO TO 18
!
!     ALUMINUM
!
  ZTIP(1) = 5.99E-3_fp
  ZTIP(2) = 18.8E-3_fp
  ZTIP(3) = 28.4E-3_fp
  ZTIP(4) = 0.120_fp
  ZTIP(5) = 0.154_fp
  ZTIP(6) = 0.190_fp
  ZTIP(7) = 0.241_fp
  ZTIP(8) = 0.285_fp
  ZTIP(9) = 0.330_fp
  ZTIP(10) = 0.399_fp
  ZTIP(11) = 0.442_fp
  ZTIP(12) = 2.086_fp
  ZTIP(13) = 2.304_fp
!
  GO TO 100
18 IF(NUCZ .NE. 18) GO TO 22
!
!     ARGON
!
  ZTIP(1) = 15.8E-3_fp
  ZTIP(2) = 27.6E-3_fp
  ZTIP(3) = 40.7E-3_fp
  ZTIP(4) = 59.8E-3_fp
  ZTIP(5) = 75.0E-3_fp
  ZTIP(6) = 91.0E-3_fp
  ZTIP(7) = 0.124_fp
  ZTIP(8) = 0.143_fp
  ZTIP(9) = 0.422_fp
  ZTIP(10) = 0.479_fp
  ZTIP(11) = 0.539_fp
  ZTIP(12) = 0.618_fp
  ZTIP(13) = 0.686_fp
  ZTIP(14) = 0.756_fp
  ZTIP(15) = 0.855_fp
  ZTIP(16) = 0.918_fp
  ZTIP(17) = 4.121_fp
  ZTIP(18) = 4.426_fp
!
  GO TO 100
22 IF(NUCZ .NE. 22) GO TO 26
!
!     TITANIUM
!
  ZTIP(1) = 6.82E-3_fp
  ZTIP(2) = 13.6E-3_fp
  ZTIP(3) = 27.5E-3_fp
  ZTIP(4) = 43.3E-3_fp
  ZTIP(5) = 99.2E-3_fp
  ZTIP(6) = 0.119_fp
  ZTIP(7) = 0.141_fp
  ZTIP(8) = 0.169_fp
  ZTIP(9) = 0.193_fp
  ZTIP(10) = 0.216_fp
  ZTIP(11) = 0.265_fp
  ZTIP(12) = 0.292_fp
  ZTIP(13) = 0.787_fp
  ZTIP(14) = 0.861_fp
  ZTIP(15) = 0.940_fp
  ZTIP(16) = 1.042_fp
  ZTIP(17) = 1.131_fp
  ZTIP(18) = 1.220_fp
  ZTIP(19) = 1.342_fp
  ZTIP(20) = 1.425_fp
  ZTIP(21) = 6.249_fp
  ZTIP(22) = 6.626_fp
!
  GO TO 100
26 IF(NUCZ .NE. 26) GO TO 100
!
!     IRON
!
  ZTIP(1) = 7.87E-3_fp
  ZTIP(2) = 16.2E-3_fp
  ZTIP(3) = 30.7E-3_fp
  ZTIP(4) = 54.8E-3_fp
  ZTIP(5) = 75.0E-3_fp
  ZTIP(6) = 99.0E-3_fp
  ZTIP(7) = 0.125_fp
  ZTIP(8) = 0.151_fp
  ZTIP(9) = 0.235_fp
  ZTIP(10) = 0.262_fp
  ZTIP(11) = 0.290_fp
  ZTIP(12) = 0.331_fp
  ZTIP(13) = 0.361_fp
  ZTIP(14) = 0.392_fp
  ZTIP(15) = 0.457_fp
  ZTIP(16) = 0.490_fp
  ZTIP(17) = 1.265_fp
  ZTIP(18) = 1.358_fp
  ZTIP(19) = 1.456_fp
  ZTIP(20) = 1.582_fp
  ZTIP(21) = 1.689_fp
  ZTIP(22) = 1.799_fp
  ZTIP(23) = 1.950_fp
  ZTIP(24) = 2.045_fp
  ZTIP(25) = 8.828_fp
  ZTIP(26) = 9.278_fp
!
!     END OF CURRENT TABULATION; RETURN IF SELECTED
!     ELEMENT NOT PRESENT AND SET FLAG.
!
100 KTIPOK = 0
  IF(ZTIP(1) .EQ. 0._fp) RETURN
!
  KTIPOK = 1
!
  DO JSPC = 1, NUCZ
     IVALNC = NVALNC(JSPC)
     JSPCP1 = JSPC + 1
!
     EIN(JSPC,IVALNC) = ZTIP(JSPC)
     EN(JSPCP1,IVALNC) = ZTIP(JSPC)
  enddo
!
  RETURN
END SUBROUTINE ADTIP
SUBROUTINE ADFNM
!
!     REV: 10/10/82 FOR NEW AD PACKAGE
!
!     REV: 8/10/79  CORRECT ZEPSNN(59) (4F13) VALUE FROM 3.43E-3
!                   TO 3.43E-2 (ERROR IN POST ET AL.)
!     REV: 6/15/78
!
!     INPUT : NUCZ, APN, AQN, NVALNC, ENM
!     OUTPUT : FNM, FNN, ENN
!
!     CALCULATES ABSORPTION OSCILLATOR STRENGTHS FOR TRANSITIONS
!     FROM SHELL IN TO SHELL IM FOR EACH SPECIES JQ AND STORES THEM
!     IN THE ARRAY FNM(JQ,IN,IM).  F(N,M) = (HYDROGENIC VALUE,
!     TABULATED FOR LOW N,M CALCULATED OTHERWISE) X (CORRECTION
!     FACTOR(S)) X (ELECTRON POPULATION OF SHELL IN) X (VACANY
!     FRACTION OF SHELL IM).
!
!     FOR N - N (E.G. DELTA N EQUAL ZERO) TRANSITIONS WE HAVE
!     F(N,N) = ANN + BNN/ZNUC, WHICH REPRESENTS A FIT TO THE
!     'EQUIVALENT' SINGLE TRANSITION USED TO MODEL ALL THE PHYSICAL
!     N - N TRANSITIONS.  ALSO COMPUTED IS E(N,N), THE 'EQUIVALENT'
!     ENERGY, E(N,N) = EPSILONNN * (ZCHG+1) ** ALPHANN.  THE ZANN, ETC.
!     ARRAYS ARE INDEXED BY THE TOTAL NUMBER OF BOUND ELECTRONS
!     IN THEIR ELECTRONIC CONFIGURATIONS (SEE REFERENCE (1)).
!
!     NOTE THAT HERE, AS IN OTHER ROUTINES, THE FILLING OF SHELLS
!     IN SIMPLE ASCENDING ORDER IS ASSUMED BOTH EXPLICITLY
!     (E.G., IN THE APN ARRAY CONTENTS) AS WELL AS IMPLICITY (THROUGH
!     THE USE OF NVALNC, ETC.).  ALSO, THE ANN, BNN, ETC.
!     COEFFICIENTS ARE DEFINED SPECIFICALLY FOR SUCH STATES.
!
!
!     REFERENCES:
!     1) POST ET AL., PPPL-1352 (WITH CORRECTIONS)
!     2) GRASBERGER, XSNQ - TOKAMAK MEMORANDUM #4, 7/29/76
!     3) GRASBERGER, XSNQ - TOKAMAK MEMORANDUM #10, 1/5/77
!     4) LOKKE & GRASBERGER, 'XSNQ-U A NON-LTE EMISSION AND
!        ABSORPTION COEFFICIENT SUBROUTINE', LLL REPORT UCRL-52276
!     5) MERTS ET AL., 'THE CALCULATED POWER OUTPUT FROM
!        A THIN IRON-SEEDED PLASMA', LOS ALAMOS REPORT LA-6220-MS
!     6) XSNQ FORTRAN LISTING
!
!
!
  use iso_c_binding, only: fp => c_double
  use adpak_mod
  save
!
!
!
  integer i
  real(fp) :: ZANN(60) = (/ 0._fp, 0._fp,&
       -.02_fp, -.01_fp, -.04_fp,  .04_fp, -.01_fp, -.01_fp,  .01_fp,&
       0._fp,  .01_fp,   .1_fp,  .25_fp,  .17_fp,  .08_fp, -.02_fp,&
       -.14_fp, -.27_fp, -.29_fp,  -.3_fp,  -.3_fp, -.29_fp, -.27_fp,&
       -.24_fp,  -.2_fp, -.14_fp, -.08_fp,   0._fp,  .97_fp, 1.96_fp,&
       1.92_fp, 1.89_fp, 1.86_fp, 1.83_fp, 1.78_fp, 1.73_fp, 1.41_fp,&
       1.05_fp, .674_fp, .261_fp,-.167_fp,-.637_fp,-1.14_fp,-1.67_fp,&
       -2.26_fp,-2.88_fp, -2.9_fp,-2.83_fp,-2.72_fp,-2.61_fp,-2.45_fp,&
       -2.27_fp,-2.05_fp,-1.81_fp,-1.55_fp,-1.25_fp, -.94_fp, -.63_fp,&
       -.31_fp, 0._fp /)
!
!
  real(fp) :: ZBNN(60) =  (/ 0._fp, 0._fp,&
       2._fp, 4.33_fp, 4.68_fp,  3.6_fp, 2.85_fp,  2.4_fp,&
       1.3_fp,   0._fp, 10.5_fp,  20._fp, 16.4_fp, 24.7_fp,&
       34.1_fp, 44.8_fp, 56.8_fp, 70.3_fp, 68.6_fp, 65.8_fp,&
       61.9_fp, 56.9_fp, 50.7_fp, 45.5_fp, 34.4_fp, 24.2_fp,&
       12.8_fp,   0._fp,-25.8_fp,-53.1_fp,-28.1_fp,-2.97_fp,&
       23._fp, 50.3_fp, 79.1_fp,109.2_fp,141.7_fp, 176._fp,&
       213.9_fp,256.6_fp,299.6_fp,348.2_fp,400.5_fp,456.6_fp,&
       518.1_fp,584.0_fp,571.9_fp,550.7_fp,524.9_fp,496.8_fp,&
       463.4_fp, 427._fp,385.3_fp,339.8_fp,291.3_fp,237.4_fp,&
       181.3_fp,122.9_fp, 62.2_fp,   0._fp /)
!
!
  real(fp) :: ZEPSNN(60) = (/ 0._fp, 0._fp,&
       2.04E-3_fp, 4.49E-3_fp,  6.8E-3_fp, 8.16E-3_fp, 6.80E-3_fp,&
       1.06E-2_fp, 1.31E-2_fp,      0._fp,  2.3E-3_fp, 3.88E-3_fp,&
       5.71E-3_fp, 5.44E-3_fp, 8.16E-3_fp,  6.8E-3_fp,  8.3E-3_fp,&
       4.32E-3_fp, 5.11E-3_fp, 6.04E-3_fp, 7.08E-3_fp,&
       8.12E-3_fp, 9.69E-3_fp, 1.13E-2_fp, 1.37E-2_fp,  1.49E-2_fp,&
       1.71E-2_fp,      0._fp, 1.52E-5_fp, 1.93E-5_fp,&
       5.62E-5_fp, 1.20E-4_fp, 2.13E-4_fp, 3.34E-4_fp,  4.66E-4_fp,&
       6.66E-4_fp, 9.10E-4_fp, 1.25E-3_fp, 1.69E-3_fp,  1.98E-3_fp,&
       3.03E-3_fp, 3.92E-3_fp, 5.19E-3_fp, 6.40E-3_fp,  8.05E-3_fp,&
       9.80E-3_fp, 1.08E-2_fp, 1.19E-2_fp, 1.32E-2_fp,  1.47E-2_fp,&
       1.59E-2_fp, 1.81E-2_fp, 1.92E-2_fp, 2.10E-2_fp,  2.33E-2_fp,&
       2.57E-2_fp, 2.82E-2_fp, 3.10E-2_fp, 3.43E-2_fp,        0._fp /)
!
!
  real(fp) :: ZALPNN(60) = (/ 1.0_fp, 1.0_fp,&
       1.0_fp, .93_fp, .86_fp, .80_fp, .87_fp, .77_fp, .77_fp, 1.0_fp,&
       .99_fp, .90_fp, .83_fp, .87_fp, .77_fp, .82_fp, .79_fp,1.06_fp,&
       1.03_fp,  1._fp, .97_fp, .94_fp, .91_fp, .88_fp, .85_fp,&
       .83_fp, .80_fp, 1.0_fp,2.46_fp, 2.4_fp,2.14_fp,1.96_fp,&
       1.83_fp,1.72_fp,1.64_fp,1.57_fp,1.49_fp,1.41_fp,1.34_fp,&
       1.30_fp,1.19_fp,1.13_fp,1.06_fp,1.01_fp, .95_fp, .91_fp,&
       .89_fp, .87_fp, .85_fp, .83_fp, .82_fp, .80_fp, .78_fp, .76_fp,&
       .74_fp, .72_fp, .70_fp, .68_fp, .66_fp, 1.0_fp/)
!
!
  real(fp) :: ZY0(10) = (/ 1.0_fp, .511_fp, .400_fp,(.230_fp, i=1,7)/)
!
  real(fp) :: ZY1(10) = (/ 0._fp,.116_fp,.0228_fp,(.00844_fp, i=1,7)/)
!
  real(fp) :: ZY2(10) = (/ 0._fp,-.00689_fp,.000596_fp,&
       (.000488_fp, i=1,7) /)

  integer JQ,JN,JM,IBOUND,IVALNC,IIJM,INDEX
  real(fp) :: ZNUC,ZCHG,ZN,ZM,ZRATIO,ZNCHG,ZEHYDR,ZYNPN
!

!
!     *********************************************************
!
!
!     ZERO OSCILLATOR STRENGTH ARRAYS AND ENN ARRAY
!
  FNN(1:100) = 0._fp
  ENN(1:100) = 0._fp
  FNM(1:100,1:5,1:10) = 0._fp
!
  ZNUC = DBLE ( NUCZ )
!
!
!     ******************************************************
!     ***** LOOP FOR ALL SPECIES EXCEPT FULLY STRIPPED *****
!     ******************************************************
!
!
  DO JQ = 1 , NUCZ
!
     ZCHG = DBLE(JQ-1)
     IBOUND = NUCZ - JQ + 1
     IVALNC = NVALNC(JQ)
!
!
!     ********** CALCULATE F(N,M) ( M > N ) **********
!
!
!     BEGIN BY EVALUTING HYDROGENIC F(N,M) EQUATION, WITH
!     EXPLICIT VALUES SUBSTITUTED FOR N < 5, M <= 5.
!
!
     DO JN = 1 , IVALNC
        IIJM = MAX0 ( JN + 1 , IVALNC )
        ZN = DBLE(JN)
!
        DO JM = IIJM , 10
           ZM = DBLE(JM)
           FNM(JQ,JN,JM) = 1.96_fp * ZN * ( ( ZM/(ZM*ZM - ZN*ZN) )**3 )
        enddo
     enddo
!
!     SUBSTITUTE TABLED VALUES FOR LOW N , M AS PER REF #4
!
     FNM(JQ,1,2) = 0.4161_fp
     FNM(JQ,1,3) = 0.0792_fp
     FNM(JQ,1,4) = 0.0290_fp
     FNM(JQ,1,5) = 0.0139_fp
     FNM(JQ,2,3) = 0.6370_fp
     FNM(JQ,2,4) = 0.1190_fp
     FNM(JQ,2,5) = 0.0443_fp
     FNM(JQ,3,4) = 0.8408_fp
     FNM(JQ,3,5) = 0.1499_fp
     FNM(JQ,4,5) = 1.037_fp
!
!     MODIFY NONZERO F(N,N+1) VALUES FOR N > 1 AS PER REF #3
!
     DO J = 1 , 2
        JN = IVALNC + J - 2
        IF(JN .LE. 1) cycle
        JM = JN + 1
        IF(AQN(JQ,JM) .EQ. 0._fp) cycle
!
        ZNCHG = ZCHG + APN(JQ,JM)
        ZEHYDR = .0136_fp * ((ZNCHG+1._fp)**2) *&
             ( 1._fp/DBLE(JN)**2 - 1._fp/DBLE(JM)**2 )
        ZRATIO = ZEHYDR / ENM(JQ,JN,JM)
        IF(ZRATIO .GT. 1.0_fp) ZRATIO = 1.0_fp
        ZYNPN = ZY0(JN) + ZY1(JN) * APN(JQ,JN) + ZY2(JN) * APN(JQ,JN)**2
!
        FNM(JQ,JN,JM) = FNM(JQ,JN,JM) * ZRATIO * ZYNPN
!
     enddo
!
!
!     MULTIPLY BY ELECTRON POPULATION OF SHELL N AND FRACTIONAL
!     VACANCY OF SHELL M
!
!
     DO JN = 1 , 5
        DO JM = 1 , 10
           FNM(JQ,JN,JM) = APN(JQ,JN) * AQN(JQ,JM) * FNM(JQ,JN,JM)
        enddo
     enddo
!
!
!
!     ***** CALCULATE N - N 'EFFECTIVE' OSCILLATOR STRENGTHS *****
!                   ***** AND TRANSITION ENERGIES *****
!
!
!
     INDEX = IBOUND
!     IF MORE THAN 60 BOUND ELECTRONS USE CONSTANTS FOR ION WITH
!     32 FEWER ELECTRONS
     IF(INDEX.GT.60)INDEX = INDEX - 32
     IF(INDEX.GT.60)INDEX = INDEX - 32
!
     FNN(JQ) = ZANN(INDEX) + ZBNN(INDEX) / ZNUC
!
     ENN(JQ) = ZEPSNN(INDEX) * (ZCHG + 1._fp)**ZALPNN(INDEX)
!
!
!
!
!     CHECK TO INSURE ALL F VALUES ARE POSITIVE
!
     IF(FNN(JQ) .GE. 0._fp) GO TO 40
     FNN(JQ) = 0._fp
     write(LADPOUT,'(A)') '! ADPAK::ADFNM()'
     write(LADPOUT,'(A,I2)') '  nuclear Z = ', nucz
     WRITE(LADPOUT,900) JQ , IVALNC , IVALNC
900  FORMAT(1X,26H***** NEGATIVE F VALUE AT ,3I4,6H *****)
40   DO JN = 1 , 5
        DO JM = 1 , 10
           IF(FNM(JQ,JN,JM) .GE. 0._fp) cycle
           FNM(JQ,JN,JM) = 0._fp
           write(LADPOUT,'(A)') '! ADPAK::ADFNM()'
           write(LADPOUT,'(A,I2)') '  nuclear Z = ', nucz
           WRITE(LADPOUT,900) JQ , JN , JM
        enddo
     enddo
!
!     DIAGNOSTIC WRITE STATMENTS TO DISPLAY F VALUES
!
!W    WRITE(LADPOUT,901)JQ,FNN(JQ),ENN(JQ)
!W  901 FORMAT(/1X,'SETFNM: JQ =',I3,'  FNN =',1PE9.2,'  ENN =',E9.2)
!W    WRITE(LADPOUT,902)( JN,(FNM(JQ,JN,JM),JM=1,10),JN=1,5)
!W  902 FORMAT(1X,'JN =',I2,10F6.1)
!
!
!     *************** END OF JQ SPECIES LOOP ***************
!
!
  enddo
!
  RETURN
END SUBROUTINE ADFNM
SUBROUTINE ADERC(PTE,PNE)
  use iso_c_binding, only: fp => c_double
  implicit none
  real(fp) :: pte,pne
!
!     CALL ELECTRON RATE COEFFICIENT ROUTINES
!
  CALL ADECI(PTE,PNE)  ! fill RCLION, CIZLOS
  CALL ADDREC(PTE,PNE) ! fill RDIREC, RADDRC
  CALL ADRREC(PTE,PNE) ! fill RRAREC, RADRRC
  CALL ADECEX(PTE,PNE) ! fill RADCLX
  CALL ADBREM(PTE,PNE) ! fill RADBRM
!
  RETURN
END SUBROUTINE ADERC
SUBROUTINE ADECI(PTE, PNE)
!
!     CALCULATE THE ELECTRON COLLISIONAL IONIZATION RATE USING
!     THE FORMULAS SELECTED BY THE LECI SWITCH.  LECIOK RETURNS
!     THE RATE FORMULAS ACTUALLY USED, WHICH MAY DIFFER FROM
!     LECI IF LECI WAS SET INAPPROPRIATELY FOR THE GIVEN ELEMENT.
!
  use iso_c_binding, only: fp => c_double
  use adpak_mod
  save
  real(fp) :: pte,pne
  integer ILMAX,IFLAG
!
!     ILMAX = CURRENT MAXIMUM NUMBER OF RATE OPTIONS
!
  ILMAX = 3
!
!     CHECK FOR VALID LECI; RETURN LECI = 1 OPTION IF NOT VALID
!
  IF(LECI .LT. 1 .OR. LECI .GT. ILMAX) GO TO 10
!
  GO TO (10, 20, 30) LECI
!
!     LECI = 1; USE XSNQ DERIVED IONIZATION RATE CALCULATION
!
10 CALL ADXECI(PTE, PNE)
  LECIOK = 1
  RETURN
!
!     LECI = 2; USE BELFAST GROUP LIGHT ELEMENT RATE FITS
!
20 CALL ADBFI(NUCZ, PTE, PNE, RCLION, CIZLOS, IFLAG)
  IF(IFLAG .NE. 0) GO TO 10
  LECIOK = 2
  RETURN
!
!     LECI = 3; USE YOUNGER'S RATES FOR AVAILABLE ELEMENTS AND SHELLS,
!               XSNQ RATES OTHERWISE ON A CHARGE STATE-BY-CHARGE STATE
!               BASIS
!
30 CALL ADXECI(PTE, PNE)
  CALL ADYGR(NUCZ, PTE, PNE, RCLION, CIZLOS, IFLAG)
  LECIOK = 3
  IF(IFLAG .NE. 0) LECIOK = 1
  RETURN
!
!
!
END SUBROUTINE ADECI
SUBROUTINE ADXECI(PTE, PNE)
!
!     REV: 3/30/83 ADECI --> ADXECI TO ACCOMODATE ALTERNATIVE RATES
!     REV: 10/10/82 FOR NEW AD PACKAGE
!
!     REV: 6/15/78
!
!     COMPUTES THE XSNQ-DERIVED COLLISIONAL IONIZATION RATES RCLION
!     AT THE ELECTRON TEMPERATURE PTE (KEV), WHERE JQ=(IONIC CHARGE+1).
!     THESE RATES HAVE THE UNITS (SEC-1).
!
!     NOTES:
!
!     1) ELECTRONS ARE ASSUMED TO FILL IONIC SHELLS IN SIMPLE ASCENDING
!        ORDER.  THIS IS ASSUMED BOTH EXPLICITLY (THE APN ARRAY)
!        AS WELL AS IMPLICITLY THROUGH THE USE OF NVALNC VALUES
!        IN LOOP INDICES, ETC.
!     2) THROUGH USE OF THE FUNCTION EXPUND, EXP(X) IS SET EQUAL TO
!        ZERO IN THE RATE EQUATIONS FOR VALUES OF X < -45.
!     3) RATES FOR THE SPECIES JQ REFER TO TRANSFORMATIONS OF
!        THAT SPECIES INTO ADJACENT IONIZATION STATES, NOT THE
!        RATES AT WHICH THAT SPECIES IS FORMED.
!
!
!     PRINCIPAL PHYSICS REFERENCES:
!
!     1) POST, JENSEN, TARTER, GRASBERGER, LOKKE, 'STEADY STATE
!        RADIATIVE COOLING RATES FOR LOW-DENSITY HIGH-TEMPERATURE
!        PLASMAS', PPPL-1352 (SUB. TO N.F.) (WITH CORRECTIONS)
!     2) LOKKE AND GRASBERGER, 'XSNQ-U A NON-LTE EMISSION AND
!        ABSORPTION COEFFICIENT SUBROUTINE', LLL REPORT UCRL-52276
!        (WITH CORRECTIONS).
!     3) XSNQ FORTRAN LISTING
!
!
!
!
  use iso_c_binding, only: fp => c_double
  use adpak_mod
  real(fp) :: pte,pne,ZJLKEV,ZTE,ZCHG,ZISUM,ZESUM,ZJN,ZXN,ZY,ZFY
  real(fp) :: ZGAUNT,ZITEMP  
  real(fp) :: EXPUND
  integer JQ,IVALNC,JN
  save
!
!
  ZJLKEV = 1.6021E-16_fp
!
!
  ZTE = PTE
!
  DO JQ = 1 , NUCZ
!
     ZCHG = DBLE(JQ - 1)
     IVALNC = NVALNC(JQ)
!
!
!
!     ******************** IONIZATION RATE ********************
!
!
!     CALCULATE ELECTRON COLLISIONAL IONIZATION RATES PER SHELL
!     AND SUM FOR ALL POPULATED SHELLS. ALSO COMPUTE
!     IONIZATION ENERGY LOSS RATE CIZLOS.
!
     ZISUM = 0._fp
     ZESUM = 0._fp
!
     DO JN = 1 , IVALNC
        ZJN = JN
        ZXN = EIN(JQ,JN)/ZTE
!
        ZY = DLOG10(ZXN/4._fp)
        ZFY = .23_fp + .046_fp * ZY + .1074_fp * ZY**2&
             - .0459_fp * ZY**3 - .01505_fp * ZY**4
        ZGAUNT = 12.18_fp * DEXP(-ZJN /(ZJN+5._fp))*&
             (1._fp + .0335_fp*ZJN)&
             * (1._fp - .622_fp/(ZCHG+1._fp)-&
             .0745_fp/(ZCHG+1._fp)**2) * ABS(ZFY)
        ZITEMP = APN(JQ,JN) * EXPUND(-ZXN,-45._fp) *&
             (1._fp-EXPUND(-ZXN,-45._fp)) * ZGAUNT / EIN(JQ,JN)**2
        ZISUM = ZISUM + ZITEMP
        ZESUM = ZESUM + EIN(JQ,JN) * ZITEMP
     enddo
!
     ZISUM = ZISUM * SQRT(ZTE)
     ZESUM = ZESUM * SQRT(ZTE)
     IF(ZISUM .LT. 1.E-26_fp) ZISUM = 0._fp
     IF(ZESUM .LT. 1.E-26_fp) ZESUM = 0._fp
     RCLION(JQ) = PNE * 3.44E-11_fp * ZISUM
     CIZLOS(JQ) = PNE * ZJLKEV * 3.44E-11_fp * ZESUM
!
!
  enddo
!
!
  RCLION(NUCZ + 1) = 0._fp
  CIZLOS(NUCZ + 1) = 0._fp
!
!
  RETURN
END SUBROUTINE ADXECI
SUBROUTINE ADBFI(KNUCZ, PTE, PNE, PBFI, PBFIL, KFLAG)
!
!     CALCULATE THE ELECTRON COLLISIONAL IONIZATION RATE COEFFICIENTS
!     USING FITTING FORMULAS FROM THE BELFAST GROUP, CULHAM
!     REPORT CLM-R216 (DECEMBER 1981):
!
!          ATOMIC AND MOLECULAR DATA FOR FUSION, PART I
!
!          RECOMMENDED CROSS SECTIONS AND RATES FOR ELECTRON
!          IONISATION OF LIGHT ATOMS AND IONS
!
!          K L BELL, H B GILBODY, J G HUGHES, A E KINGSTON, F J SMITH
!          THE QUEEN'S UNIVERSITY OF BELFAST, BELFAST, N IRELAND
!
!     KNUCZ = ELEMENT ATOMIC NUMBER ( Z=1 TO Z=8 ONLY)
!     PTE = ELECTRON TEMPERATURE (KEV)
!     PNE = ELECTRON DENSITY (CM-3)
!
!     PBFI = IONIZATION RATES FOR THE Z+1 CHARGE STATES (SEC-1)
!     PBFIL = ARRAY OF IONIZATION ENERGY LOSS RATES (WATTS/ION)
!     KFLAG = 0 FOR O.K., = 1 FOR INVALID ELEMENT
!
!
!
  use iso_c_binding, only: fp => c_double
  implicit none
  save
  real(fp)  PBFI(*), PBFIL(*)
  real(fp) :: PTE, PNE
  integer KNUCZ,KFLAG,INSPC,JSPC,alloc_stat
!
!----------------------------------------------------------------------
!
!     HYDROGEN
!
  real(fp) :: EH(1) = 13.60_fp 
  real(fp) :: AH(6) = (/ 2.3742E-8_fp, -3.6866E-9_fp, -1.0366E-8_fp,&
       -3.8010E-9_fp,  3.4159E-9_fp,  1.6834E-9_fp /)
  real(fp) :: AAH = 2.4617E-8_fp 
  real(fp) :: BTH(3) = (/9.5986E-8_fp, -9.2463E-7_fp, 3.9973E-6_fp /)
!
!     HELIUM
!
  real(fp) :: EHE(2) = (/ 24.6_fp, 54.42_fp /)
  real(fp) :: AHE(6,2) = reshape( (/ 1.4999E-8_fp, 5.6656E-10_fp, &
       -6.0821E-9_fp, -3.5894E-9_fp,  1.5529E-9_fp,& 
       1.3207E-9_fp,  3.4356E-9_fp, -1.6865E-9_fp,&
       -6.9236E-10_fp, 9.7863E-11_fp, 1.5591E-10_fp,&
       6.2236E-11_fp /), (/6,2/) )
  real(fp) :: AAHE(2) = (/ 3.1373E-8_fp, 3.0772E-9_fp /)
  real(fp) :: BTHE(3,2) = reshape( (/ 4.7893E-8_fp, -7.7359E-7_fp, &
       3.7366E-6_fp,1.1902E-8_fp, -1.1514E-7_fp, &
       5.0489E-7_fp /), (/3,2/) )
!
!     LITHIUM
!
  real(fp) :: ELI(3) = (/ 5.39_fp, 75.64_fp, 122.45_fp /)
  real(fp) :: ALI(6,3) = reshape((/ 9.9655E-8_fp, -5.5941E-8_fp,&
       -5.5228E-8_fp,4.0589E-8_fp, 1.4800E-8_fp,&
       -1.3120E-8_fp,3.4023E-9_fp, -7.6588E-10_fp,&
       -8.6078E-10_fp,-8.9748E-10_fp, 4.1661E-10_fp,&
       3.3188E-10_fp, 1.1786E-9_fp, -8.7637E-10_fp,&
       -9.3373E-11_fp,2.1137E-10_fp, 1.9017E-11_fp,&
       -4.0679E-11_fp/),(/6,3/))
  real(fp) :: AALI(3) = (/4.5456E-8_fp,7.3504E-9_fp,1.9767E-9_fp/)
  real(fp) :: BTLI(3,3) = reshape((/2.7800E-7_fp, -1.5830E-6_fp,&
       5.4650E-6_fp,5.3459E-10_fp, -5.6387E-8_fp,& 
       2.9577E-7_fp,-1.0926E-9_fp, 8.8700E-10_fp, &
       6.0764E-9_fp/), (/3,3/))
!
!     BERYLLIUM
!
  real(fp) :: EBE(4) = (/ 9.32_fp, 18.21_fp, 153.89_fp, 217.71_fp /)
  real(fp) :: ABE(6,4) = reshape( (/ 7.4206E-8_fp, -1.5520E-8_fp,& 
       -3.9403E-8_fp,&
       7.2155E-9_fp, 1.1098E-8_fp, -2.5501E-9_fp,&
       1.7136E-8_fp, -1.3997E-8_fp, -2.9656E-11_fp,&
       3.0777E-9_fp, -1.1676E-10_fp, -5.1930E-10_fp,&
       1.6039E-9_fp, -6.4336E-10_fp, -7.7804E-10_fp,&
       3.3527E-10_fp, 2.1889E-10_fp, -1.0600E-10_fp,&
       4.9587E-10_fp, -3.6870E-10_fp, -3.9284E-11_fp,&
       8.8928E-11_fp, 8.0007E-12_fp, -1.7114E-11_fp/),&
       (/6,4/) )
  real(fp) :: AABE(4) = (/ 2.1732E-7_fp, 2.7494E-8_fp, 2.7873E-9_fp, &
       8.3163E-10_fp /)
  real(fp) :: BTBE(3,4) = reshape( (/ -2.1649E-7_fp, 2.8120E-7_fp,& 
       5.3031E-7_fp,&
       -1.5900E-8_fp, 2.5911E-8_fp, 2.4061E-8_fp,&
       -2.4333E-10_fp, -9.7973E-9_fp, 5.2094E-8_fp,&
       -4.5966E-10_fp, 3.7317E-10_fp, 2.5564E-9_fp /),&
       (/3,4/) )
!
!     BORON
!
  real(fp) :: EB(5) = (/ 8.3_fp, 25.15_fp, 37.93_fp, 259.37_fp,& 
       340.22_fp /)
  real(fp) :: AB(6,5) = reshape( (/ 5.8365E-8_fp, 1.0047E-8_fp,& 
       -3.6230E-8_fp,&
       -7.3448E-9_fp, 1.0220E-8_fp, 1.6951E-9_fp,&
       2.0590E-8_fp, -9.8899E-9_fp, -6.0949E-9_fp,&
       2.7762E-9_fp, 1.6499E-9_fp, -6.7692E-10_fp,&
       5.7023E-9_fp, -4.6578E-9_fp, -9.8688E-12_fp,&
       1.0242E-9_fp, -3.8855E-11_fp, -1.7281E-10_fp,&
       7.3539E-10_fp, -2.9498E-10_fp, -3.5672E-10_fp,&
       1.5372E-10_fp, 1.0036E-10_fp, -4.8602E-11_fp,&
       2.5458E-10_fp, -1.8930E-10_fp, -2.0169E-11_fp,&
       4.5657E-11_fp, 4.1076E-12_fp, -8.7867E-12_fp/),(/6,5/))
  real(fp) :: AAB(5) = (/3.0952E-7_fp, 4.7980E-8_fp, 9.1493E-9_fp, &
       1.2780E-9_fp, 4.2697E-10_fp/)
  real(fp) :: BTB(3,5) = reshape((/ -4.9240E-7_fp, 1.3750E-6_fp,&
       -2.5387E-6_fp,&
       -4.1361E-8_fp, 5.5259E-8_fp, 9.9841E-8_fp,&
       -5.2910E-9_fp, 8.6226E-9_fp, 8.0067E-9_fp,&
       -1.1156E-10_fp, -4.4920E-9_fp, 2.3885E-8_fp,&
       -2.3600E-10_fp, 1.9159E-10_fp, 1.3125E-9_fp/),&
       (/3,5/))
!
!     CARBON
!
  real(fp) :: EC(6) = (/ 11.26_fp, 24.38_fp, 47.89_fp, 64.49_fp,& 
       392.08_fp, 489.98_fp/)
  real(fp) :: AC(6,6) = reshape((/ 5.9848E-8_fp, 1.1903E-8_fp,&
       -3.0140E-8_fp,&
       -1.3693E-8_fp, 8.3748E-9_fp, 4.0150E-9_fp,&
       2.8395E-8_fp, -1.6698E-8_fp, -2.3557E-9_fp,&
       3.2161E-10_fp, 9.6016E-10_fp, 5.2713E-10_fp,&
       9.0555E-9_fp, -6.3206E-9_fp, -1.3256E-9_fp,&
       1.7441E-9_fp, 3.2680E-10_fp, -3.8303E-10_fp,&
       2.7464E-9_fp, -2.0070E-9_fp, -2.3595E-11_fp,&
       4.2011E-10_fp, -8.1600E-11_fp, -3.9729E-11_fp,&
       3.9495E-10_fp, -1.5842E-10_fp, -1.9158E-10_fp,&
       8.2555E-11_fp, 5.3899E-11_fp, -2.6102E-11_fp,&
       1.4715E-10_fp, -1.0941E-10_fp, -1.1657E-11_fp,&
       2.6389E-11_fp, 2.3742E-12_fp, -5.0786E-12_fp/),&
       (/6,6/))
  real(fp) :: AAC(6) = (/ 3.7442E-7_fp, 6.0150E-8_fp, 1.4501E-8_fp,&
       6.0330E-9_fp, 6.8634E-10_fp, 2.4679E-10_fp /)
  real(fp) :: BTC(3,6) = reshape( (/ -6.5826E-7_fp, 2.0521E-6_fp, &
       -4.4694E-6_fp,&
       -4.0217E-8_fp, -2.7908E-8_fp, 5.5499E-7_fp,&
       -5.3596E-9_fp, -1.0473E-8_fp, 1.0629E-7_fp,&
       -5.7710E-9_fp, 9.9302E-9_fp, 7.4462E-9_fp,&
       -5.9916E-11_fp, -2.4124E-9_fp, 1.2828E-8_fp,&
       -1.3640E-10_fp, 1.1074E-10_fp, 7.5862E-10_fp /),&
       (/3,6/) )
!
!     NITROGEN
!
  real(fp) :: EN(7) = (/ 14.53_fp, 29.60_fp, 47.45_fp, 77.47_fp, & 
       97.89_fp, 552.06_fp,667.03_fp /)
  real(fp) :: AN(6,7) = reshape( (/ 4.6209E-8_fp, 9.2264E-9_fp, &
       -1.2092E-8_fp,&
       -2.4852E-8_fp, 5.1361E-9_fp, 8.3068E-9_fp,&
       2.4369E-8_fp, -2.2155E-9_fp, -1.4805E-8_fp,&
       -4.4218E-10_fp, 4.5211E-9_fp, 1.7874E-10_fp,&
       1.2964E-8_fp, -8.3408E-9_fp, -2.3684E-9_fp,&
       2.2485E-9_fp, 2.6234E-10_fp, -2.6333E-10_fp,&
       4.6322E-9_fp, -3.4645E-9_fp, -3.1014E-10_fp,&
       8.0576E-10_fp, 5.7791E-11_fp, -1.4907E-10_fp,&
       1.5862E-9_fp, -9.8633E-10_fp, 7.5130E-11_fp,&
       3.1005E-11_fp, -8.1970E-12_fp, 2.6759E-11_fp,&
       2.3635E-10_fp, -9.4805E-11_fp, -1.1465E-10_fp,&
       4.9404E-11_fp, 3.2255E-11_fp, -1.5620E-11_fp,&
       9.2653E-11_fp, -6.8892E-11_fp, -7.3402E-12_fp,&
       1.6616E-11_fp, 1.4949E-12_fp, -3.1978E-12_fp /),&
       (/6,7/) )
  real(fp) :: AAN(7) = (/ 2.7367E-7_fp, 4.4690E-8_fp, 1.0243E-8_fp,&
       7.9743E-9_fp, 5.7812E-9_fp, 4.1073E-10_fp,&
       1.5539E-10_fp /)
  real(fp) :: BTN(3,7) = reshape( (/ -4.2976E-7_fp, 9.8352E-7_fp, &
       -9.5745E-7_fp,&
       3.0430E-8_fp, -5.2696E-7_fp, 2.4863E-6_fp,&
       3.4218E-8_fp, -2.9155E-7_fp, 1.2324E-6_fp,&
       -4.9184E-9_fp, 6.3763E-9_fp, 1.4917E-8_fp,&
       -8.5163E-9_fp, 1.8527E-8_fp, -7.8181E-9_fp,&
       -3.5856E-11_fp, -1.4437E-9_fp, 7.6765E-9_fp,&
       -8.5888E-11_fp, 6.9728E-11_fp, 4.7767E-10_fp /),&
       (/3,7/) )
!
!     OXYGEN
!
  real(fp) :: EO(8) = (/ 13.62_fp, 35.12_fp, 54.93_fp, 77.41_fp,&
       113.90_fp, 138.12_fp, 739.32_fp,871.39_fp /)
  real(fp) :: AO(6,8) = reshape( (/ 3.3559E-8_fp, 1.3449E-8_fp, &
       -6.7112E-9_fp,&
       -1.9976E-8_fp, 1.6214E-9_fp, 6.5852E-9_fp,&
       2.4476E-8_fp, -5.3141E-9_fp, -7.3316E-9_fp,&
       -4.4515E-9_fp, 2.4257E-9_fp, 1.9791E-9_fp,&
       1.4741E-8_fp, -8.7905E-9_fp, -8.6099E-10_fp,&
       -2.4143E-10_fp, 1.2598E-10_fp, 6.4901E-10_fp,&
       6.2130E-9_fp, -2.5047E-9_fp, -3.0813E-9_fp,&
       1.3559E-9_fp, 8.6816E-10_fp, -4.3189E-10_fp,&
       2.6145E-9_fp, -2.0276E-9_fp, -1.6569E-10_fp,&
       5.0245E-10_fp, 3.0067E-11_fp, -9.8231E-11_fp,&
       1.0099E-9_fp, -6.5165E-10_fp, 2.8863E-12_fp,&
       3.0336E-11_fp, -1.4065E-11_fp, 4.5106E-12_fp,&
       1.5258E-10_fp, -6.1203E-11_fp, -7.4014E-11_fp,&
       3.1894E-11_fp, 2.0823E-11_fp, -1.0084E-11_fp,&
       6.2090E-11_fp, -4.6167E-11_fp, -4.9189E-12_fp,&
       1.1135E-11_fp, 1.0018E-12_fp, -2.1430E-12_fp /),&
       (/6,8/) )
  real(fp) :: AAO(8) = (/ 3.2721E-7_fp, 4.9003E-8_fp, 1.7523E-8_fp,&
       1.0270E-8_fp, 4.0023E-9_fp, 2.6228E-9_fp,&
       2.6516E-10_fp, 1.0413E-10_fp /)
  real(fp) :: BTO(3,8) = reshape( (/ -6.7484E-7_fp, 2.3938E-6_fp, &
       -6.04388E-6_fp, 2.1747E-8_fp, -5.4612E-7_fp, &
       2.7213E-6_fp,&
       2.8129E-8_fp, -3.1692E-7_fp, 1.4381E-6_fp,&
       4.8134E-10_fp, -4.3936E-8_fp, 2.1924E-7_fp,&
       -1.5957E-9_fp, -7.2485E-10_fp, 1.9724E-8_fp,&
       -2.6662E-9_fp, 2.8968E-9_fp, 1.7246E-8_fp,&
       -2.3148E-11_fp, -9.3201E-10_fp, 4.9557E-9_fp,&
       -5.7557E-11_fp, 4.6727E-11_fp, 3.2010E-10_fp /),&
       (/3,8/) )
!
!----------------------------------------------------------------------
!
  INSPC = KNUCZ + 1
!
  PBFI(1:INSPC) = 0._fp
  PBFIL(1:INSPC) = 0._fp
!
  KFLAG = 0
!
!     ERROR EXIT IF ELEMENT NOT AVAILABLE
!
  IF(KNUCZ .GE. 1 .AND. KNUCZ .LE. 8) GO TO 5
  KFLAG = 1
  RETURN
!
!     BRANCH ON ELEMENT TO CALL FIT EVALUATION ROUTINE WITH PROPER
!     CONSTANTS
!
5 GO TO (10, 20, 30, 40, 50, 60, 70, 80) KNUCZ
!
10 CALL ADBFIT(KNUCZ, PTE, PNE, EH, AH, AAH, BTH, PBFI, PBFIL)
  RETURN
20 CALL ADBFIT(KNUCZ, PTE, PNE, EHE, AHE, AAHE, BTHE, PBFI, PBFIL)
  RETURN
30 CALL ADBFIT(KNUCZ, PTE, PNE, ELI, ALI, AALI, BTLI, PBFI, PBFIL)
  RETURN
40 CALL ADBFIT(KNUCZ, PTE, PNE, EBE, ABE, AABE, BTBE, PBFI, PBFIL)
  RETURN
50 CALL ADBFIT(KNUCZ, PTE, PNE, EB, AB, AAB, BTB, PBFI, PBFIL)
  RETURN
60 CALL ADBFIT(KNUCZ, PTE, PNE, EC, AC, AAC, BTC, PBFI, PBFIL)
  RETURN
70 CALL ADBFIT(KNUCZ, PTE, PNE, EN, AN, AAN, BTN, PBFI, PBFIL)
  RETURN
80 CALL ADBFIT(KNUCZ, PTE, PNE, EO, AO, AAO, BTO, PBFI, PBFIL)
  
  RETURN
END SUBROUTINE ADBFI
!
!#####################################################################
!
SUBROUTINE ADBFIT(KNUCZ, PTE, PNE, PE, PA, PAA, PBT, PBFI, PBFIL)
!
!     EVALUATE THE BELFAST GROUP RATE COEFFICIENT FITTING FORMULAS.
!     NOTE THAT 0 IS RETURNED FOR TE < (IONIZATION POTENTIAL / 10).
!
  use iso_c_binding, only: fp => c_double
  implicit none
  save
  real(fp) :: PE(KNUCZ), PA(6,KNUCZ), PAA(KNUCZ), PBT(3,KNUCZ)
  real(fp) :: PBFI(*), PBFIL(*)
  real(fp) :: PTE, PNE,ZJLEV,ZTE,ZX,ZLOG,ZSUM,ZIRC
  integer KNUCZ,INSPC,JSPC, J
!
  ZJLEV = 1.6021E-19_fp
!
!     CONVERT TE TO EV AND ZERO RETURN ARRAYS
!
  ZTE = 1000._fp * PTE
!
  INSPC = KNUCZ + 1
  PBFI(1:INSPC) = 0._fp
  PBFIL(1:INSPC) = 0._fp
!
!     LOOP OVER ALL SPECIES EXCEPT FULLY STRIPPED
!
  DO JSPC = 1, KNUCZ
!
!     RATE IS ZERO FOR KT < (IP/10)
!
     IF(ZTE .LT. PE(JSPC)/10._fp) cycle
!
!     BRANCH IF HIGH TEMPERATURE FIT IS REQUIRED
!
     IF(ZTE .GT. 10._fp * PE(JSPC)) GO TO 80
!
!     (IP/10) < TE < (10*IP) FITTING FORM
!
     ZX = PE(JSPC) / ZTE
     ZLOG = DLOG10(1.0_fp / ZX)
!
     ZSUM = PA(1,JSPC)
     DO J = 2, 6
        ZSUM = ZSUM + PA(J,JSPC) * (ZLOG**(J-1))
     enddo
!
     ZIRC = DEXP(-ZX) * SQRT(1.0_fp / ZX) * ZSUM
     PBFI(JSPC) = PNE * ZIRC
     PBFIL(JSPC) = ZJLEV * PE(JSPC) * PBFI(JSPC)
     cycle
!
!     HIGH TEMPERATURE FIT FOR TE > 10*IP
!
80   ZX = PE(JSPC) / ZTE
!
     ZIRC = SQRT(ZX) * (PAA(JSPC) * DLOG(1.0_fp/ZX)&
          + PBT(1,JSPC) + PBT(2,JSPC) * ZX + PBT(3,JSPC) * ZX * ZX)
!
     PBFI(JSPC) = PNE * ZIRC
     PBFIL(JSPC) = ZJLEV * PE(JSPC) * PBFI(JSPC)
!
  enddo
!
  RETURN
END SUBROUTINE ADBFIT
SUBROUTINE ADYGR(KNUCZ, PTE, PNE, PYGRI, PYGRL, KFLAG)
!
!     COMPUTE DIRECT ELECTRON IONIZATION RATES FOR HYDROGEN-LIKE
!     THROUGH NEON-LIKE CHARGE STATES OF CERTAIN HEAVY ELEMENTS
!     (PRESENTLY SCANDIUM AND IRON).  USES FORMULAE DUE TO
!     S. YOUNGER, NBS.  (JQSRT 29, 61 (1983) AND PRIVATE
!     COMMUNICATIONS).
!
!     KNUCZ= ELEMENT (Z=21 OR 26 FOR NOW)
!     PTE = ELECTRON TEMPERATURE(KEV)
!     PNE = ELECTRON DENSITY (CM-3)
!
!     PYGRI = ARRAY OF IONIZATION RATES (SEC-1)
!             (ONLY THE 10 STATES FROM H-LIKE TO NE-LIKE WILL BE
!              OVERWRITTEN BY THE SUBROUTINE)
!     PYGRL = ARRAY OF IONIZATION ENERGY LOSS RATES (WATTS/ION)
!     KFLAG = 0 FOR O.K.;
!           = 1 FOR INVALID ELEMENT (NO VALUES ARE RETURNED)
!
!     
  use iso_c_binding, only: fp => c_double
  implicit NONE
  save
  real(fp) :: EION(10,3), RATE(10,3)
  real(fp) :: PYGRI(*), PYGRL(*)
  integer i
!
  integer :: NSS(10,3) = reshape( (/ 1,&
       (2,i=1,9),0,0,1,(2,i=1,7),&
       (0,i=1,4),1,2,3,4,5,6/), (/10,3/) )
!
  real(fp) :: CA(3) = (/7.5E-14_fp, 5.9E-14_fp, 8.4E-14_fp/)
  real(fp) :: CB(3) = (/ -2.605E-14_fp, -1.635E-14_fp, -2.68E-14_fp/)
  real(fp) :: CC(3) = (/ 1.195E-14_fp, 0.82E-14_fp, 0.672E-14_fp/)
  real(fp) :: CD(3) = (/ -6.15E-14_fp, -3.79E-14_fp, -5.08E-14_fp/)
!
  real(fp) :: EIONSC(10,3) = reshape( (/ 6034._fp, 5675._fp,&
       5566._fp, 5491._fp, 5318._fp, 5204._fp, 5095._fp, 4990._fp, &
       4890._fp, 4794._fp,&
       0._fp, 0._fp, 1288._fp, 1213._fp, 1135._fp, 1068._fp, &
       993.3_fp,&
       914.0_fp, 846.3_fp, 769.3_fp, (0._fp,i=1,4), 1090._fp, &
       1004._fp, 922.4_fp,&
       838.6_fp, 761.8_fp, 687.4_fp /), (/10,3/) )
!
  real(fp) :: EIONFE(10,3) = reshape( (/ 9277._fp, 8829._fp,&
       8694._fp, 8521._fp, 8400._fp, 8263._fp, 8118._fp, 7949._fp, &
       7818._fp, 7824._fp,&
       0._fp, 0._fp, 2046._fp, 1950._fp, 1852._fp, 1755._fp,& 
       1679._fp, 1566._fp, 1482._fp,&
       1394._fp, (0._fp,i=1,4), 1789._fp, 1678._fp, 1583._fp, &
       1463._fp, &
       1366._fp, 1266._fp/),&
       (/10,3/) )
!
  real(fp) :: PTE, PNE,TEV,CHI,A,B,C,D
  real(fp) :: fchi
  integer JSS,JBE,KFLAG,ICS,KNUCZ
!
!
  TEV = 1000._fp * PTE
!
  EION(1,1) = 0._fp
  DO JSS = 1, 3
     DO JBE = 1, 10
        IF(KNUCZ .EQ. 21) EION(JBE,JSS) = EIONSC(JBE,JSS)
        IF(KNUCZ .EQ. 26) EION(JBE,JSS) = EIONFE(JBE,JSS)
     enddo
  enddo
!
  KFLAG = 0
  IF(EION(1,1) .NE. 0._fp)GO TO 50
  KFLAG = 1
  RETURN
!
50 DO JBE = 1, 10
     ICS = KNUCZ - JBE +1
     PYGRI(ICS) = 0._fp
     PYGRL(ICS) = 0._fp
!
     DO JSS = 1, 3
        RATE(JBE,JSS) = 0._fp
        IF(NSS(JBE,JSS) .EQ. 0) cycle
!
        CHI = TEV / EION(JBE,JSS)
        A = CA(JSS) * DBLE(NSS(JBE,JSS))
        B = CB(JSS) * DBLE(NSS(JBE,JSS))
        C = CC(JSS) * DBLE(NSS(JBE,JSS))
        D = CD(JSS) * DBLE(NSS(JBE,JSS))
        RATE(JBE,JSS) = FCHI(CHI,A,B,C,D) * (EION(JBE,JSS)**(-1.5_fp)) *&
             2.2E-06_fp * SQRT(CHI) * DEXP(-1.0_fp/CHI)
        PYGRI(ICS) = PYGRI(ICS) + PNE * RATE(JBE,JSS)
        PYGRL(ICS) = PYGRL(ICS) + 1.6021E-19_fp * PNE * EION(JBE,JSS)&
             * RATE(JBE,JSS)
     enddo
  enddo
!
  RETURN
END SUBROUTINE ADYGR
!
real(fp) FUNCTION FCHI(PCHI, PA, PB, PC, PD)
!
  use iso_c_binding, only: fp => c_double
  implicit NONE
  save
  real(fp) :: PCHI, PA, PB, PC, PD
  real(fp) :: Z1,Z2,Z3,ZCHISQ,ZCHICB,ZALPHA,ZBETA
  
  Z1 = PA + PB * (1.0_fp + 1.0_fp / PCHI)
  Z2 = PC - (PA + 2.0_fp*PB + PB/PCHI)/PCHI
  Z3 = PD / PCHI
  ZCHISQ = PCHI * PCHI
  ZCHICB = ZCHISQ * PCHI
  ZALPHA = (.001193_fp + .9764_fp*PCHI +.6604_fp*ZCHISQ +&
       .02590_fp*ZCHICB) / (1.0_fp + 1.488_fp*PCHI +&
       .2972_fp*ZCHISQ + .004925_fp*ZCHICB)
  ZBETA = (-.0005725_fp + .01345_fp*PCHI +.8691_fp*ZCHISQ +&
       .03404_fp*ZCHICB) / (1.0_fp + 2.197_fp*PCHI +&
       .2454_fp*ZCHISQ + .002053_fp*ZCHICB)
  FCHI = (3.0E13_fp / PCHI) * (Z1 + Z2 * ZALPHA + Z3 * ZBETA)
  RETURN
END FUNCTION FCHI
SUBROUTINE ADRREC(PTE, PNE)
!
!     REV: 10/10/82 FOR AD PACKAGE
!
!     REV: 9/9/81, 6/15/78
!
!     COMPUTE RADIATIVE RECOMBINATION RATES RRAREC(JQ) FOR A GIVEN
!     ELECTRON TEMPERATURE PTE (KEV), WHERE JQ = (IONIC CHARGE + 1).
!     THESE RATES HAVE THE UNITS (SEC-1).
!     ALSO COMPUTED ARE THE RADIATION RATES ASSOCIATED WITH
!     THIS PROCESS, RADRRC(JQ).  THESE RATES ARE IN JOULES/SEC.
!
!     NOTES:
!
!     1) ELECTRONS ARE ASSUMED TO FILL IONIC SHELLS IN SIMPLE ASCENDING
!        ORDER.  THIS IS ASSUMED BOTH EXPLICITLY (THE APN ARRAY)
!        AS WELL AS IMPLICITLY THROUGH THE USE OF NVALNC VALUES
!        IN LOOP INDICES, ETC.
!     2) THROUGH USE OF THE FUNCTION EXPUND, EXP(X) IS SET EQUAL TO
!        ZERO IN THE RATE EQUATIONS FOR VALUES OF X < -45.
!     3) RATES FOR THE SPECIES JQ REFER TO TRANSFORMATIONS OF
!        THAT SPECIES INTO ADJACENT IONIZATION STATES, NOT THE
!        RATES AT WHICH THAT SPECIES IS FORMED.
!     4) UPON EVALUATION OF THE FORMULAE IT WILL BE FOUND THAT THE
!        FORMALISM USED IN XSNQ/LOKKE AND GRASBERGER (REFS 6,2)
!        IN FACT LEADS TO THE SAME EQUATIONS GIVEN IN
!        PPPL-1352/SEATON (REFS 1,3) IF THE SHIELDED CHARGE FOR
!        LEVEL N IS USED FOR 'Q'.
!
!
!     PRINCIPAL PHYSICS REFERENCES:
!
!     1) POST, JENSEN, TARTER, GRASBERGER, LOKKE, 'STEADY STATE
!        RADIATIVE COOLING RATES FOR LOW-DENSITY HIGH-TEMPERATURE
!        PLASMAS', CORRECTED PPPL-1352 (SUB. TO N.F.)
!     2) LOKKE AND GRASBERGER, 'XSNQ-U A NON-LTE EMISSION AND
!        ABSORPTION COEFFICIENT SUBROUTINE', LLL REPORT UCRL-52276
!     3) SEATON, 'RADIATIVE RECOMBINATION OF HYDROGENIC IONS',
!        MNRAS:119,81 (1959)
!     4) COX AND TUCKER, 'IONIZATION EQUILIBRIUM AND RADIATIVE
!        COOLING OF A LOW-DENSITY PLASMA', AP.J.:157,1157 (1969)
!     5) GRASBERGER, XSNQ - TOKAMAK MEMORANDUM #1, 2/11/76
!     6) XSNQ FORTRAN LISTING
!
!
!
!
  use iso_c_binding, only: fp => c_double
  use adpak_mod
  save
  real(fp) :: PTE, PNE,ZJLKEV,ZTE,ZRSUM,ZRSUMC,ZRSUML,ZXN,ZRTEMP
  real(fp) :: ZRTMPL,ZRTMPC
  integer JQ,IVALNC,IVJQM1,JN
  real(fp) EXPE1

  ZJLKEV = 1.6021E-16_fp
!
!
!
  ZTE = PTE
!
  RRAREC(1) = 0._fp
  RADRRC(1) = 0._fp
!
!     ********** LOOP FOR ALL NON-NEUTRAL SPECIES **********
!
  DO JQ = 2 , NSPC
!
     IVALNC = NVALNC(JQ)
     IVJQM1 = NVALNC(JQ - 1)
!
!
!
!     CALCULATE RADIATIVE RECOMBINATION RATES PER SHELL AND SUM THEM
!     (SUMS (FRACTIONAL VACANCY OF SHELL) * (ALPHAN) ; ALPHAN
!     FROM CORRECTED PPPL-1352).  ALSO SUM CONTINUUM AND LINE
!     RADIATION RATES DUE TO RADIATIVE RECOMBINATIONS TO EACH SHELL.
!
!
!
     ZRSUM = 0._fp
     ZRSUMC = 0._fp
     ZRSUML = 0._fp
!
     DO JN = IVALNC,10
!
!     SKIP VALANCE SHELL IF FULL TO AVOID UNDEFINED EN, QN
!
        IF(AQN(JQ,JN) .EQ. 0._fp) cycle
!
        ZXN = EN(JQ,JN)/ZTE
!
        ZRTEMP = AQN(JQ,JN) * QN(JQ,JN) * (ZXN**1.5_fp) * EXPE1(ZXN)
!
!     HIGH-LYING LEVELS CORRECTION FOR NLVLMX=10 IS 5.13
!
        IF(JN .EQ. 10) ZRTEMP = ZRTEMP * 5.13_fp
        ZRSUM = ZRSUM + ZRTEMP
!
        ZRTMPL = ENM(JQ-1,IVJQM1,JN) * ZRTEMP
        ZRSUML = ZRSUML + ZRTMPL
!
        ZRTMPC = AQN(JQ,JN) * QN(JQ,JN) * SQRT(ZXN) * EN(JQ,JN)
        ZRSUMC = ZRSUMC + ZRTMPC
     enddo
!
     RRAREC(JQ) = PNE * 5.20E-14_fp * ZRSUM
     IF(ZRSUMC .LT. 1.E-07_fp) ZRSUMC = 0._fp
     ZRSUMC = 8.32E-30_fp * ZRSUMC
!
     IF(ZRSUML .LT. 1.E-7_fp) ZRSUML = 0._fp
     ZRSUML = ZJLKEV * 5.20E-14_fp * ZRSUML
     RADRRC(JQ) = PNE * (ZRSUMC + ZRSUML)
!
!
  enddo
!
!
  RETURN
END SUBROUTINE ADRREC
SUBROUTINE ADDREC(PTE, PNE)
!7600      LCM DIEREC
!
!     REV: 10/10/82 FOR NEW AD PACKAGE
!
!     REV: 11/11/81 ADD CDNN AND CDNM MULTIPLIERS
!
!     REV: 10/23/78 (REMOVE 'C' FROM ZDSUM0 DEFINING STATEMENT TO FIX
!                    N-N DIELECTRONIC RATE BUG)
!     REV: 6/15/78
!
!     COMPUTES DIELECTRONIC RECOMBINATION RATE RDIREC(JQ)
!     FOR A GIVEN ELECTRON TEMPERATURE PTE (KEV) AND ELECTRON
!     DENSITY PNE (CM-3), WHERE JQ = (IONIC CHARGE +1).
!     THESE RATES HAVE THE UNITS (SEC-1).  SINCE
!     THE RATE COEFF DEPEND ON NE, THE TOTAL RECOMBINATION RATE
!     PER ION IS NOT STRICTLY A LINEAR FUNCTION OF NE.  HOWEVER,
!     THE DIELECTRONIC COLLISIONAL-INTERRUPTION CORRECTION IS
!     ONLY WEAKLY DEPENDENT ON THE DENSITY, AND THUS THE NON-LINEARITY
!     IS GENERALLY SMALL.
!
!     ALSO COMPUTED ARE THE RADIATION RATES ASSOCIATED WITH THIS
!     PROCESS, RADDRC(JQ), WHICH INCLUDE CONTRIBUTIONS FROM
!     THE RADIATIVE DECAYS OF BOTH THE EXCITED AND CAPTURED ELECTRONS.
!     THESE RATES ARE IN JOULES/SEC.
!
!     NOTES:
!
!     1) ELECTRONS ARE ASSUMED TO FILL IONIC SHELLS IN SIMPLE ASCENDING
!        ORDER.  THIS IS ASSUMED BOTH EXPLICITLY (THE APN ARRAY)
!        AS WELL AS IMPLICITLY THROUGH THE USE OF NVALNC VALUES
!        IN LOOP INDICES, ETC.
!     2) THROUGH USE OF THE FUNCTION EXPUND, EXP(X) IS SET EQUAL TO
!        ZERO IN THE RATE EQUATIONS FOR VALUES OF X < -45.
!     3) RATES FOR THE SPECIES JQ REFER TO TRANSFORMATIONS OF
!        THAT SPECIES INTO ADJACENT IONIZATION STATES, NOT THE
!        RATES AT WHICH THAT SPECIES IS FORMED.
!
!
!     PRINCIPAL PHYSICS REFERENCES:
!
!     1) POST, JENSEN, TARTER, GRASBERGER, LOKKE, 'STEADY STATE
!        RADIATIVE COOLING RATES FOR LOW-DENSITY HIGH-TEMPERATURE
!        PLASMAS', CORRECTED PPPL-1352 (SUB. TO N.F.)
!     2) BURGESS, 'A GENERAL FORMULA FOR THE ESTIMATION OF
!        DIELECTRONIC RECOMBINATION COEFFICIENTS IN LOW-DENSITY
!        PLASMAS', AP.J. 141, 1588 (1965).
!     3) GRASBERGER, XSNQ - TOKAMAK MEMORANDUM #1, 2/11/76
!     4) GRASBERGER, XSNQ - TOKAMAK MEMORANDUM #4, 7/29/76
!     5) GRASBERGER, XSNQ - TOKAMAK MEMORANDUM #10, 1/5/77
!     6) MERTS, COWAN, MAGEE, 'THE CALCULATED POWER OUTPUT
!        FROM A THIN IRON-SEEDED PLASMA', LOS ALAMOS REPORT LA-6220-MS
!     7) XSNQ FORTRAN LISTING
!     8) ANSARI, ELWERT AND MUCKLICH, 'ON DIELECTRONIC RECOMBINATION',
!        ZEITSCHRIFT NATURFORSCHUNG 25A, 1781 (1970).
!
!
!
!
  use iso_c_binding, only: fp => c_double
  use adpak_mod
  save
  real(fp) :: PTE, PNE,ZJLKEV,ZTE,ZNE,ZNUC,ZCHG,ZQ,ZQP1,ZBQ,ZNT,ZDNN,&
       ZZZ,ZDNM,ZZZNN, ZZZNM,ZZZA,ZZZET,ZEIJNN,ZYNN,ZAYNN,ZDSUM0,&
       ZDSUM,ZDSUMR,ZEIJ,ZY,ZAY,ZDTEMP,ZDNNRT,ZDNMRT,ZIQ,ZTEMP
  integer JQ,IVALNC,JN,IIJM,JM,ITEMP
  real(fp) :: EXPUND
!
  ZJLKEV = 1.6021E-16_fp
!
!     CALL ADDRCC TO FILL CDNN AND CDNM MULTIPICATIVE CONSTANT ARRAYS
!
  CALL ADDRCC
!
  ZTE = PTE
  ZNE = PNE
!
  ZNUC = DBLE(NUCZ)
!
  RDIREC(1) = 0._fp
  RADDRC(1) = 0._fp
  RDIREC(NSPC) = 0._fp
  RADDRC(NSPC) = 0._fp
!
  IF(NUCZ .EQ. 1) RETURN
!
!
!     ********** LOOP FOR ALL SPECIES EXCEPT NEUTRAL **********
!              ********** AND FULLY IONIZED **********
!
  DO JQ = 2 , NUCZ
!
!
     ZCHG = DBLE(JQ-1)
     IVALNC = NVALNC(JQ)
!
!
!
!     ************* DIELECTRONIC RECOMBINATION RATE *************
!
!     (EQUATIONS AND VARIABLES FOLLOW PPPL-1352/BURGESS FORMALISM)
!
!
!
     ZQ = ZCHG
     ZQP1 = ZCHG + 1._fp
!
     ZBQ = SQRT(  (ZQ * (ZQ+1._fp)**5) / (ZQ*ZQ + 13.4_fp)  )
     ZNT = (4.77E+18_fp * (ZQ**6) * SQRT(ZTE) / ZNE)**0.142857143_fp
     ZDNN = .0068_fp * ZNT * (1._fp+.001_fp*ZNT) / &
          (1._fp+.00002_fp*ZNT*ZNT)
     ZZZ = .0015_fp * ( (ZQ+1._fp) * ZNT )**2
     ZDNM = ZZZ / (1._fp + ZZZ)
     ZZZNN = 7.59E-14_fp* ZBQ * ZDNN / (ZTE**1.5_fp)
     ZZZNM = 7.59E-14_fp * ZBQ * ZDNM / (ZTE**1.5_fp)
     ZZZA = 1._fp + .015_fp * (ZQ**3) / ( (ZQ+1._fp)**2 )
     ZZZET = ( (ZQ + 1._fp)**2 ) / (73.5_fp * ZZZA * ZTE)
!
!
!     COMPUTE N - N CONTRIBUTION TO SUM FIRST
!
!
     ZEIJNN = ENN(JQ) / (.0136_fp * ZQP1 * ZQP1)
     ZYNN = (ZQ + 1._fp) * ZEIJNN
     ZAYNN = SQRT(ZYNN) / (1._fp + .105_fp * ZYNN + .015_fp * ZYNN**2)
!
     ZDSUM0 = FNN(JQ) * ZAYNN * EXPUND(-ZZZET*ZEIJNN , -45._fp)
!
!
!     SUM OVER N - M TRANSITIONS (NOTE THAT TRANSITIONS FROM
!     INNER SHELLS TO THE VALENCE SHELL AND ABOVE ARE INCLUDED)
!
!
     ZDSUM = 0._fp
     ZDSUMR = 0._fp
!
     DO JN = 1 , IVALNC
        IIJM = IVALNC
        IF(JN .EQ. IVALNC .OR.&
             AQN(JQ,IVALNC) .EQ. 0._fp) IIJM = IVALNC + 1
!
        DO JM = IIJM , 10
!
           ZEIJ = ENM(JQ,JN,JM) / (.0136_fp * ZQP1**2)
           ZY = (ZQ + 1._fp) * ZEIJ
           ZAY = SQRT(ZY) / (2._fp + .420_fp * ZY + .06_fp * ZY**2)
!
           ZDTEMP = FNM(JQ,JN,JM) * ZAY * EXPUND(-ZZZET*ZEIJ , -45._fp)
!
           ZDSUM = ZDSUM + ZDTEMP
           ZDSUMR = ZDSUMR + ENM(JQ,JN,JM) * ZDTEMP
        enddo
     enddo
!
     ZDNNRT = ZZZNN * ZDSUM0
     ZDNMRT = ZZZNM * ZDSUM
!W    WRITE(LADPOUT9,909)JQ,ZDNNRT,ZDNMRT
!W  909 FORMAT(1X,'JQ =',I3,3X,'ZDNNRT =',1PE12.2,'  ZDNMRT =',E12.2)
     RDIREC(JQ) = PNE * (CDNN(JQ) * ZDNNRT + CDNM(JQ) * ZDNMRT)
!
     ITEMP = NVALNC(JQ-1)
     ZIQ = EN(JQ,ITEMP)
     ZTEMP = CDNN(JQ) * (ZIQ + ENN(JQ)) * ZDNNRT +&
          CDNM(JQ) * (ZIQ * ZDNMRT + ZZZNM * ZDSUMR)
     IF(ZTEMP .LT. 1.E-21_fp) ZTEMP = 0._fp
     RADDRC(JQ) = PNE * ZJLKEV * ZTEMP
!
!
!
  enddo
!
!
  RETURN
END SUBROUTINE ADDREC
SUBROUTINE ADDRCC
!
!     REV: 10/10/82 FOR NEW AD PACKAGE
!
!     SETUP THE DIELECTRONIC RECOMBINATION RATE COEFFICIENT
!     MULTIPLICATIVE CONSTANT ARRAYS CDNN AND CDNM ACCORDING
!     TO THE LDRMLT SWITCH.
!
!     LDRMLT = 0     USE CDNN, CDNM ARRAYS AS GIVEN
!     LDRMLT = 1     CDNN, CDNM ARRAYS SET TO 1.0
!     LDRMLT = 2     USE Y. HAHN FACTORS TO SETUP CDNN, CDNM
!
  use iso_c_binding, only: fp => c_double
  use adpak_mod
  save
  integer JSPC
  real(fp) :: ZNELEC
!
!
  IF(LDRMLT .EQ. 0) RETURN
!
  CDNN(1:100) = 1.0_fp
  CDNM(1:100) = 1.0_fp
!
  IF(LDRMLT .EQ. 1) RETURN
!
!
  DO JSPC = 2, NUCZ
!
     ZNELEC = DBLE(NUCZ - JSPC + 1)
!
     CDNN(JSPC) = YHNNA * DEXP(-YHNNB*SQRT(ZNELEC) ) *&
          (DBLE(NUCZ)**YHNNC)
!
     CDNM(JSPC) = YHNMA * DEXP(-YHNMB*SQRT(ZNELEC)) *&
          (DBLE(NUCZ)**YHNMC)
  enddo
!
  RETURN
END SUBROUTINE ADDRCC
SUBROUTINE ADECEX(PTE, PNE)
!
!     REV: 10/10/82 FOR NEW AD PACKAGE
!
!     REV: 6/15/78
!
!     COMPUTE RADIATION RATES RADCLX(JQ) (JOULE/SEC) DUE TO
!     COLLISIONAL EXCITATION FOR EACH IONIC SPECIES JQ = (IONIC
!     CHARGE + 1).  ALL EXCITATIONS ARE ASSUMED TO RESULT IN
!     RADIATIVE DECAYS.
!
!     REFERENCES:
!     1) POST ET AL. PPPL-1352 (CORRECTED)
!
!
  use iso_c_binding, only: fp => c_double
  use adpak_mod
  save
!
!
  integer i
  real(fp) :: ZDNN(28) = (/ 0._fp, 0._fp,&
       1.2_fp, .91_fp, .89_fp, .92_fp, .86_fp, .87_fp, .85_fp, 0._fp,&
       .72_fp, .78_fp, .76_fp, .78_fp, .75_fp, .70_fp, .68_fp, .65_fp,&
       .65_fp,(.70_fp,i=1,8), 0._fp /)
!
  real(fp) :: ZGAMNN(28) = (/ 0._fp, 0._fp,&
       .54_fp, .77_fp, .58_fp, .57_fp, .41_fp, .63_fp, .66_fp, 0._fp,&
       .97_fp, .96_fp, .88_fp, .86_fp, .87_fp, .85_fp, .83_fp, .81_fp,&
       (.80_fp,i=1,9), 0._fp /)
  real(fp) EXPE1
  real(fp) :: EXPUND
  real(fp) :: PTE, PNE,ZJLKEV,ZTE,ZNUC,ZCHG,ZZNN,ZXNN,ZTEMP,ZGNN,&
       ZNMSUM,ZJN,ZJM,ZXNM,ZGNM,ZZNM
  integer IVALNC,IBOUND,JQ,JN,IIJM,JM
!
  ZJLKEV = 1.6021E-16_fp
!
!
!
  ZTE = PTE
  ZNUC = DBLE(NUCZ)
!
!     ******** LOOP FOR ALL SPECIES EXCEPT FULLY IONIZED ********     
!
  DO JQ = 1 , NUCZ
!
     ZCHG = DBLE(JQ - 1)
     IVALNC = NVALNC(JQ)
     IBOUND = NUCZ - JQ + 1
!
!     ***** N - N RATE *****
!
     ZZNN = 0._fp
     IF(FNN(JQ) .EQ. 0._fp) GO TO 30
!
     ZXNN = ENN(JQ) / ZTE
!
     IF(JQ .NE. 1) GO TO 20
     ZTEMP = .06_fp * (SQRT(ZXNN) - 2._fp) / (1._fp + ZXNN)
     GO TO 22
!
20   IF(IBOUND .LE. 28) GO TO 21
     ZTEMP = .7_fp * (1._fp - .8_fp/ ZCHG)
     GO TO 22
!
21   ZTEMP = ZDNN(IBOUND) * (1._fp - ZGAMNN(IBOUND) / ZCHG)
!
22   ZGNN = ZTEMP + .276_fp * EXPE1(ZXNN)
!
     ZZNN = FNN(JQ) * EXPUND(-ZXNN , -45._fp) * ZGNN
!
!     ***** SUM N - M RATES FROM ALL OCCUPIED SHELLS *****
!
30   ZNMSUM = 0._fp
!
!
     DO JN = 1 , IVALNC
!
        ZJN = DBLE (JN)
        IIJM = IVALNC
        IF(JN .EQ. IVALNC .OR.&
             AQN(JQ,IVALNC) .EQ. 0._fp) IIJM = IVALNC + 1
!
        DO JM = IIJM , 10
           ZJM = DBLE(JM)
!
           ZXNM = ENM(JQ,JN,JM) / ZTE
           ZTEMP = ZJM * (ZJM - ZJN) * (1._fp + (1._fp - 2._fp/ZNUC) * ZXNM)&
                / 20._fp
           ZGNM = .19_fp * (1._fp + .9_fp * (1._fp + ZTEMP) * EXPE1(ZXNM))
!
!     NOTE THAT FNM HAS APN AND AQN FACTORS ALREADY INCLUDED
!
           ZZNM = FNM(JQ,JN,JM) * EXPUND(-ZXNM , -45._fp) * ZGNM
           ZNMSUM = ZNMSUM + ZZNM
        enddo
     enddo
!
!
!
     ZTEMP = (ZZNN + ZNMSUM) / SQRT(ZTE)
     IF(ZTEMP .LT. 1.E-10_fp) ZTEMP = 0._fp
     RADCLX(JQ) = PNE * ZJLKEV * 4.99E-10_fp * ZTEMP
!
  enddo
!
!     ***************END OF JQ SPECIES LOOP ***************
!
  RADCLX(NSPC) = 0._fp
!
  RETURN
END SUBROUTINE ADECEX
SUBROUTINE ADBREM(PTE, PNE)
!
!     REV: 10/10/82 FOR NEW AD PACKAGE
!
!     REV: 6/15/78
!
!     INPUT : PTE, NUCZ, NSPC
!     OUTPUT : RADBRM
!
!     COMPUTE BREMSSTRAHLUNG RADIATION RADBRM(JQ) (JOULE/SEC)
!     FOR EACH IONIC SPECIES JQ = (IONIC CHARGE + 1).
!
!     REFERENCES:
!     1) POST ET AL. PPPL-1352 (CORRECTED)
!     2) KARZAS AND LATTER
!     3) TUCKER
!
!
  use iso_c_binding, only: fp => c_double
  use adpak_mod
  save
  real(fp) :: PTE, PNE,ZTE,ZGFF,ZCHG
  integer JQ
!
!
  ZTE = PTE
!
!     USE FIXED FREE-FREE GAUNT FACTOR ZGFF = 1.2
!
  ZGFF = 1.2_fp
!
  DO JQ = 1 , NSPC
     ZCHG = DBLE(JQ - 1)
     RADBRM(JQ) = PNE * 4.85E-31_fp * ZCHG * ZCHG * SQRT(ZTE) * ZGFF
  enddo
!
  RETURN
END SUBROUTINE ADBREM
real(fp) FUNCTION EXPE1(PX)
!
!     REV: 6/15/78
!
!     CALCULATE EXP(PX) * E1(PX), WHERE THE EXPONENTIAL INTEGRAL
!     E1(X) = INTEGRAL FROM X TO INFINITY OF (EXP(-T)/T)DT.
!
!     REFERENCE: 'HANDBOOK OF MATHEMATICAL FUNCTIONS', ABRAMOWITZ
!     AND STEGUN, NATIONAL BUREAU OF STANDARDS
!
  use iso_c_binding, only: fp => c_double
  implicit NONE
  save
  real(fp) :: PX
  IF(PX.GE.1._fp)GO TO 2
  IF(PX.GT.1.E-4_fp)GO TO 1
!
  EXPE1 = DEXP(PX) * ( - DLOG(PX) - .57721566_fp + PX )
  RETURN
!
!
1 EXPE1 = DEXP(PX) * ( - DLOG(PX) - .57721566_fp + .99999193_fp*PX&
       - .24991055_fp*PX**2 + .05519968_fp*PX**3 &
       - .00976004_fp*PX**4 + .00107857_fp*PX**5 )
!
  RETURN
!
!
2 EXPE1 = (PX + 2.334733_fp  + .250621_fp/PX) /&
       (PX**2 + 3.330657_fp*PX + 1.681534_fp)
!
  RETURN
END FUNCTION EXPE1
!
!
!********************************************************************
!
!
real(fp) FUNCTION EXPUND(PX,PCHK)
!
!     REV: 6/15/78
!
!     PREVENT UNDERFLOWS IN RATE CALCULATIONS BY RETURNING
!     0. FOR EXP(PX) IF PX < PCHK.
!
  use iso_c_binding, only: fp => c_double
  implicit NONE
  save
  real(fp) :: PX,PCHK
  IF( PX - PCHK ) 1 , 1 , 2
1 EXPUND = 0._fp
  RETURN
!
2 EXPUND = DEXP(PX)
  RETURN
!
END FUNCTION EXPUND
SUBROUTINE ADBCXR(PNNEUT, PVNEUT, KNCXB, KCXOPT, KERR, KVUNIT)
!
!     REV: 10/10/82 FOR NEW AD PACKAGE
!
!     REV: 7/24/79; ZERO RADBCX BEFORE KNCXB=0 TEST & RETURN
!     REV: 5/10/79; ADD RADIATION DUE TO BEAM CHARGE EXCHANGE VIA
!                   RADBCX AND BEQRAD
!
!     COMPUTE RECOMBINATION RATE DUE TO CHARGE EXCHANGE WITH NEUTRAL
!     BEAM IONS.
!
!          NPSC = NUMBER OF IMPURITY SPECIES (NUCLEAR Z + 1)
!
!          PNNEUT = ARRAY OF ANGULAR AVERAGED NEUTRAL DENSITIES FOR
!                   EACH BEAM ENERGY COMPONENT
!          PVNEUT = ARRAY OF VELOCITIES FOR EACH BEAM COMPONENT (CM/S)
!          KNCXB = NUMBER OF ENERGY COMPONENTS IN THE BEAM
!                 (KNCXB = 0 TURNS OFF RCXREC)
!          KCXOPT = 1, 2, OR 3 TO SELECT CROSS-SECTIONS TO BE USED
!          RCXREC = ARRAY OF CHARGE EXCHANGE RECOMBINATION RATES FOR
!                   EACH SPECIES, SEC-1 UNITS (E.G. RATE PER ION)
!          KERR = ERROR FLAG FROM ADCXXS ROUTINE (0 = O.K.)
!          RADBCX = RADIATION RATE DUE TO CASCADE AFTER
!                   CHARGE EXCHANGE TO EXCITED LEVEL (WATTS / ION)
!
!
  use iso_c_binding, only: fp => c_double
  use adpak_mod
  save
!
  real(fp) :: PNNEUT(*), PVNEUT(*)
  real(fp) :: ZSIGMA(100)
  integer KNCXB, KCXOPT, KERR, KVUNIT,INSPC,JSPC,JB,ITEMP
  real(fp) :: ZJLKEV,ZVCMS,ZNFLUX
!
  ZJLKEV = 1.602E-16_fp
!
  INSPC = NSPC
!
!     ZERO RATE ARRAYS FOR ACCUMULATION OF CONTRIBUTIONS FROM EACH BEAM
!     COMPONENT
!
  RCXREC(1:100) = 0._fp
  RADBCX(1:100) = 0._fp
!
!     KNCXB = 0 OR KCXOPT = 0 TO TURN OFF C-X RECOMBINATION
!
  IF(KNCXB .EQ. 0 .OR. KCXOPT .EQ. 0) RETURN
!
!     OBTAIN CROSS-SECTIONS FOR EACH VELOCITY (ENERGY) COMPONENT
!     IN THE BEAM AND COMPUTE TOTAL RECOMBINATION RATE.
!
  DO JB = 1 , KNCXB
!
     CALL ADCXXS(PVNEUT(JB), KVUNIT, ZVCMS, ZSIGMA, INSPC,&
          KCXOPT, KERR)
     ZNFLUX = ZVCMS * PNNEUT(JB)
!
     DO JSPC = 2 , INSPC
        RCXREC(JSPC) = RCXREC(JSPC) + ZNFLUX * ZSIGMA(JSPC)
     enddo
  enddo
!
  DO JSPC = 2 , INSPC
     ITEMP = NVALNC(JSPC-1)
     RADBCX(JSPC) = ZJLKEV * EN(JSPC,ITEMP) * RCXREC(JSPC)
  enddo
!
  RETURN
END SUBROUTINE ADBCXR
SUBROUTINE ADCXXS(PVEL, KVUNIT, PVCMS, PSIGMA, KNSPC,&
     KOPT, KERR)
!
!     REV: 10/10/82 FOR NEW AD PACKAGE
!
!     SUPPLIES CROSS-SECTIONS FOR CHARGE EXCHANGE BETWEEN NEUTRAL
!     HYDROGEN AND MULTI-CHARGED IONS.  THE VARIABLE KOPT ALLOWS
!     THE SELECTION OF RESULTS FROM ONE OF THE VARIOUS PUBLISHED
!     CALCULATIONS.
!
!     PVEL =  RELATIVE VELOCITY, UNITS AS SELECTED BY KVUNIT
!     KVUNIT = UNITS FLAG FOR INPUT VELOCITY
!                 1 = CM/SEC
!                 2 = KEV/AMU
!                 3 = ATOMIC UNITS
!     PSIGMA = ARRAY OF CROSS-SECTION VALUES RETURNED, CM**2.
!              PSIGMA(I) = CROSS-SECTION FOR ION WITH CHARGE = I-1,
!              FOR 2 <= I <= KNSPC
!     KNSPC = HIGHEST SPECIES NUMBER, = MAX Z + 1
!     KOPT = SWITCH FOR DIFFERENT RESULTS, AS FOLLOWS:
!            1 = OLSON & SALOP, PHYS. REV. A 14, 579 (1976)
!                (ABSORBING SPHERE, V <= 1.E08 CM/SEC)
!            2 = GROZDANOV & JANEV, PHYS. REV. A 17, 880 (1978)
!                (TUNNELING, 2.E06 <= V <= 8.E08 CM/SEC)
!            3 = OLSON & SALOP, PHYS. REV. A 16, 531 (1977)
!                (CLASSICAL, (2 - 7)E08 CM/SEC)
!     KERR = ERROR FLAG. 0 = O.K., <0 = INVALID INPUT, OTHERS IN TEXT
!
!*********************************************************************
!
  use iso_c_binding, only: fp => c_double
  implicit NONE
  save
  real(fp), PARAMETER :: xpi =  3.1415926535897931_fp
  real(fp) :: PSIGMA(*)
!
  real(fp) :: ZFITV(4)  = (/ 2.7E08_fp, 3.0E08_fp, 4.0E08_fp, &
       5.0E08_fp/)
  real(fp) :: ZFITLT(4) = (/1.220988_fp, 1.277249_fp, 1.868400_fp, &
       2.575095_fp/)
  real(fp) :: ZFITGT(4) = (/1.000000_fp, 1.050777_fp, 1.221593_fp, &
       1.668531_fp/)
  real(fp) :: PVEL,PVCMS
  integer KVUNIT,KNSPC,KOPT, KERR,JSPC,ICOUNT,IX,IXP1
  real(fp) :: ZVCMS,ZVKEVM,ZVAU,ZCHG,ZL,ZC,ZR,ZFR,ZSLOPE,Z0,Z3V,&
       ZSIG8,ZALT,ZAGT,ZDIV8
!
!---------------------------------------------------------------------
!
  KERR = 0
!
!     CONVERT INPUT VELOCITY PARAMETER
!
  IF(KVUNIT .NE. 1) GO TO 2
  ZVCMS = PVEL
  ZVKEVM = (ZVCMS / 4.39E07_fp)**2
  ZVAU = ZVCMS / 2.19E08_fp
  GO TO 5
!
2 IF(KVUNIT .NE. 2) GO TO 3
  ZVKEVM = PVEL
  ZVCMS = 4.39E07_fp * SQRT(ZVKEVM)
  ZVAU = ZVCMS / 2.19E08_fp
  GO TO 5
!
3 IF(KVUNIT .NE. 3) GO TO 4
  ZVAU = PVEL
  ZVCMS = 2.19E08_fp * ZVAU
  ZVKEVM = (ZVCMS / 4.39E07_fp)**2
  GO TO 5
!
4 KERR = - 1
  RETURN
!
!     RETURN VELOCITY IN CM/S UNITS
!
5 PVCMS = ZVCMS
!
!     NEUTRAL SPECIES CROSS-SECTION = 0
!
  PSIGMA(1) = 0._fp
!
  GO TO (100, 200, 300), KOPT
  KERR = -2
  RETURN
!
!--------------------------------------------------------------------
!     
!     KOPT = 1 ; OLSON & SALOP LOW - V ABSORBING SPHERE
!     NOMINALLY VALID ONLY FOR V < 1.0E08 CM/SEC
!
100 DO JSPC = 3 , KNSPC
!
!W    WRITE(LADPOUT,198)JSPC
!W  198 FORMAT(1X,/,'JSPC =',I3)
!
     ZCHG = DBLE(JSPC - 1)
     ZL = 2.648_fp / SQRT(ZCHG)
     ZC = 2.864E-04_fp * ZCHG * (ZCHG - 1._fp) * ZVAU
     IF(ZC .LT. .541341133_fp/(ZL**2) ) GO TO 102
     KERR = 1
     RETURN
!
!     ITERATIVE SOLUTION TO EQUATION (10)
!
!     (FIRST GUESS, FROM LINEAR FIT TO FIG. 3)
!
102  ZR = 9._fp + 11._fp * ZCHG / 45._fp
     ZR = - DLOG( ZC / (ZR**2) ) / ZL
     ZFR = ZR * ZR * DEXP(- ZL * ZR)
     ICOUNT = 0
!
105  IF(ZR .LT. 2._fp/ZL) GO TO 180
     IF(ICOUNT .GT. 100) GO TO 181
     ICOUNT = ICOUNT + 1
!
!W    WRITE(LADPOUT,199)ZR
199  FORMAT(1X,'ZR=',F10.2)
!
     ZR = ZR + (ZC/ZFR - 1._fp) / (2._fp/ZR - ZL)
     ZFR = ZR * ZR * DEXP (- ZL * ZR)
!
     IF( ABS(ZFR - ZC)/ZC .GE. .001_fp) GO TO 105
!
!     ITERATION COMPLETE TO 0.1% IN VELOCITY; COMPUTE SIGMA
!
     PSIGMA(JSPC) = xpi * (0.529E-08_fp * ZR)**2
  enddo
!     FILL IN Z = 1 CROSS SECTION WITH Z = 2 VALUE
!
  PSIGMA(2) = PSIGMA(3)
  RETURN
!
180 KERR = 2
  RETURN
181 KERR = 3
  RETURN
!
!----------------------------------------------------------------
!
!     KOPT = 2; GROZDANOV & JANEV
!     RESULTS SHOWN ONLY FOR Z = 10, 20, AND 30, 2.E06 < V < 8.E08
!     CM/SEC; ALL OTHER POINTS BY INTERPOLATION OR EXTRAPOLATION
!
200 DO JSPC = 2 , KNSPC
     ZCHG = DBLE(JSPC - 1)
!
!     EMPIRICAL FIT TO FIGURE 3, CENTERED AT V = 2.0E08 CM/SEC
!
     ZSLOPE = - (.25_fp + .04_fp * ZCHG) * 1.0E-14_fp
     Z0 = .11_fp * ZCHG * 1.0E-14_fp
     PSIGMA(JSPC) = DMAX1(0._fp, Z0 + ZSLOPE * DLOG10(ZVCMS/2.E08_fp))
!
  enddo
  RETURN
!
!----------------------------------------------------------------------
!
!
!     KOPT = 3 ; OLSON & SALOP CLASSICAL TRAJECTORY.  USES A
!     POWER LAW FIT TO FIG. 1 AT 4 VELOCITIES IN THE RANGE
!     2.7E08 < V < 5.E08 CM/SEC.  INPUT VELOCITIES OUTSIDE THIS
!     RANGE YIELD DATA FOR THE APPROPRIATE LIMITING VELOCITY.  THE
!     LAST GIVEN DATA CURVE IS FOR Z=36, HENCE DATA FOR Z>36
!     REPRESENTS AN EXTRAPOLATION.
!
300 CONTINUE
  Z3V = DMAX1(2.7E08_fp, ZVCMS)
  Z3V = DMIN1(5.0E08_fp, Z3V)
!
  IX = IDINT(Z3V/1.E08_fp) - 1
  IF(IX .GT. 3) IX = 3
  IXP1 = IX + 1
!
!     USE LINEAR FIT TO Z=8 CURVE TO FIND X-SECTION FOR Z=8 AT GIVEN
!     VELOCITY
!
  ZSIG8 = 7.43E-15_fp - 1.26E-23_fp * Z3V
!
!     INTERPOLATE TO FIND POWER LAW EXPONENTS FOR THIS VELOCITY; ONE
!     FOR Z<8, THE OTHER FOR Z>8.
!
  ZALT = ZFITLT(IX) + (ZFITLT(IXP1) - ZFITLT(IX)) *&
       ( (Z3V-ZFITV(IX)) / (ZFITV(IXP1) - ZFITV(IX)) )
  ZAGT = ZFITGT(IX) + (ZFITGT(IXP1) - ZFITGT(IX)) *&
       ( (Z3V-ZFITV(IX)) / (ZFITV(IXP1)-ZFITV(IX)) )
!
!     FIT PARAMETERS FOUND FOR THIS VELOCITY; COMPUTE X-SECTIONS
!
  DO JSPC = 2 , KNSPC
     ZDIV8 = DBLE(JSPC - 1) / 8._fp
     IF(ZDIV8 .GE. 1._fp) GO TO 310
     PSIGMA(JSPC) = ZSIG8 * ZDIV8**ZALT
     cycle
310  PSIGMA(JSPC) = ZSIG8 * ZDIV8**ZAGT
  enddo
!
  RETURN
!
!---------------------------------------------------------------------
!
END SUBROUTINE ADCXXS
