!====================
!
!  09/28/94  TBT  Added capabilities for Li to HE and H.
!
!  D. MC CUNE 2 JUNE 1981
!    THIS VERSION OF FRANTIC FOR USE WITH TRANSP *****
!
!  DMC OCT 1988 -- USE TRANSP STANDARD SIGMA*V ROUTINES
!
!    FRANTIC IS 2 SPECIES GENERALIZED FAST NEUTRAL TRANSPORT
!  ALGORITHM BASED ON 1 SPECIES ALGORITHM BY S. TAMOR, GENERALIZED
!  BY HH TOWNER AT PPPL.
!    CONVERTED FOR USE WITH TRANSP BY D. MC CUNE.
!    (1)  VARIABLE NAMES OLYMPUSIZED:  ALL LOCAL VARIABLES BEGIN
!    WITH Z (REAL) OR I OR J (integer).
!    (2)  NEUTRAL ESCAPE COEFFICIENTS AND AVG ESCAPING NEUTRALS'
!         ENERGIES ARE DEFINED IN TRANSP COMMON ARRAYS
!         OUTFLX(JG,NSRC), EESCAV(JG,NSRC); JG=NEUTRAL HYDROGENIC
!         SPECIES, NSRC= NEUTRAL SOURCE NUMBER.
!      >>THE CALCULATION IS VALID ONLY if MODELING
!         ONE SPECIES AND TYPE OF NEUTRAL SOURCE
!         AT A TIME, AND EDGE OR VOLUME BUT NOT BOTH TYPE
!         SOURCES SIMULTANEOUSLY.  THIS RESTRICTION APPLIES
!         FOR RENORMALIZATION OF OUTFLX, EESCAV, AND RADIAL
!         IN/OUT FLUX ARRAYS TO BE VALID ********
!=======================================
! SO >> USE THIS VERSION WITH [TRANSP]SORCE1.FOR AS CALLING ROUTINE
!=======================================
!    (3)  THE PTCL OUTFLUX CALCULATION IS GENERALIZED TO ALLOW
!         CALCULATION OF NEUTRAL PTCL AND ENERGY IN/OUT FLUXES
!         AT ALL RADIAL ZONE BOUNDARIES.  THE CORRESPONDING
!         FRANTIC-INTERNAL PROBABILITY ARRAYS ARE PRWFLX(J,IK,IDIR)
!         WHICH INDICATES THE PROBABILITY THAT A SPECIES IK WALL
!         NEUTRAL CONTRIBUTES TO THE FLUX BETWEEN ZONES J,J+1 IN
!         DIRECTION IDIR=1:INFLUX, OR IDIR=2:OUTFLUX
!            AND PRFLUX(I,J,IK,IDIR) INDICATES THE PROBABILITY
!         THAT A NEUTRAL SPECIE IK BORN IN ZONE I WILL CONTRIBUTE
!         TO THE DIRECTION IDIR NEUTRAL FLUX AT THE BDY. BETWEEN
!         ZONES J AND J+1, IDIR AS WITH PRWFLX ARRAY.
!            FROM THESE QUANTITIES THE TRANSP DIVERGENCE-OF IN/OUT
!         PTCL/ENERGY NEUTRAL FLUX ARRAYS SFLX0M,PFLX0M(IDIR,J,NSRC)
!         ARE CALCULATED; NOTE THESE ARE SUMMED OVER ALL NEUTRAL
!         SPECIES.
!                      ... D. MC CUNE 2 JUNE 1981
!
!
subroutine frantic_alpha
  !
  !  AUG 1986 - MOD DMC
  !  INCLUDE DifFERENCE IN ROTATION VELOCITY AS PART OF INTERACTION
  !  ENERGY FOR COLLISIONS-- FOR ROTATION SUPPORTING VSN OF FRANTIC
  !
  !  THIS subroutine WAS WRITTEN BY HARRY H. TOWNER OF THE PRINCETON
  !  PLASMA PHYSICS LAB.  THIS ROUTINE WILL CALCULATE THE FOLLOWING:
  !  ALPHAX(I,J,NL,K) - CHARGE EXCHANGE ABSORPTION COEFFICIENT IN ZONE I
  !                  FOR HYDROGENIC NEUTRAL SPECIE K BORN IN ZONE J
  !		   CREATING HYDROGENIC NEUTRAL SPECIES NL IN
  !		   ZONE I.
  !  ALPHAT(I,J,K) - TOTAL ABSORPTION COEFFICIENT IN ZONE I FOR
  !                  HYDROGENIC NEUTRAL SPECIE K BORN IN ZONE J
  !		   INTERACTING WITH ALL CHARGED SPECIES IN ZONE I.
  !  BETAX(I,NL,K)    - CHARGE EXCHANGE ABSORPTION COEFFICIENT IN ZONE I
  !                  FOR HYDROGENIC NEUTRAL SPECIES K BORN AT THE WALL
  !                  CREATING HYDROGENIC NEUTRAL SPECIES NL IN
  !                  ZONE I.
  !  BETAT(I,K)    - TOTAL ABSORPTION COEFFICIENT IN ZONE I FOR
  !                  HYDROGENIC NEUTRAL SPECIE K BORN AT THE WALL
  !		   INTERACTING WITH ALL CHARGED SPECIES IN ZONE I.
  !
  !
  use iso_c_binding, only: fp => c_double
  use fpreact_parameters
  use frantic_module
  use adas_mod, only : adas_zstop_sigvz, adas_sigv, &
       adas_sigvte_ioniz
  implicit none
  real(fp), parameter :: C10TH = 0.1_fp
  real(fp), parameter :: C20TH = 0.05_fp
  real(fp), parameter :: C3OV2 = 1.5_fp
  !
  integer :: ik,izneut,i,ink,il,ilm1,izplas,j,inl,ierr
  real(fp) :: zdsvel,ztskz,ztska,zewall,zvwall,ztsla
  real(fp) :: ztslz,zeborn,zecl,zvborn,zvphij,zvphil,zerelw
  real(fp), dimension(:), allocatable :: zeova
  real(fp), dimension(:,:), allocatable :: z_erel,zsigv,zsigv_cx
  real(fp) :: ztswbi,ztswbx,zec,zvphii,zdvphi
  real(fp) :: ztsmbi,ztsmbx,zvphi_wall
  logical :: il_li ! .true. if Li is a neutral

  !============
  !xxx      DIMENSION ZDSVEL(MJ,MIG)
  !
  !xxx      EQUIVALENCE (ZDSVEL(1,1),TSTOR1(1,1))
  !
  real(fp), parameter :: zcon1 = 1.929691e15_fp

  !  CON1= 2*C*C/(KEV/AMU)
  !
  !  I NOW FILL TEMPORARY STORAGE ARRAY TSTOR1 WITH DENE*<SIGMA*V>EL
  !  AT ALL ZONE LOCATIONS.
  if(allocated(zeova)) deallocate(zeova)
  allocate(zeova(nzonec))
  zeova=0.0_fp

  if(MCFLAG) then

    if(allocated(zsigv)) deallocate(zsigv)
    allocate(zsigv(nzonec,nzonec))
    zsigv=0.0_fp

    if(allocated(zsigv_cx)) deallocate(zsigv_cx)
    allocate(zsigv_cx(nzonec,nzonec))
    zsigv_cx=0.0_fp

    if(allocated(z_erel)) deallocate(z_erel)
    allocate(z_erel(nzonec,nzonec))
    z_erel=0.0_fp
  else
    if(allocated(zsigv)) deallocate(zsigv)
    allocate(zsigv(1,nzonec))
    zsigv=0.0_fp

    if(allocated(zsigv_cx)) deallocate(zsigv_cx)
    allocate(zsigv_cx(1,nzonec))
    zsigv_cx=0.0_fp

  end if

  do IK=1,NNEUT
    ZTSKZ=XZPLAS(NSPEC(IK))
    izneut=ztskz+C20TH
    if((FRANTIC_ATOMIC.eq.1).or.(FRANTIC_ATOMIC.eq.3)) then !PREACT ground state atomic physics
      call sigvte_ioniz(izneut,temp(1:NZONEC,1),NZONEC, &
           zsigv(1,1:nzonec))
    elseif((FRANTIC_ATOMIC.eq.2).or.(FRANTIC_ATOMIC.eq.4)) then
      call adas_sigvte_ioniz(izneut,temp(1:NZONEC,1),NZONEC, &
           zsigv(1,1:nzonec),ierr)
    end if
    TSTOR1(1:NZONEC,IK)=DEN(1:NZONEC,1)*1.0e6_fp* &
         zsigv(1,1:NZONEC)
  end do

  !
  !  I NOW LOOP OVER THE DIFFERENT NEUTRAL SPECIES.
  do IK=1,NNEUT
    !  I NOW DEFINE THE MASS, Z, AND WALL VELOCITY FOR THIS NEUTRAL SPECIES.
    INK=NSPEC(IK)
    ZTSKA=APLAS(INK)
    ZTSKZ=XZPLAS(INK)
    izneut=ztskz+C10TH
    !  CHECK TO SEE if NEUTRAL IS HYDROGEN OR HELIUM  or Lithium
    il_li=.false.
    if(izneut.gt.3) go to 90
    if((izneut.eq.3).and.((frantic_atomic.eq.2).or. &
         (frantic_atomic.eq.4)))then
      !     ADAS atomic physics does not support Li
      WRITE(LUN6,101) IK
101   FORMAT(T2, &
           ' !FRANTIC_ALPHA: ADAS dataset does not support Li', &
           ' NEUTRAL SPECIES ',I2, &
           ' IS NOT AN ISOTOPE OF HYDROGEN OR HELIUM.', &
           ' PREACT WILL BE USED FOR Li')
      il_li=.true.
    end if
    ZEWALL=C3OV2*TWALL(IK)
    ZVWALL=SQRT(ZCON1*ZEWALL/ZTSKA)
    zvphi_wall=vphi_wall(ik)
    !  I NOW LOOP OVER ALL SPECIES WHICH THIS NEUTRAL CAN INTERACT WITH.
    do IL=2,NPLAS
      ILM1=IL-1
      ZTSLA=APLAS(IL)
      ZTSLZ=XZPLAS(IL)
      izplas=ztslz+C10TH
      !  I NOW LOOP OVER THE BIRTH ZONES OF THE MULTI-GENERATION NEUTRALS.
      !  NOTE THAT THIS SAME LOOP WILL BE USED AS DEATH ZONES FOR WALL
      !  NEUTRALS.
      do J=1,NZONEC
        !  I NOW FIND THE ENERGY AND VELOCITY OF THE BIRTH NEUTRAL.
        ZEBORN=C3OV2*TEMP(J,INK)
        ZECL=C3OV2*TEMP(J,IL)
        ZVBORN=SQRT(ZCON1*ZEBORN/ZTSKA)
        !AUG86  ROTATION VELOCITY OF NEUTRAL SPECIE K, ZONE J
        ZVPHIJ=VPHIZ(J,INK)
        !  I NOW FIND THE CREATED NEUTRAL'S INDEX.
        INL=LISPEC(ILM1)
        if(.NOT.ESFLAG) GO TO 30
        !  I NOW FIND THE RELATIVE ENERGY AND VELOCITY BETWEEN A WALL NEUTRAL
        !  OF SPECIES K AND AN ION OF SPECIE L AT LOCATION J.
        !AUG86  INCLUDE ROTATION IN REL. ENERGY
        ZVPHIL=VPHIZ(J,IL)
        if(lzpflag.and.(izplas.gt.3)) then
          ZTSLA=aimpj(j)           ! dmc Nov 2002: A(r) profiles
        end if
        zdvphi=zvphil-zvphi_wall
        ZERELW=ZEWALL+ZTSKA*ZECL/ZTSLA+ZTSKA*ZdVPHI**2/ZCON1
        !  I NOW FIND (SIGMA)LOSS AND (SIGMA)CX FOR THE WALL NEUTRAL
        !  INTERACTING AT ZONE J
        zeova(j)=ZERELW/ZTSKA
30      if(.NOT.MCFLAG) GO TO 60
        do I=1,NZONEC
          !  I NOW FIND THE ENERGY OF THE ION IN THIS ZONE AND CALCULATE
          !  THE RELATIVE ENERGY AND VELOCITY BETWEEN THIS ION AND THE
          !  NEUTRAL FROM ZONE J.
          ZEC=C3OV2*TEMP(I,IL)
          !AUG86 INCLUDE ROTATION
          ZVPHII=VPHIZ(I,IL)
          ZDVPHI=ZVPHII-ZVPHIJ
          if(lzpflag.and.(izplas.gt.3)) then
            ZTSLA=aimpj(i)         ! dmc Nov 2002: A(r) profiles
          end if
          !  I NOW FIND (SIGMA)LOSS AND (SIGMA)CX FOR THE NEUTRAL
          !  BORN IN ZONE J INTERACTING WITH THE IONS IN ZONE I.
          z_erel(j,i)=(ZEBORN+ZTSKA*ZEC/ZTSLA+ZTSKA*ZDVPHI**2/ZCON1) &
               /ZTSKA
50        continue
        end do
60      continue
      end do

      if(.NOT.ESFLAG) GO TO 31

      if(izplas.le.3) then
        if((FRANTIC_ATOMIC.eq.1).or.(FRANTIC_ATOMIC.eq.3).or.il_li) &
             then          !PREACT ground state atomic physics
          call hatom_sigv(fpreact_CX,zeova,nzonec,izneut,izplas, &
               zsigv_cx(1,1:nzonec),ierr)
          call hatom_sigv(fpreact_II,zeova,nzonec,izneut,izplas, &
               zsigv(1,1:nzonec),ierr)

        elseif((FRANTIC_ATOMIC.eq.2.and..not.il_li).or. &
             (FRANTIC_ATOMIC.eq.4.and..not.il_li)) then !ADAS ground state atomic physics

          call adas_sigv(fpreact_CX,zeova,nzonec,izneut,izplas, &
               zsigv_cx(1,1:nzonec),ierr)
          if(ierr.eq.10) then
            write(LUN6,*) &
                 ' ?FRANTIC_ALPHA: ADAS data is requested but not found'

            call frantic_dealloc
            call bad_exit
          end if
          call adas_sigv(fpreact_II,zeova,nzonec,izneut,izplas, &
               zsigv(1,1:nzonec),ierr)

          if(ierr.eq.10) then
            write(LUN6,*) &
                 ' ?FRANTIC_ALPHA: ADAS data is requested but not found'

            call frantic_dealloc
            call bad_exit
          end if
        end if
        zsigv(1,1:nzonec)=zsigv_cx(1,1:nzonec)+zsigv(1,1:nzonec)
      else
        if(lzpflag) then
          do j=1,nzonec
            ztslz=xzimpj(j)
            if((FRANTIC_ATOMIC.eq.1).or.(FRANTIC_ATOMIC.eq.4).or.il_li) &
                 then    !PREACT impurity stopping rates
              call zstop_sigvz(izneut,ztslz, &
                   zeova(j),1,zsigv(1,j))
            elseif((FRANTIC_ATOMIC.eq.2.and..not.il_li).or. &
                 (FRANTIC_ATOMIC.eq.3.and..not.il_li)) then
              call adas_zstop_sigvz(izneut,ztslz, &
                   zeova(j:j),1,zsigv(1,j:j),ierr)
              if(ierr.eq.10) then
                write(LUN6,*) &
                     ' ?FRANTIC_ALPHA: ADAS data is requested but not found'

                call frantic_dealloc
                call bad_exit
              end if
            end if
          end do
        else
          if((FRANTIC_ATOMIC.eq.1).or.(FRANTIC_ATOMIC.eq.4).or. &
               il_li) then !PREACT impurity stopping rates
            call zstop_sigvz(izneut,ztslz, &
                 zeova,nzonec,zsigv(1,1:nzonec))
          elseif((FRANTIC_ATOMIC.eq.2.and..not.il_li).or. &
               (FRANTIC_ATOMIC.eq.3.and..not.il_li)) then
            call adas_zstop_sigvz(izneut,ztslz, &
                 zeova,nzonec,zsigv(1,1:nzonec),ierr)
            if(ierr.eq.10) then
              write(LUN6,*) &
                   ' ?FRANTIC_ALPHA: ADAS data is requested but not found'

              call frantic_dealloc
              call bad_exit
            end if
          end if
        end if
      end if
      if(izplas.gt.3) go to 20
      !  WE CAN CHARGE EXCHANGE OFF A HYDROGEN OR HELIUM SPECIE.
      !  I NOW CHECK if THIS IS AN ALLOWED NEUTRAL.
      if(INL.EQ.0) GO TO 20
      BETAX(1:nzonec,INL,IK)=DEN(1:nzonec,il)*1.0e6_fp* &
           zsigv_cx(1,1:nzonec)/ZVWALL
20    if(IL.EQ.2) then
        BETAT(1:NZONEC,IK)=(TSTOR1(1:NZONEC,IK)+BII(1:NZONEC,IK)+ &
             BCX(1:NZONEC,IK))/ZVWALL
      end if
      BETAT(1:NZONEC,IK)=DEN(1:NZONEC,il)*1.0e6_fp* &
           zsigv(1,1:NZONEC)/ZVWALL+BETAT(1:NZONEC,IK)
      !     I NOW LOOP OVER ALL INTERACTION ZONES.
31    if(MCFLAG) then
        do j=1,nzonec
          if(izplas.le.3) then
            if((FRANTIC_ATOMIC.eq.1).or.(FRANTIC_ATOMIC.eq.3) &
                 .or.il_li) &
                 then    !PREACT ground state atomic physics
              call hatom_sigv(fpreact_CX,z_erel(j,1:NZONEC), &
                   nzonec,izneut,izplas,zsigv_cx(j,1:NZONEC), &
                   ierr)
              call hatom_sigv(fpreact_II,z_erel(j,1:NZONEC), &
                   nzonec,izneut,izplas,zsigv(j,1:NZONEC),ierr)
            elseif((FRANTIC_ATOMIC.eq.2.and..not.il_li).or. &
                 (FRANTIC_ATOMIC.eq.4.and..not.il_li) &
                 )then !ADAS ground state atomic physics
              call adas_sigv(fpreact_CX,z_erel(j,1:NZONEC), &
                   nzonec,izneut,izplas,zsigv_cx(j,1:NZONEC),ierr)

              if(ierr.eq.10) then
                write(LUN6,*) &
                     ' ?FRANTIC_ALPHA: ADAS data is requested but not found'
                call frantic_dealloc
                call bad_exit
              end if
              call adas_sigv(fpreact_II,z_erel(j,1:NZONEC), &
                   nzonec,izneut,izplas,zsigv(j,1:NZONEC),ierr)

              if(ierr.eq.10) then
                write(LUN6,*) &
                     ' ?FRANTIC_ALPHA: ADAS data is requested but not found'

                call frantic_dealloc
                call bad_exit
              end if
            end if
            zsigv(j,1:NZONEC)=zsigv_cx(j,1:NZONEC)+zsigv(j,1:NZONEC)
          else
            if(lzpflag)then
              do i=1,nzonec
                ztslz=xzimpj(i)
                if((FRANTIC_ATOMIC.eq.1).or.(FRANTIC_ATOMIC.eq. &
                     4).or.il_li) then !PREACT impurity stopping rates
                  call zstop_sigvz(izneut,ztslz, &
                       z_erel(j,I),1,zsigv(j,I))
                elseif((FRANTIC_ATOMIC.eq.2.and..not.il_li).or. &
                     (FRANTIC_ATOMIC.eq.3.and..not.il_li)) then
                  call adas_zstop_sigvz(izneut,ztslz, &
                       z_erel(j,I:I),1,zsigv(j,I:I),ierr)
                  if(ierr.eq.10) then
                    write(LUN6,*) &
                         ' ?FRANTIC_ALPHA: ADAS data is requested but not found'
                    call frantic_dealloc
                    call bad_exit
                  end if
                end if
              end do
            else
              if((FRANTIC_ATOMIC.eq.1).or.(FRANTIC_ATOMIC.eq.4).or.il_li) &
                   then !PREACT impurity stopping rates
                call zstop_sigvz(izneut,ztslz, &
                     z_erel(j,1:NZONEC),nzonec, &
                     zsigv(j,1:NZONEC))
              elseif((FRANTIC_ATOMIC.eq.2.and..not.il_li).or. &
                   (FRANTIC_ATOMIC.eq.3.and..not.il_li))then
                call adas_zstop_sigvz(izneut,ztslz, &
                     z_erel(j,1:NZONEC),nzonec, &
                     zsigv(j,1:NZONEC),ierr)
                if(ierr.eq.10) then
                  write(LUN6,*) &
                       ' ?FRANTIC_ALPHA: ADAS data is requested but not found'
                  call frantic_dealloc
                  call bad_exit
                end if
              end if
            end if
          end if
          if(izplas.gt.3) go to 40
          !  WE CAN CHARGE EXCHANGE OFF OF HYDROGEN OR HELIUM.
          if(INL.EQ.0) GO TO 40
          ALPHAX(1:NZONEC,J,INL,IK)=DEN(1:NZONEC,IL)*1.0e6_fp* &
               zsigv_cx(j,1:NZONEC)/ &
               SQRT(ZCON1*C3OV2*TEMP(J,INK)/ZTSKA)
40        if(IL.EQ.2) then
            ALPHAT(1:NZONEC,J,IK)=(TSTOR1(1:NZONEC,IK)+ &
                 BII(1:NZONEC,IK)+BCX(1:NZONEC,IK))/ &
                 SQRT(ZCON1*C3OV2*TEMP(J,INK)/ZTSKA)
          end if
          ALPHAT(1:NZONEC,J,IK)=DEN(1:NZONEC,il)*1.0e6_fp* &
               zsigv(j,1:NZONEC)/ &
               SQRT(ZCON1*C3OV2*TEMP(J,INK)/ZTSKA) &
               +ALPHAT(1:NZONEC,J,IK)
        end do
      end if

    end do
  end do

  call frantic_dealloc
  return
  !----------------------------------------------------------------------
90 WRITE(LUN6,100) IK
100 FORMAT(T2, &
       'NEUTRAL SPECIES ',I2,' IS NOT AN ISOTOPE OF HYDROGEN OR HELIUM', &
       ' or Lithium' )

  call frantic_dealloc
  CALL BAD_EXIT

contains

  subroutine frantic_dealloc
    if(allocated(zeova)) deallocate(zeova)
    if(allocated(z_erel)) deallocate(z_erel)
    if(allocated(zsigv)) deallocate(zsigv)
    if(allocated(zsigv_cx)) deallocate(zsigv_cx)
    return
  end subroutine frantic_dealloc

end subroutine frantic_alpha
