subroutine frantic_gmat
  !  THIS ROUTINE WAS WRITTEN BY HARRY H. TOWNER OF THE PRINCETON
  !  PLASMA PHYSICS LAB.  THIS ROUTINE WILL CALCULATE THE CHARGE
  !  EXCHANGE RATE IN EACH ZONE DUE TO NEUTRALS BORN IN ALL ZONES
  !  AND FROM THE WALL BY INTEGRATING ALONG EACH TRAJECTORY AND
  !  SUMMING OVER ALL TRAJECTORIES.
  !-------------------------------
  !
  !  TBT Jun, 1991  Added NINLDX as the pointer to the lightest gas in
  !                 BACKZ for this source.
  !
  !-----------------------------
  !
  !   T.B. Terpstra - Adding INDEX because of mixed H and He plasma.
  !   May 20, 1991
  !
  !   D. MC CUNE THIS ROUTINE MODifIED TO INCLUDE FLUX(R)
  !  CALCULATION
  !   JUNE 3 1981
  !
  use iso_c_binding, only: fp => c_double
  use physconst_mod, only: zero, two
  use frantic_module
  implicit none
  !
  integer :: izmid,ik,idirw,ishfw,i,iza,izf,idir,ishf,j,izb
  real(fp) :: zx,frantic_zh3x,zdeltr,zx1,zdisti,ztaub,zx2
  real(fp) :: zh3x1,zh3x2,ztaua,zts1,ztauc,zts2
  real(fp), parameter :: zpid2 = 1.570796327_fp
  !
  IZMID=NZCROS(MID)
  ZDELTR=RBOUND(IZMID+1)-RBOUND(IZMID)
  !  I NOW TRACK FROM LEFT TO RIGHT AND CALCULATE THE WALL FLUX
  !  WHICH CHARGE EXCHANGES IN ZONE I AND THE FRACTION WHICH GETS
  !  TRANSMITTED TO THE RIGHT.
  !
  !  IDIR(W)=1 INDICATES INGOING PTCL, IDIR(W)=2 INDICATES
  !   OUTGOING PTCL.  D. MC CUNE 3 JUNE 1981
  !
  do IK=1,NNEUT
    !  INITIALIZE FLUX(R) DUE TO 1ST. GEN. NEUTS. CALCULATION
    IDIRW=1
    ISHFW=-1
    !  INCOMING FLUX FROM WALL
    if(ESFLAG) PRWFLX(NZONEC,IK,IDIRW)= &
         PRWFLX(NZONEC,IK,IDIRW)+ZPID2*ZDELTR
    !
    ZX1=ZERO
    do I=1,NBCROS
      IZA=NZCROS(I)
      ZDISTI=DIST(I)
      if(.NOT.ESFLAG) GO TO 10
      ZTAUB=BETAT(IZA,IK)*ZDISTI
      ZX2=ZX1+ZTAUB
      !	    if(X2.GT.87.5E00) GO TO 10  !CHECK
      ZH3X1=ZH3(ZX1)
      ZH3X2=ZH3(ZX2)
      !CC  S0COLD(IZA,1,   IK)=S0COLD(IZA,1,   IK)+
      S0COLD(IZA,NINLDX,IK)=S0COLD(IZA,NINLDX,IK)+ &  ! TBT 5/20/91
           (ZH3X1-ZH3X2)*ZDELTR
      ZX1=ZX2
      !  CHECK FOR SWITCH FROM IN- TO OUT-GOING FLUX (WALL NEUTS ONLY)
      if(I.NE.MID) GO TO 5
      IDIRW=2
      ISHFW=0
5     continue
      !
      !  WALL NEUTS CONTRIBUTION TO FLUX(J)
      IZF=IZA+ISHFW
      PRWFLX(IZF,IK,IDIRW)=PRWFLX(IZF,IK,IDIRW)+ZH3X2*ZDELTR
      !
10    continue
      if(.NOT.MCFLAG) GO TO 40
      !  THE ATTENUATION IN ZONE IZA DUE TO ATOMS BORN IN THE
      !  SAME ZONE IS NOW FOUND.
      ZTAUA=ZDISTI*ALPHAT(IZA,IZA,IK)
      ZTS1=ZPID2-ZH3(ZTAUA)
      !CC GFUN(IZA,IZA,1,IK)= &
      !CC    GFUN(IZA,IZA,1,IK)+(2.0*ZTAUA-ZTS1)*ZDELTR
      GFUN(IZA,IZA,NINLDX,IK)= &
           GFUN(IZA,IZA,NINLDX,IK)+(TWO*ZTAUA-ZTS1)*ZDELTR   ! TBT 5/91
      if(I.EQ.NBCROS) GO TO 30
      !  THE ATTENUATION IN EACH ZONE IZB, TO THE RIGHT OF ZONE
      !  IZA, DUE TO ATOMS BORN IN ZONE IZA AND THE FRACTION TRANSMITTED
      !  TO THE NEXT ZONE IS NOW CALCULATED.
      ZTAUC=ZERO
      !  INITIALIZE FLUX CALCULATION FOR THIS PART OF TRAJECTORY
      IDIR=1
      ISHF=-1
      if(I.LT.MID) GO TO 15
      IDIR=2
      ISHF=0
15    continue
      IZF=IZA+ISHF
      PRFLUX(IZA,IZF,IK,IDIR)=PRFLUX(IZA,IZF,IK,IDIR)+ZTS1*ZDELTR
      !
      do J=I+1,NBCROS
        IZB=NZCROS(J)
        ZTAUC=ZTAUC+DIST(J)*ALPHAT(IZB,IZA,IK)
        ZTS2=ZH3(ZTAUC)-ZH3(ZTAUC+ZTAUA)
        !CCC GFUN(IZB,IZA,1,   IK)=GFUN(IZB,IZA,1,   IK)+
        GFUN(IZB,IZA,NINLDX,IK)=GFUN(IZB,IZA,NINLDX,IK)+ &   ! TBT 5/91
             (ZTS1-ZTS2)*ZDELTR
        ZTS1=ZTS2
        !  FLUX(R) CALCULATION
        if(J.NE.MID) GO TO 25
        IDIR=2
        ISHF=0
25      continue
        if(J.EQ.NBCROS) GO TO 20
        IZF=IZB+ISHF
        PRFLUX(IZA,IZF,IK,IDIR)=PRFLUX(IZA,IZF,IK,IDIR)+ &
             ZTS1*ZDELTR
20      continue
      end do
      !  ATOMS BORN IN IZA WHICH GET ALL THE WAY TO THE WALL.
30    WALL(IZA,IK)=WALL(IZA,IK)+ZTS1*ZDELTR
      PRFLUX(IZA,NZONEC,IK,2)=PRFLUX(IZA,NZONEC,IK,2)+ &
           ZTS1*ZDELTR
40    continue
    end do
    if(ESFLAG) WWALL(IK)=WWALL(IK)+ZH3X2*ZDELTR
  end do
  return

  contains

    ! DEFINE THE H3 FUNCTION
    real(fp) function zh3(zx)
      real(fp), intent(in) :: zx
      real(fp), external :: frantic_zh3x
      zh3 = frantic_zh3x(zx)
      return
    end function zh3

end subroutine frantic_gmat
