subroutine frantic_neuts(ierr)
  !
  !  THIS ROUTINE WAS WRITTEN BY HARRY H. TOWNER OF THE PRINCETON
  !  PLASMA PHYSICS LAB.  THIS ROUTINE WILL DETERMINE THE NEUTRAL
  !  DENSITY FOR MULTIPLE SPECIES. THE BASIC ALGORITHEM USED
  !  IS THAT DEVELOPED BY STEVE TAMOR IN HIS ANTIC CODE.
  
  !-------------------------------
  !
  !  TBT Jun, 1991  Added NINLDX as the pointer to the lightest gas in
  !                 BACKZ for this source.
  !-----------------------------
  !
  !  TBT May 1991 - Added INDX for H and He plasmas.
  !  DMC AUG 1986 - GEN. FOR ROTATION BALANCE
  !
  use iso_c_binding, only: fp => c_double
  use physconst_mod, only: zero
  use frantic_module
  implicit none
  !
  integer, intent(out) :: ierr   ! completion code (0=OK)
  real(fp), parameter :: C4TH = 0.25_fp
  real(fp), parameter :: CEPS4 = 1.0e-4_fp
  !
  integer :: inn1,ik,i,j,ip1,ineut,idir,jstart,inl,istart,j1,i1
  integer :: irow,jcol,il,ioff
  real(fp) :: zrpi,zrpi2,zr,zvlt,zvlm,zts,zsigv
  real(fp), dimension(MJ*MIG,MJ*MIG+1) :: zdd
  real(fp), dimension(MJ*MIG) :: zstor1
  real(fp), parameter :: zpi = 3.141592654_fp

  ierr=0
  if(.not.allocated(bii)) then
    write(lun6,*) ' ?FRANTIC: unallocated arrays detected.'
    write(lun6,*) '  call FRANTIC_SPECIES_ZA and ', &
         'FRANTIC_PROFILE_ALLOC first.'
    ierr=88
    return
  end if

  if(.not.allocated(x_user)) then
    write(lun6,*) ' ?FRANTIC: geometry information missing.'
    write(lun6,*) '  call FRANTIC_RADIUS first.'
    ierr=99
    return
  end if

  if(nneut_s0.eq.0) then
    ierr=ierr+1
    write(lun6,*) ' ?FRANTIC: no neutral source specified.'
  end if

  do ik=1,nplas
    if(.not.npro_set(ik)) then
      ierr=ierr+1
      write(lun6,*) ' ?FRANTIC: density and temperature ', &
           'profiles not set for species:'
      if(ik.eq.1) write(lun6,*) '  --> electrons.'
      if(ik.eq.2) write(lun6,*) '  --> impurities.'
      if(ik.gt.2) then
        write(lun6,8881) xzplas(ik),aplas(ik)
8881    format('  --> ions, Z=',1pd10.3,' A=',1pd10.3)
      end if
    end if
  end do

  if(ierr.gt.0) return

  !	---------------
  !
  INN1=MJ*MIG
  if(.NOT.ESFLAG.AND..NOT.VSFLAG.AND..NOT.RCFLAG) GO TO 280
  !
  if(LBFLAG) GO TO 30
  !------------------
  do IK=1,NNEUT
    do I=1,NZONEC
      BII(I,IK)=ZERO
      BCX(I,IK)=ZERO
    end do
  end do
!------------------
30 continue
  do I=1,NZONEC
    PCX(I)=ZERO
    PII(I)=ZERO
    PCXSF(I)=ZERO
    PIISF(I)=ZERO
    TQCX(I)=ZERO
    TQII(I)=ZERO
    PRC(I)=ZERO
    SORE(I)=ZERO
    SCX(I)=ZERO
  end do
  !------------------
  do J=1,NNEUT
    do I=1,NZONEC
      SORI(I,J)=ZERO
      SORN(I,J)=ZERO
      DCOLD(I,J)=ZERO
    end do
  end do
  !------------------
  if(MSFLAG) GO TO 70
  if(LNFLAG.AND.MCFLAG) GO TO 70
  !------------------
  WRITE(LUN6,60)
60 FORMAT(T2,'NO MATRIX CALCULATED.  DOING INITIALIZATION', &
        ' WITH MATRIX CALCULATION')
  LNFLAG=.TRUE.
  MCFLAG=.TRUE.
  !------------------
70 if(.NOT.LNFLAG) GO TO 120
  !  I NOW FILL ISPEC ARRAY
  do I=1,NPLAS-1
    IP1=I+1
    do J=1,NNEUT
      INEUT=J
      if(NSPEC(J).EQ.IP1) GO TO 90
    end do
    LISPEC(I)=0
    GO TO 100
90  LISPEC(I)=INEUT
100 continue
  end do
  !------------------
  !  I NOW FIND THE BOUNDARY VALUES FOR EACH ZONE. NOTE THAT ZONE
  !  CENTER I LIES BETWEEN ZONE BOUNDARY I AND I+1.
  NBOUND=NZONEC+1
  do I=1,NZONEC
    VOL(I)=ZPI*(RBOUND(I+1)*RBOUND(I+1)-RBOUND(I)*RBOUND(I))
  end do
  !------------------
  !  I NOW INITALIZE ALPHA AND BETA ARRAYS
120 if(MCFLAG.OR.ESFLAG) call frantic_alpha
  if(.NOT.LNFLAG) GO TO 150
  !  I NOW FIND ARRAY Y WHICH CONTAINS THE DISTANCE OF CLOSEST
  !  APPOACH. SEE PROGRAM WRITE UP FOR DETAILS.
  YLOC(1)=RBOUND(2)*0.6189908923_fp
  do I=2,NZONEC
    ZRPI=RBOUND(I+1)
    ZRPI2=ZRPI*ZRPI
    ZR=RBOUND(I)
    ZVLT=C4TH*ZPI*ZRPI2
    ZVLM=ZERO
    do J=1,I-1
      ZVLM=ZVLM+(RBOUND(J+1)-RBOUND(J))*SQRT(ZRPI2-YLOC(J)**2)
    end do
    ZTS=(ZVLT-ZVLM)/(ZRPI-ZR)
    YLOC(I)=SQRT(ZRPI2-ZTS*ZTS)
  end do
  !------------------
  !  I NOW INITIALIZE SOME ARRAYS.
150 if(.NOT.ESFLAG.AND..NOT.MCFLAG) GO TO 180
  do IK=1,NNEUT
    WWALL(IK)=ZERO
    do I=1,NZONEC
      if(MCFLAG) WALL(I,IK)=ZERO
      !CC	    if(ESFLAG) S0COLD(I,1,     IK)=0.E00
      if(ESFLAG) S0COLD(I,NINLDX,IK)=ZERO  ! TBT 5/91
      if(ESFLAG) PRWFLX(I,IK,1)=ZERO
      if(ESFLAG) PRWFLX(I,IK,2)=ZERO
      if(.NOT.MCFLAG) GO TO 158
      !
      do J=1,NZONEC
        !CC GFUN(J,I,1,     IK)=0.E00
        GFUN(J,I,NINLDX,IK)=ZERO  ! TBT 5/91
        do IDIR=1,2
          PRFLUX(J,I,IK,IDIR)=ZERO
        end do
      end do
158   continue
    end do
  end do
  !------------------
  !  I NOW LOOP OVER ALL TRAJECTORIES
  do I=1,NZONEC
    call frantic_trackr(YLOC(I))
    call frantic_gmat
  end do
  !------------------
  call frantic_kernel
  MSFLAG=.TRUE.
  !------------------
  !  I NOW MAKE A COPY OF 4-D ARRAY GFUN + S0COLD SO THAT
  !  THE SOLUTION VECTOR CAN BE FOUND.
  !  I NOW LOOP OVER THE NEUTRAL WHICH WILL DIE IN ZONE I.
180 continue
  do IK=1,NNEUT
    JSTART=NZONEC*(IK-1)
    !  I NOW LOOP OVER THE NEUTRAL CREATED IN ZONE I.
    do INL=1,NNEUT
      ISTART=NZONEC*(INL-1)
      !  I NOW LOOP OVER ALL BIRTH ZONES OF THE K NEUTRAL.
      do J=1,NZONEC
        J1=JSTART+J
        !  I NOW LOOP OVER ALL DEATH ZONES OF THE K NEUTRAL.
        do I=1,NZONEC
          I1=ISTART+I
          ZDD(I1,J1)=GFUN(I,J,INL,IK)
        end do
      end do
    end do
  end do
  !------------------
  !  I NOW ATTACH THE SOLUTION VECTOR.
  IROW=NZONEC*NNEUT
  JCOL=IROW+1
  do I=1,IROW
    ZDD(I,JCOL)=ZERO
  end do
  if(.NOT.ESFLAG) GO TO 220
  !------------------
  do IK=1,NNEUT
    do INL=1,NNEUT
      ISTART=NZONEC*(INL-1)
      do I=1,NZONEC
        I1=ISTART+I
        ZDD(I1,JCOL)=S0COLD(I,INL,IK)+ZDD(I1,JCOL)
      end do
    end do
  end do
!------------------
220 if(.NOT.VSFLAG) GO TO 240
  do INL=1,NNEUT
    ISTART=NZONEC*(INL-1)
    do I=1,NZONEC
      I1=ISTART+I
      ZDD(I1,JCOL)=VOLSOR(I,INL)+ZDD(I1,JCOL)
    end do
  end do
!------------------
240 if(.NOT.RCFLAG) GO TO 270
  !  I NOW FILL UP ARRAY SVRC
  do I=1,NZONEC
    call sigvte_reco(temp(i,1),1,zsigv)  ! <sigma*v> recomb., m**3/sec
    SVRC(I)=DEN(I,1)*1.0e6_fp*zsigv
  end do
  do INL=1,NNEUT
    IL=NSPEC(INL)
    ISTART=NZONEC*(INL-1)
    do I=1,NZONEC
      I1=ISTART+I
      ZDD(I1,JCOL)=SVRC(I)*DEN(I,IL)+ZDD(I1,JCOL)
    end do
  end do
  !------------------
  !  I NOW CALL GAUSSE TO SOLVE THE EQUATIONS
270 continue
  if(IROW.GT.INN1) GO TO 9000
  call frantic_gausse(ZDD,INN1,IROW,JCOL,ZSTOR1,CEPS4,6)
  !------------------
  !  PUT ANSWER (NET SCE RATE) IN COMMON ARRAY -- D. MC CUNE 8 JUN 81
  TSTOR1=0.0
  do IK=1,NNEUT
    do I=1,NZONEC
      IOFF=(IK-1)*NZONEC+I
      if(abs(ZSTOR1(IOFF)).gt.EPSLON) TSTOR1(I,IK)=ZSTOR1(IOFF) !MG fixed 12/19/2013
    end do
  end do
  !------------------
  call frantic_editr
  call frantic_edits
  !------------------
  return
  !------------------
  !------------------
280 WRITE(LUN6,290)
290 FORMAT(T2,'NO SOURCES MEANS NO NEUTRALS MEANS NO WORK.  NEUTS')
  call BAD_EXIT
  !------------------
  !------------------
9000 continue
  WRITE(LUN6,9001)
9001 FORMAT(T2,'DIMENSIONALITY OF PROBLEM TOO LARGE.  NEUTS')
  call BAD_EXIT
  !------------------
  !------------------
end subroutine frantic_neuts
