!------------------------------------------------------------------------------
!
      SUBROUTINE DELTA_BEAM_Z(E_BEAM, BEAM_SPECIES,TEMP,&
     		THERMAL_SPECIES, EPS, ITER, NREACT, KK, IERR,&
     		SIGV_1, SIGV_2)
!
!...This routine was written by Harry H. Towner of the Princeton Plasma
!...Physics Lab. This routine will calculate the reaction rate between a
!...Delta function beam and a thermal background plasma.
!
!...PARAMETER LIST:
!*..E_BEAM - The energy of the incident beam. (keV)
!*..BEAM_SPECIES - The mass of the beam species. (kev/C**2)
!*..TEMP - The temperature of the thermal species. (keV)
!*..THERMAL_SPECIES - The mass of the thermal species. (keV/C**2)
!*..EPS - The desired relative error.
!*..ITER - The maximum # of iterations to be taken to achieve
!	   relative error EPS.  (see above)
!*..NREACT - Specifies the desired reaction and may have the value:
!     1)   T(D,N)HE4	      2)   HE3(D,P)HE4
!     3)   D(D,P)T	      4)   D(D,N)HE3
!     5)   T(T,2N)HE4	      6)   T(HE3,X)Y
!     12)   T(T,2N)HE4	     !DPC fit, 06/2018
!     7)   3&4 (currently not working)
!*..KK - If 0 reactions are as above. (i.e. D -> T). If KK = 1 then
!	 the reaction is reversed (i.e. T -> D).
!*..IERR - The error code returned.
!		= 1 sucess
!		= 2 maximum iterations reached.
!...SIGV_1 - The value of <sigma*v> (m**3/sec).  If nreact=7 SIGV_1 is
!		 for reaction 4.
!...SIGV_2 - The value of <sigma*v> (m**3/sec).  SIGV_2 = 0.E00 unless
!		nreact=7 then SIGV_2 is for reaction 3.
!
!...Note the the "*" indicates input parameters.
!
!============
! idecl:  explicitize implicit INTEGER declarations:
  use iso_c_binding, only: fp => c_double
  use physconst_mod, only : zero,half,two,sqrt_pi=>sqpi,VC,zev2kev
  IMPLICIT NONE
  INTEGER iter,nreact,kk,ierr,j,k,i
!============
! idecl:  explicitize implicit REAL declarations:
  real(fp) beam_species,temp,thermal_species,eps,sigv_1,sigv_2,&
       e_beam,c2,v_beam,sigma_z,vmin_cut,&
       vmax_thermal,beta2,beta,anorm,vlow,vhigh,a,b,relative_error,&
       xlow,sigv_1_old,sigv_2_old,sum_1,sum_2,xhigh,c1,c0,z,v,v2,&
       arg_1,arg_2,exp1,exp2,e_incident,fun
  real(fp) :: ecut
!============
  real(fp) :: X(6), W(6), E_CUT(6)
!
  DATA X/-.932469514203152_fp,	-.661209386466265_fp,&
       -.238619186083197_fp,	 .238619186083197_fp,&
       .661209386466265_fp,	 .932469514203152_fp/
!
  DATA W/.171324492379170_fp,	 .360761573048139_fp,&
       .467913934572691_fp,	 .467913934572691_fp,&
       .360761573048139_fp,	 .171324492379170_fp/
  !
  DATA E_CUT/.120_fp,	.470_fp,	.132_fp,&
       .145_fp,	.095_fp,	.920_fp/
!
  C2=VC*VC
!
!...Array X contains the roots of the legendre polynomial.
!...Array W contains the weight factors.
!...Array E_CUT contains the lowest energy cut-off for a given reaction.
!
!******************************************************************************
!
!...Define various velocities.
!
  V_BEAM = SQRT(two*E_BEAM*C2/BEAM_SPECIES)
!
  IF (E_BEAM*zev2kev.GT. TEMP) THEN
     SIGV_1 = SIGMA_Z(NREACT,KK,6,E_BEAM)*V_BEAM
     IERR = 1
  ELSE
     if(nreact.eq.12) then
        ecut=e_cut(5)
     else
        ecut=E_CUT(NREACT)
     endif
     VMIN_CUT = SQRT(two*ECUT*C2/BEAM_SPECIES)
     VMAX_THERMAL = SQRT(two*87.5_fp*TEMP*C2/THERMAL_SPECIES)
!
     BETA2 = half*THERMAL_SPECIES/(TEMP*C2)
     BETA = SQRT(BETA2)
     ANORM = BETA/(V_BEAM*SQRT_PI)
!
!******************************************************************************
!
!...Now find <SIGMA*V> for a delta function beam and a thermal background
!
     VLOW = VMIN_CUT
     VHIGH = V_BEAM + VMAX_THERMAL
!
     A = VLOW
     B = VHIGH
     J = 1
!
!	J tells how meny times to apply quadrature to interval.
!
     SIGV_1 = zero
     SIGV_2 = zero
     RELATIVE_ERROR = 100.0_fp
!
     DO WHILE (RELATIVE_ERROR .GT. EPS)
        XLOW = A
        SIGV_1_OLD = SIGV_1
        SIGV_2_OLD = SIGV_2
        SUM_1 = zero
        SUM_2 = zero
!
        DO K=1,J
           XHIGH = XLOW+(B-A)/J
           C1 = (XHIGH-XLOW)*half
           C0 = C1+XLOW
!
           DO I=1,6
              Z = C1*X(I)
              V = C0 + Z
              V2 = V*V
              ARG_1 = -BETA2*(V_BEAM - V)**2
              ARG_2 = -BETA2*(V_BEAM + V)**2
!
              IF (ARG_1 .GT. -87.5_fp) THEN
                 EXP1 = EXP(ARG_1)
!
                 IF (ARG_2 .GT. -87.5_fp) THEN
                    EXP2 = EXP(ARG_2)
                 ELSE
                    EXP2 = zero
                 END IF
!
                 E_INCIDENT = half*BEAM_SPECIES*(V2/C2)
!
                 FUN = (SIGMA_Z(NREACT,KK,6,E_INCIDENT)*V2*1.e+30_fp)*&
                      (EXP1 - EXP2)
                 SUM_1 = SUM_1 + C1*W(I)*FUN
              END IF
!
           END DO
!
           XLOW = XHIGH
        END DO
!
        IF (SUM_1 .GT. 1.e-8_fp) THEN
           SIGV_1 = (SUM_1*ANORM)*1.e-30_fp
           SIGV_2 = (SUM_2*ANORM)*1.e-30_fp
        ELSE
           SIGV_1 = zero
           SIGV_2 = zero
        END IF
!
!...Test for convergence.
!
        IF (SIGV_1 .EQ. zero) THEN
           IERR = 1
           RETURN
        ELSE
           RELATIVE_ERROR = ABS((SIGV_1 - SIGV_1_OLD)/&
     		SIGV_1)
!
           IF (RELATIVE_ERROR .LE. EPS) THEN
              IERR = 1
              RETURN
           ELSE
              J = J*2
!
              IF (J .GT. ITER) THEN
                 J = J/2
                 IERR = 2
                 RETURN
              END IF
!
           END IF
!
        END IF
!
     END DO
!
  END IF
!
  RETURN
END SUBROUTINE DELTA_BEAM_Z
!
!------------------------------------------------------------------------------
! 30Jun2000 fgtok -s r8_precision.sub "r8con.csh conversion"
