module react_state_module

  use bl_types
  use multifab_module
  use define_bc_module
  use ml_layout_module
  use bl_constants_module

  implicit none

  private

  public :: react_state

contains

  function slope(q, qm, qp) result (dq)

    real (kind=dp_t), intent(in) :: q, qm, qp
    real (kind=dp_t) :: dq

    real (kind=dp_t) :: test

    test = (qp - q)*(q - qm)
    if (test > ZERO) then
       dq = min(HALF*abs(qp - qm), min(TWO*abs(qp-q), TWO*abs(q-qm)))* sign(ONE, qp-qm)
    else
       dq = ZERO
    endif

  end function slope

  function ppm_fit(q, qm2, qm1, qp1, qp2) result (qcoeff)

    real (kind=dp_t), intent(in) :: q, qm2, qm1, qp1, qp2
    real (kind=dp_t) :: qcoeff(3)

    ! qcoeff(1) is the ppm ql, qcoeff(2) is the ppm qr, and
    ! qcoeff(3) is the ppm q6
    ! no limiting is done!!

    ! find ql and qr
    qcoeff(1) = (7.0_dp_t/12.0_dp_t)*(q + qm1) - (1.0_dp_t/12.0_dp_t)*(qm2 + qp1)
    qcoeff(2) = (7.0_dp_t/12.0_dp_t)*(q + qp1) - (1.0_dp_t/12.0_dp_t)*(qm1 + qp2)

    ! construct q6
    qcoeff(3) = 6.0_dp_t*(q - 0.5_dp_t*(qcoeff(1) + qcoeff(2)))

  end function ppm_fit

  function ppm_eval(xi, ql, qr, q6) result (qval)

    real (kind=dp_t), intent(in) :: xi, ql, qr, q6
    real (kind=dp_t) :: qval

    qval = ql + xi*(qr - ql + q6*(1.0_dp_t - xi))

  end function ppm_eval

  subroutine react_state(mla,tempbar_init,sold,snew,rho_omegadot,rho_Hnuc,rho_Hext,p0, &
                         dt,dx,the_bc_level)

    use probin_module, only: use_tfromp, do_heating, do_burning
    use variables, only: temp_comp, rhoh_comp, rho_comp,nscal

    use multifab_fill_ghost_module
    use multifab_physbc_module, only : multifab_physbc
    use ml_cc_restriction_module , only : ml_cc_restriction
    use heating_module        , only : get_rho_Hext
    use rhoh_vs_t_module      , only : makeTfromRhoP, makeTfromRhoH
    use bl_constants_module   , only: ZERO

    type(ml_layout), intent(in   ) :: mla
    type(multifab) , intent(in   ) :: sold(:)
    type(multifab) , intent(inout) :: snew(:)
    type(multifab) , intent(inout) :: rho_omegadot(:)
    type(multifab) , intent(inout) :: rho_Hnuc(:)
    type(multifab) , intent(inout) :: rho_Hext(:)
    real(dp_t)     , intent(in   ) :: p0(:,0:)
    real(dp_t)     , intent(in   ) :: tempbar_init(:,0:)
    real(kind=dp_t), intent(in   ) :: dt,dx(:,:)
    type(bc_level) , intent(in   ) :: the_bc_level(:)

    ! Local
    type(bl_prof_timer), save :: bpt

    integer :: n,nlevs,dm

    call build(bpt, "react_state")

    nlevs = mla%nlevel
    dm = mla%dim

    ! apply heating term
    if(do_heating) then
       call get_rho_Hext(mla,tempbar_init,sold,rho_Hext,the_bc_level,dx,dt)

       ! if we aren't burning, then we should just copy the old state to the
       ! new and only update the rhoh component with the heating term
       if (.not. do_burning) then
          do n = 1, nlevs
             call multifab_copy(snew(n),sold(n), nghost(sold(n)))

             ! add in the heating term*dt
             call multifab_mult_mult_s(rho_Hext(n),dt)
             call multifab_plus_plus_c(snew(n),rhoh_comp,rho_Hext(n),1,1)
             call multifab_div_div_s(rho_Hext(n),dt)
          enddo
       endif

    else ! not burning, so we ZERO rho_Hext
       do n = 1, nlevs
          call setval(rho_Hext(n),ZERO,all=.true.)
       enddo

    endif

    ! apply burning term
    if (do_burning) then
       ! we pass in rho_Hext so that we can add it to rhoh incase we
       ! applied heating
       call burner_loop(mla,tempbar_init,sold,snew,rho_omegadot,rho_Hnuc, &
                        rho_Hext,dx,dt,the_bc_level)

       ! pass temperature through for seeding the temperature update eos call
       do n=1,nlevs
          call multifab_copy_c(snew(n),temp_comp,sold(n),temp_comp,1, &
                               nghost(sold(n)))
       end do

    else ! not burning, so we ZERO rho_omegadot and rho_Hnuc
       do n = 1, nlevs
          call setval(rho_omegadot(n),ZERO,all=.true.)
          call setval(rho_Hnuc(n),ZERO,all=.true.)
       enddo

    endif

    ! if we aren't doing any heating/burning, then just copy the old to the new
    if (.not. (do_heating .or. do_burning)) then
       do n = 1, nlevs
          call multifab_copy(snew(n),sold(n),nghost(sold(n)))
       enddo
    endif

    ! let's fill the boundaries
    if (nlevs .eq. 1) then

       ! fill ghost cells for two adjacent grids at the same level
       ! this includes periodic domain boundary ghost cells
       call multifab_fill_boundary(snew(nlevs))

       ! fill non-periodic domain boundary ghost cells
       call multifab_physbc(snew(nlevs),rho_comp,dm+rho_comp,nscal,the_bc_level(nlevs))

    else

       ! the loop over nlevs must count backwards to make sure the finer grids are done first
       do n=nlevs,2,-1

          ! set level n-1 data to be the average of the level n data covering it
          call ml_cc_restriction(snew(n-1)        ,snew(n)        ,mla%mba%rr(n-1,:))
          call ml_cc_restriction(rho_omegadot(n-1),rho_omegadot(n),mla%mba%rr(n-1,:))
          call ml_cc_restriction(rho_Hext(n-1)    ,rho_Hext(n)    ,mla%mba%rr(n-1,:))
          call ml_cc_restriction(rho_Hnuc(n-1)    ,rho_Hnuc(n)    ,mla%mba%rr(n-1,:))

          ! fill level n ghost cells using interpolation from level n-1 data
          ! note that multifab_fill_boundary and multifab_physbc are called for
          ! both levels n-1 and n
          call multifab_fill_ghost_cells(snew(n),snew(n-1),nghost(snew(n)),mla%mba%rr(n-1,:), &
                                         the_bc_level(n-1),the_bc_level(n), &
                                         rho_comp,dm+rho_comp,nscal,fill_crse_boundary_input=.false.)
       enddo

    end if

    ! now update temperature
    if (use_tfromp) then
       call makeTfromRhoP(snew,p0,mla,the_bc_level,dx)
    else
       call makeTfromRhoH(snew,p0,mla,the_bc_level,dx)
    end if

    call destroy(bpt)

  end subroutine react_state

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine burner_loop(mla,tempbar_init,sold,snew,rho_omegadot,rho_Hnuc,rho_Hext,dx,dt,the_bc_level)

    use bl_constants_module, only: ZERO
    use variables, only: foextrap_comp
    use network, only: nspec
    use probin_module, only: drive_initial_convection, do_subgrid_burning
    use geometry, only: spherical
    use fill_3d_module, only: put_1d_array_on_cart

    type(ml_layout), intent(in   ) :: mla
    type(multifab) , intent(in   ) :: sold(:)
    type(multifab) , intent(inout) :: snew(:)
    type(multifab) , intent(inout) :: rho_omegadot(:)
    type(multifab) , intent(inout) :: rho_Hnuc(:)
    type(multifab) , intent(inout) :: rho_Hext(:)
    real(kind=dp_t), intent(in   ) :: tempbar_init(:,0:)
    real(kind=dp_t), intent(in   ) :: dt,dx(:,:)
    type(bc_level) , intent(in   ) :: the_bc_level(:)

    ! Local
    real(kind=dp_t), pointer :: snp(:,:,:,:)
    real(kind=dp_t), pointer :: sop(:,:,:,:)
    real(kind=dp_t), pointer ::  rp(:,:,:,:)
    real(kind=dp_t), pointer ::  hnp(:,:,:,:)
    real(kind=dp_t), pointer ::  hep(:,:,:,:)
    real(kind=dp_t), pointer ::  tcp(:,:,:,:)
    logical        , pointer ::   mp(:,:,:,:)

    type(multifab) :: tempbar_init_cart(mla%nlevel)

    integer :: lo(mla%dim),hi(mla%dim)
    integer :: ng_si,ng_so,ng_rw,ng_he,ng_hn,ng_tc
    integer :: dm,nlevs
    integer :: i,n

    type(bl_prof_timer), save :: bpt

    call build(bpt, "burner_loop")

    dm = mla%dim
    nlevs = mla%nlevel

    ng_si = nghost(sold(1))
    ng_so = nghost(snew(1))
    ng_rw = nghost(rho_omegadot(1))
    ng_hn = nghost(rho_Hnuc(1))
    ng_he = nghost(rho_Hext(1))

    ! put tempbar_init on Cart
    if (spherical == 1) then
       do n=1, nlevs
          ! tempbar_init_cart will hold the initial tempbar on a Cartesian
          ! grid to be used if drive_initial_convection is true
          call build(tempbar_init_cart(n),mla%la(n),1,0)
          call setval(tempbar_init_cart(n), ZERO, all=.true.)
       enddo

       if (drive_initial_convection) then
          ! fill all components
          call put_1d_array_on_cart(tempbar_init,tempbar_init_cart, &
                                    foextrap_comp,.false.,.false.,dx, &
                                    the_bc_level,mla)
       endif
    endif

    do n = 1, nlevs
       do i = 1, nfabs(sold(n))
          print *, 'lev, ifab: ', n, i
          snp => dataptr(sold(n) , i)
          sop => dataptr(snew(n), i)
          rp => dataptr(rho_omegadot(n), i)
          hnp => dataptr(rho_Hnuc(n), i)
          hep => dataptr(rho_Hext(n), i)
          lo =  lwb(get_box(sold(n), i))
          hi =  upb(get_box(sold(n), i))
          select case (dm)
          case (1)
             call burner_loop_1d(tempbar_init(n,:), &
                                 snp(:,1,1,:),ng_si,sop(:,1,1,:),ng_so, &
                                 rp(:,1,1,:),ng_rw, &
                                 hnp(:,1,1,1),ng_hn,hep(:,1,1,1),ng_he, &
                                 dt,lo,hi)
          case (2)

             if (do_subgrid_burning) then
                if (n .eq. nlevs) then
                   call burner_loop_2d_sub(tempbar_init(n,:), &
                                           snp(:,:,1,:),ng_si,sop(:,:,1,:),ng_so, &
                                           rp(:,:,1,:),ng_rw, &
                                           hnp(:,:,1,1),ng_hn,hep(:,:,1,1),ng_he, &
                                           dx(n,:),dt,lo,hi)
                else
                   mp => dataptr(mla%mask(n), i)
                   call burner_loop_2d_sub(tempbar_init(n,:), &
                                           snp(:,:,1,:),ng_si,sop(:,:,1,:),ng_so, &
                                           rp(:,:,1,:),ng_rw, &
                                           hnp(:,:,1,1),ng_hn,hep(:,:,1,1),ng_he, &
                                           dx(n,:),dt,lo,hi,mp(:,:,1,1))
                end if

             else

                if (n .eq. nlevs) then
                   call burner_loop_2d(tempbar_init(n,:), &
                                       snp(:,:,1,:),ng_si,sop(:,:,1,:),ng_so, &
                                       rp(:,:,1,:),ng_rw, &
                                       hnp(:,:,1,1),ng_hn,hep(:,:,1,1),ng_he, &
                                       dt,lo,hi)
                else
                   mp => dataptr(mla%mask(n), i)
                   call burner_loop_2d(tempbar_init(n,:), &
                                       snp(:,:,1,:),ng_si,sop(:,:,1,:),ng_so, &
                                       rp(:,:,1,:),ng_rw, &
                                       hnp(:,:,1,1),ng_hn,hep(:,:,1,1),ng_he, &
                                       dt,lo,hi,mp(:,:,1,1))
                end if

             endif

          case (3)
             if (spherical == 1) then
                tcp => dataptr(tempbar_init_cart(n), i)
                ng_tc = nghost(tempbar_init_cart(1))
                if (n .eq. nlevs) then
                   call burner_loop_3d_sph(tcp(:,:,:,1),ng_tc, &
                                           snp(:,:,:,:),ng_si,sop(:,:,:,:),ng_so, &
                                           rp(:,:,:,:),ng_rw, &
                                           hnp(:,:,:,1),ng_hn,hep(:,:,:,1),ng_he, &
                                           dt,lo,hi)
                else
                   mp => dataptr(mla%mask(n), i)
                   call burner_loop_3d_sph(tcp(:,:,:,1),ng_tc, &
                                           snp(:,:,:,:),ng_si,sop(:,:,:,:),ng_so, &
                                           rp(:,:,:,:),ng_rw, &
                                           hnp(:,:,:,1),ng_hn,hep(:,:,:,1),ng_he, &
                                           dt,lo,hi,mp(:,:,:,1))
                end if
             else
                print *, 'Calling 3D vec loop...'
                !call burner_loop_3d_vec(tempbar_init(n,:), &
                !                    snp(:,:,:,:),ng_si,sop(:,:,:,:),ng_so, &
                !                    rp(:,:,:,:),ng_rw, &
                !                    hnp(:,:,:,1),ng_hn,hep(:,:,:,1),ng_he, &
                !                    dt,lo,hi)
                if (n .eq. nlevs) then
                   call burner_loop_3d(tempbar_init(n,:), &
                                       snp(:,:,:,:),ng_si,sop(:,:,:,:),ng_so, &
                                       rp(:,:,:,:),ng_rw, &
                                       hnp(:,:,:,1),ng_hn,hep(:,:,:,1),ng_he, &
                                       dt,lo,hi)
                else
                   mp => dataptr(mla%mask(n), i)
                   call burner_loop_3d(tempbar_init(n,:), &
                                       snp(:,:,:,:),ng_si,sop(:,:,:,:),ng_so, &
                                       rp(:,:,:,:),ng_rw, &
                                       hnp(:,:,:,1),ng_hn,hep(:,:,:,1),ng_he, &
                                       dt,lo,hi,mp(:,:,:,1))
                end if
             endif
          end select
       end do
    end do

    call destroy(bpt)

    if (spherical == 1) then
       do n = 1, nlevs
          call destroy(tempbar_init_cart(n))
       enddo
    endif

  end subroutine burner_loop

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine burner_loop_1d(tempbar_init,sold,ng_si,snew,ng_so,rho_omegadot,ng_rw,rho_Hnuc,ng_hn, &
                            rho_Hext,ng_he,dt,lo,hi)

    use bl_constants_module
    use burner_module
    use variables, only: rho_comp, spec_comp, temp_comp, rhoh_comp, trac_comp, ntrac
    use network, only: nspec, network_species_index
    use probin_module, ONLY: burning_cutoff_density, burner_threshold_species, &
         burner_threshold_cutoff, drive_initial_convection

    integer        , intent(in   ) :: lo(:),hi(:),ng_si,ng_so,ng_rw,ng_he,ng_hn
    real(kind=dp_t), intent(in   ) ::        sold (lo(1)-ng_si:,:)
    real(kind=dp_t), intent(  out) ::         snew(lo(1)-ng_so:,:)
    real(kind=dp_t), intent(  out) :: rho_omegadot(lo(1)-ng_rw:,:)
    real(kind=dp_t), intent(  out) ::     rho_Hnuc(lo(1)-ng_hn:)
    real(kind=dp_t), intent(in   ) ::     rho_Hext(lo(1)-ng_he:)
    real(kind=dp_t), intent(in   ) :: tempbar_init(0:)
    real(kind=dp_t), intent(in   ) :: dt

    !     Local variables
    integer            :: i,n
    real (kind = dp_t) :: rho,T_in
    real (kind = dp_t) :: x_in(nspec)
    real (kind = dp_t) :: x_out(nspec)
    real (kind = dp_t) :: rhowdot(nspec)
    real (kind = dp_t) :: rhoH
    real (kind = dp_t) :: x_test
    integer, save      :: ispec_threshold
    logical, save      :: firstCall = .true.

    real (kind = dp_t) :: sumX
    real (kind = dp_t), parameter :: x_err = 1.d-10

    if (firstCall) then
       ispec_threshold = network_species_index(burner_threshold_species)
       firstCall = .false.
    endif

    do i = lo(1), hi(1)

          rho = sold(i,rho_comp)
          x_in(1:nspec) = sold(i,spec_comp:spec_comp+nspec-1) / rho

          if (drive_initial_convection) then
             T_in = tempbar_init(i)
          else
             T_in = sold(i,temp_comp)
          endif

          ! Fortran doesn't guarantee short-circuit evaluation of logicals so
          ! we need to test the value of ispec_threshold before using it
          ! as an index in x_in
          if (ispec_threshold > 0) then
             x_test = x_in(ispec_threshold)
          else
             x_test = ZERO
          endif

          ! if the threshold species is not in the network, then we burn
          ! normally.  if it is in the network, make sure the mass
          ! fraction is above the cutoff.
          if (rho > burning_cutoff_density .and.                      &
              ( ispec_threshold < 0 .or.                              &
               (ispec_threshold > 0 .and.                             &
                x_test > burner_threshold_cutoff                      &
               )                                                      &
              )                                                       &
             ) then
             call burner(rho, T_in, x_in, dt, x_out, rhowdot, rhoH)
          else
             x_out = x_in
             rhowdot = 0.d0
             rhoH = 0.d0
          endif

          ! check if sum{X_k} = 1
          sumX = ZERO
          do n = 1, nspec
             sumX = sumX + x_out(n)
          enddo
          if (abs(sumX - ONE) > x_err) then
             call bl_error("ERROR: abundances do not sum to 1", abs(sumX-ONE))
          endif

          ! pass the density through
          snew(i,rho_comp) = sold(i,rho_comp)

          ! update the species
          snew(i,spec_comp:spec_comp+nspec-1) = x_out(1:nspec) * rho

          ! store the energy generation and species creation quantities
          rho_omegadot(i,1:nspec) = rhowdot(1:nspec)
          rho_Hnuc(i) = rhoH

          ! update the enthalpy -- include the change due to external heating
          snew(i,rhoh_comp) = sold(i,rhoh_comp) + dt*rho_Hnuc(i) + dt*rho_Hext(i)

          ! pass the tracers through
          snew(i,trac_comp:trac_comp+ntrac-1) = sold(i,trac_comp:trac_comp+ntrac-1)

    enddo

  end subroutine burner_loop_1d

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine burner_loop_2d(tempbar_init,sold,ng_si,snew,ng_so,rho_omegadot,ng_rw,rho_Hnuc,ng_hn, &
                            rho_Hext,ng_he,dt,lo,hi,mask)

    use bl_constants_module
    use burner_module
    use variables, only: rho_comp, spec_comp, temp_comp, rhoh_comp, trac_comp, ntrac
    use network, only: nspec, network_species_index
    use probin_module, ONLY: burning_cutoff_density, burner_threshold_species, &
         burner_threshold_cutoff, drive_initial_convection

    integer        , intent(in   ) :: lo(:),hi(:),ng_si,ng_so,ng_rw,ng_he,ng_hn
    real(kind=dp_t), intent(in   ) ::        sold (lo(1)-ng_si:,lo(2)-ng_si:,:)
    real(kind=dp_t), intent(  out) ::         snew(lo(1)-ng_so:,lo(2)-ng_so:,:)
    real(kind=dp_t), intent(  out) :: rho_omegadot(lo(1)-ng_rw:,lo(2)-ng_rw:,:)
    real(kind=dp_t), intent(  out) ::     rho_Hnuc(lo(1)-ng_hn:,lo(2)-ng_hn:)
    real(kind=dp_t), intent(in   ) ::     rho_Hext(lo(1)-ng_he:,lo(2)-ng_he:)
    real(kind=dp_t), intent(in   ) :: tempbar_init(0:)
    real(kind=dp_t), intent(in   ) :: dt
    logical        , intent(in   ), optional :: mask(lo(1):,lo(2):)

    !     Local variables
    integer            :: i, j, n
    real (kind = dp_t) :: rho,T_in
    real (kind = dp_t) :: x_in(nspec)
    real (kind = dp_t) :: x_out(nspec)
    real (kind = dp_t) :: rhowdot(nspec)
    real (kind = dp_t) :: rhoH
    real (kind = dp_t) :: x_test
    logical            :: cell_valid
    integer, save      :: ispec_threshold
    logical, save      :: firstCall = .true.

    real (kind = dp_t) :: sumX
    real (kind = dp_t), parameter :: x_err = 1.d-10

    if (firstCall) then
       ispec_threshold = network_species_index(burner_threshold_species)
       firstCall = .false.
    endif

    do j = lo(2), hi(2)
       do i = lo(1), hi(1)

          ! make sure the cell isn't covered by finer cells
          cell_valid = .true.
          if ( present(mask) ) then
             if ( (.not. mask(i,j)) ) cell_valid = .false.
          end if

          if (cell_valid) then

             rho = sold(i,j,rho_comp)
             x_in(1:nspec) = sold(i,j,spec_comp:spec_comp+nspec-1) / rho

             if (drive_initial_convection) then
                T_in = tempbar_init(j)
             else
                T_in = sold(i,j,temp_comp)
             endif

             ! Fortran doesn't guarantee short-circuit evaluation of logicals so
             ! we need to test the value of ispec_threshold before using it
             ! as an index in x_in
             if (ispec_threshold > 0) then
                x_test = x_in(ispec_threshold)
             else
                x_test = ZERO
             endif

             ! if the threshold species is not in the network, then we burn
             ! normally.  if it is in the network, make sure the mass
             ! fraction is above the cutoff.
             if (rho > burning_cutoff_density .and.           &
                  ( ispec_threshold < 0 .or.                  &
                  (ispec_threshold > 0 .and.                  &
                  x_test > burner_threshold_cutoff ))) then
                call burner(rho, T_in, x_in, dt, x_out, rhowdot, rhoH)
             else
                x_out = x_in
                rhowdot = 0.d0
                rhoH = 0.d0
             endif

             ! check if sum{X_k} = 1
             sumX = ZERO
             do n = 1, nspec
                sumX = sumX + x_out(n)
             enddo
             if (abs(sumX - ONE) > x_err) then
                call bl_error("ERROR: abundances do not sum to 1", abs(sumX-ONE))
             endif

             ! pass the density through
             snew(i,j,rho_comp) = sold(i,j,rho_comp)

             ! update the species
             snew(i,j,spec_comp:spec_comp+nspec-1) = x_out(1:nspec) * rho

             ! store the energy generation and species creation quantities
             rho_omegadot(i,j,1:nspec) = rhowdot(1:nspec)
             rho_Hnuc(i,j) = rhoH

             ! update the enthalpy -- include the change due to external heating
             snew(i,j,rhoh_comp) = sold(i,j,rhoh_comp) + dt*rho_Hnuc(i,j) + dt*rho_Hext(i,j)

             ! pass the tracers through
             snew(i,j,trac_comp:trac_comp+ntrac-1) = sold(i,j,trac_comp:trac_comp+ntrac-1)

          end if

       enddo
    enddo

  end subroutine burner_loop_2d

  subroutine burner_loop_2d_sub(tempbar_init,sold,ng_si,snew,ng_so,rho_omegadot,ng_rw,rho_Hnuc,ng_hn, &
                            rho_Hext,ng_he,dx,dt,lo,hi,mask)

    ! a special version of the 2d loop that subsamples in the vertical direction and averages
    ! the result -- this gets a better value for the average enuc in a cell.

    use bl_constants_module
    use burner_module
    use variables, only: rho_comp, spec_comp, temp_comp, rhoh_comp, trac_comp, ntrac
    use network, only: nspec, network_species_index
    use probin_module, ONLY: burning_cutoff_density, burner_threshold_species, &
         burner_threshold_cutoff, drive_initial_convection

    integer        , intent(in   ) :: lo(:),hi(:),ng_si,ng_so,ng_rw,ng_he,ng_hn
    real(kind=dp_t), intent(in   ) ::        sold (lo(1)-ng_si:,lo(2)-ng_si:,:)
    real(kind=dp_t), intent(  out) ::         snew(lo(1)-ng_so:,lo(2)-ng_so:,:)
    real(kind=dp_t), intent(  out) :: rho_omegadot(lo(1)-ng_rw:,lo(2)-ng_rw:,:)
    real(kind=dp_t), intent(  out) ::     rho_Hnuc(lo(1)-ng_hn:,lo(2)-ng_hn:)
    real(kind=dp_t), intent(in   ) ::     rho_Hext(lo(1)-ng_he:,lo(2)-ng_he:)
    real(kind=dp_t), intent(in   ) :: tempbar_init(0:)
    real(kind=dp_t), intent(in   ) :: dx(:), dt
    logical        , intent(in   ), optional :: mask(lo(1):,lo(2):)

    !     Local variables
    integer, parameter :: nsub = 4
    integer :: jj

    integer            :: i, j, n
    real (kind = dp_t) :: rho,T_in
    real (kind = dp_t) :: x_in(nspec)
    real (kind = dp_t) :: x_out(nspec)
    real (kind = dp_t) :: rhowdot(nspec)
    real (kind = dp_t) :: rhoH
    real (kind = dp_t) :: x_test
    logical            :: cell_valid
    integer, save      :: ispec_threshold
    logical, save      :: firstCall = .true.

    real (kind = dp_t) :: sumX
    real (kind = dp_t), parameter :: x_err = 1.d-10

    real (kind=dp_t) :: slope_rho, slope_T, slope_X
    real (kind=dp_t) :: Tcoeff(3)
    real (kind=dp_t) :: slope_X_temp
    real (kind=dp_t) :: x_out_temp(nspec), rhowdot_temp(nspec), rhoH_temp

    if (firstCall) then
       ispec_threshold = network_species_index(burner_threshold_species)
       firstCall = .false.
    endif

    do j = lo(2), hi(2)
       do i = lo(1), hi(1)

          ! make sure the cell isn't covered by finer cells
          cell_valid = .true.
          if ( present(mask) ) then
             if ( (.not. mask(i,j)) ) cell_valid = .false.
          end if

          if (cell_valid) then

             ! density
             slope_rho = slope(sold(i,j,rho_comp), sold(i,j-1,rho_comp), sold(i,j+1,rho_comp))

             ! temp -- do dT and T_0 separately
             if (j > 1 .and. j < size(tempbar_init,dim=1)-2) then
                slope_T = slope(sold(i,j  ,temp_comp)-tempbar_init(j), &
                                sold(i,j-1,temp_comp)-tempbar_init(j-1), &
                                sold(i,j+1,temp_comp)-tempbar_init(j+1))

                Tcoeff = ppm_fit(tempbar_init(j), &
                                 tempbar_init(j-2), tempbar_init(j-1), &
                                 tempbar_init(j+1), tempbar_init(j+2))
             else
                slope_T = slope(sold(i,j  ,temp_comp)-tempbar_init(j), &
                                sold(i,j-1,temp_comp)-tempbar_init(j), &
                                sold(i,j+1,temp_comp)-tempbar_init(j))

                Tcoeff = [tempbar_init(j), tempbar_init(j), 0.0d0]
             endif

             ! X -- we really need to do a group limit here -- for now do 0
             slope_X = ZERO

             ! subcycle over the zones
             x_out = ZERO
             rhowdot = ZERO
             rhoH = ZERO

             do jj = 0, nsub-1

                rho = sold(i,j,rho_comp) + dble(jj - nsub/2 + HALF)*slope_rho/dx(2)

                x_in(1:nspec) = sold(i,j,spec_comp:spec_comp+nspec-1) / sold(i,j,rho_comp) + &
                     dble(jj - nsub/2 + HALF)*slope_X/dx(2)

                ! T is the sum of dT interpolated + T0 reconstructed via PPM
                T_in = (sold(i,j,temp_comp)-tempbar_init(j)) + dble(jj - nsub/2 + HALF)*slope_T/dx(2) + &
                     ppm_eval(dble(jj+HALF)/nsub, Tcoeff(1), Tcoeff(2), Tcoeff(3))

                if (i == 0) then
                   print *, 'j, T_ij, T0, T_in', j, sold(i,j,temp_comp), tempbar_init(j), T_in
                endif
                sumX = ZERO
                do n = 1, nspec
                   sumX = sumX + x_in(n)
                enddo
                if (abs(sumX - ONE) > x_err) then
                   print *, x_in
                   print *, slope_X
                   call bl_error("ERROR: before burn, abundances do not sum to 1", abs(sumX-ONE))
                endif

                ! Fortran doesn't guarantee short-circuit evaluation of logicals so
                ! we need to test the value of ispec_threshold before using it
                ! as an index in x_in
                if (ispec_threshold > 0) then
                   x_test = x_in(ispec_threshold)
                else
                   x_test = ZERO
                endif

                ! if the threshold species is not in the network, then we burn
                ! normally.  if it is in the network, make sure the mass
                ! fraction is above the cutoff.
                if (rho > burning_cutoff_density .and.           &
                     ( ispec_threshold < 0 .or.                  &
                     (ispec_threshold > 0 .and.                  &
                     x_test > burner_threshold_cutoff ))) then
                   call burner(rho, T_in, x_in, dt, x_out_temp, rhowdot_temp, rhoH_temp)
                else
                   x_out_temp = x_in
                   rhowdot_temp = 0.d0
                   rhoH_temp = 0.d0
                endif

                ! check if sum{X_k} = 1
                sumX = ZERO
                do n = 1, nspec
                   sumX = sumX + x_out_temp(n)
                enddo
                if (abs(sumX - ONE) > x_err) then
                   print *, sold(i,j,spec_comp:spec_comp+nspec-1)
                   call bl_error("ERROR: abundances do not sum to 1", abs(sumX-ONE))
                endif

                x_out = x_out + x_out_temp
                rhowdot = rhowdot + rhowdot_temp
                rhoH = rhoH + rhoH_temp

             enddo

             ! normalize
             x_out = x_out/nsub
             rhowdot = rhowdot/nsub
             rhoH = rhoH/nsub

             ! pass the density through
             snew(i,j,rho_comp) = sold(i,j,rho_comp)

             ! update the species
             snew(i,j,spec_comp:spec_comp+nspec-1) = x_out(1:nspec) * sold(i,j,rho_comp)

             ! store the energy generation and species creation quantities
             rho_omegadot(i,j,1:nspec) = rhowdot(1:nspec)
             rho_Hnuc(i,j) = rhoH

             ! update the enthalpy -- include the change due to external heating
             snew(i,j,rhoh_comp) = sold(i,j,rhoh_comp) + dt*rho_Hnuc(i,j) + dt*rho_Hext(i,j)

             ! pass the tracers through
             snew(i,j,trac_comp:trac_comp+ntrac-1) = sold(i,j,trac_comp:trac_comp+ntrac-1)

          end if

       enddo
    enddo

  end subroutine burner_loop_2d_sub

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine burner_loop_3d(tempbar_init,sold,ng_si,snew,ng_so,rho_omegadot,ng_rw,rho_Hnuc,ng_hn, &
                            rho_Hext,ng_he,dt,lo,hi,mask)

    use bl_constants_module
    use parallel
    use burner_module
    use variables, only: rho_comp, spec_comp, temp_comp, rhoh_comp, trac_comp, ntrac
    use network, only: nspec, network_species_index
    use probin_module, ONLY: burning_cutoff_density, burner_threshold_species, &
         burner_threshold_cutoff, drive_initial_convection

    integer        , intent(in   ) :: lo(:),hi(:),ng_si,ng_so,ng_rw,ng_he,ng_hn
    real(kind=dp_t), intent(in   ) ::         sold(lo(1)-ng_si:,lo(2)-ng_si:,lo(3)-ng_si:,:)
    real(kind=dp_t), intent(  out) ::         snew(lo(1)-ng_so:,lo(2)-ng_so:,lo(3)-ng_so:,:)
    real(kind=dp_t), intent(  out) :: rho_omegadot(lo(1)-ng_rw:,lo(2)-ng_rw:,lo(3)-ng_rw:,:)
    real(kind=dp_t), intent(  out) ::     rho_Hnuc(lo(1)-ng_hn:,lo(2)-ng_hn:,lo(3)-ng_hn:)
    real(kind=dp_t), intent(in   ) ::     rho_Hext(lo(1)-ng_he:,lo(2)-ng_he:,lo(3)-ng_he:)
    real(kind=dp_t), intent(in   ) :: tempbar_init(0:)
    real(kind=dp_t), intent(in   ) :: dt
    logical        , intent(in   ), optional :: mask(lo(1):,lo(2):,lo(3):)

    !     Local variables
    integer            :: i, j, k, n
    real (kind = dp_t) :: rho,T_in,ldt

    real (kind = dp_t) :: x_in(nspec)
    real (kind = dp_t) :: x_out(nspec)
    real (kind = dp_t) :: rhowdot(nspec)
    real (kind = dp_t) :: rhoH
    real (kind = dp_t) :: x_test
    logical            :: cell_valid
    integer, save      :: ispec_threshold
    logical, save      :: firstCall = .true.

    real (kind = dp_t) :: sumX
    real (kind = dp_t), parameter :: x_err = 1.d-10

    if (firstCall) then
       ispec_threshold = network_species_index(burner_threshold_species)
       firstCall = .false.
    endif

    ldt = dt

    !$OMP PARALLEL DO PRIVATE(i,j,k,cell_valid,rho,x_in,T_in,x_test,x_out,rhowdot,rhoH,sumX,n) FIRSTPRIVATE(ldt) &
    !$OMP SCHEDULE(DYNAMIC,1)
    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)

             cell_valid = .true.
             if ( present(mask) ) then
                if ( (.not. mask(i,j,k)) ) cell_valid = .false.
             end if

             if (cell_valid) then

                rho = sold(i,j,k,rho_comp)
                x_in = sold(i,j,k,spec_comp:spec_comp+nspec-1) / rho

                if (drive_initial_convection) then
                   T_in = tempbar_init(k)
                else
                   T_in = sold(i,j,k,temp_comp)
                endif

                ! Fortran doesn't guarantee short-circuit evaluation of logicals
                ! so we need to test the value of ispec_threshold before using it
                ! as an index in x_in
                if (ispec_threshold > 0) then
                   x_test = x_in(ispec_threshold)
                else
                   x_test = ZERO
                endif

                ! if the threshold species is not in the network, then we burn
                ! normally.  if it is in the network, make sure the mass
                ! fraction is above the cutoff.
                if (rho > burning_cutoff_density .and.                &
                     ( ispec_threshold < 0 .or.                       &
                     (ispec_threshold > 0 .and.                       &
                     x_test > burner_threshold_cutoff))) then
                   call burner(rho, T_in, x_in, ldt, x_out, rhowdot, rhoH)
                else
                   x_out = x_in
                   rhowdot = 0.d0
                   rhoH = 0.d0
                endif

                ! check if sum{X_k} = 1
                sumX = ZERO
                do n = 1, nspec
                   sumX = sumX + x_out(n)
                enddo
                if (abs(sumX - ONE) > x_err) then
                   call bl_error("ERROR: abundances do not sum to 1", abs(sumX-ONE))
                endif

                ! pass the density through
                snew(i,j,k,rho_comp) = sold(i,j,k,rho_comp)

                ! update the species
                snew(i,j,k,spec_comp:spec_comp+nspec-1) = x_out(1:nspec) * rho

                ! store the energy generation and species create quantities
                rho_omegadot(i,j,k,1:nspec) = rhowdot(1:nspec)
                rho_Hnuc(i,j,k) = rhoH

                ! update the enthalpy -- include the change due to external heating
                snew(i,j,k,rhoh_comp) = sold(i,j,k,rhoh_comp) &
                     + ldt*rho_Hnuc(i,j,k) + ldt*rho_Hext(i,j,k)

                ! pass the tracers through
                snew(i,j,k,trac_comp:trac_comp+ntrac-1) = &
                     sold(i,j,k,trac_comp:trac_comp+ntrac-1)

             end if

          enddo
       enddo
    enddo
    !$OMP END PARALLEL DO

  end subroutine burner_loop_3d

  !This loop makes use of a vectorized burner.  So the loop is trivial,
  !creating a vector of data, and the heavy numerical lifting is deferred to the
  !burner/integrator.  Useful for burners that target GPUs.
  subroutine burner_loop_3d_vec(tempbar_init,sold,ng_si,snew,ng_so,rho_omegadot,ng_rw,rho_Hnuc,ng_hn, &
                            rho_Hext,ng_he,dt,lo,hi)
                           ! rho_Hext,ng_he,dt,lo,hi,mask)

    use bl_constants_module
    use parallel
    use burner_module
    use variables, only: rho_comp, spec_comp, temp_comp, rhoh_comp, trac_comp, ntrac
    use network, only: nspec, network_species_index
    use probin_module, ONLY: burning_cutoff_density, burner_threshold_species, &
         burner_threshold_cutoff, drive_initial_convection

    integer        , intent(in   ) :: lo(:),hi(:),ng_si,ng_so,ng_rw,ng_he,ng_hn
    real(kind=dp_t), intent(in   ) ::         sold(lo(1)-ng_si:,lo(2)-ng_si:,lo(3)-ng_si:,:)
    real(kind=dp_t), intent(  out) ::         snew(lo(1)-ng_so:,lo(2)-ng_so:,lo(3)-ng_so:,:)
    real(kind=dp_t), intent(  out) :: rho_omegadot(lo(1)-ng_rw:,lo(2)-ng_rw:,lo(3)-ng_rw:,:)
    real(kind=dp_t), intent(  out) ::     rho_Hnuc(lo(1)-ng_hn:,lo(2)-ng_hn:,lo(3)-ng_hn:)
    real(kind=dp_t), intent(in   ) ::     rho_Hext(lo(1)-ng_he:,lo(2)-ng_he:,lo(3)-ng_he:)
    real(kind=dp_t), intent(in   ) :: tempbar_init(0:)
    real(kind=dp_t), intent(in   ) :: dt
    !logical        , intent(in   ), optional :: mask(lo(1):,lo(2):,lo(3):)

    !     Local variables
    integer            :: vec_size, x_size, y_size, z_size
    integer            :: i, j, k, n, ii
    real (kind = dp_t) :: ldt
    real (kind = dp_t), allocatable :: rho(:)
    real (kind = dp_t), allocatable :: T_in(:)
    real (kind = dp_t), allocatable :: x_in(:,:)
    real (kind = dp_t), allocatable :: x_out(:,:)
    real (kind = dp_t), allocatable :: rhowdot(:,:)
    real (kind = dp_t), allocatable :: rhoH(:)
    real (kind = dp_t) :: x_test
    !logical            :: cell_valid
    integer, save      :: ispec_threshold
    logical, save      :: firstCall = .true.

    real (kind = dp_t) :: sumX
    real (kind = dp_t), parameter :: x_err = 1.d-10

    if (firstCall) then
       ispec_threshold = network_species_index(burner_threshold_species)
       firstCall = .false.
    endif

    ldt = dt

    ! Build input and output vectors
    x_size = (hi(1) - lo(1) + 1)
    y_size = (hi(2) - lo(2) + 1)
    z_size = (hi(3) - lo(3) + 1)
    vec_size = x_size * y_size * z_size
    allocate(    rho(vec_size))
    allocate(   T_in(vec_size))
    allocate(   x_in(nspec,vec_size))
    allocate(  x_out(nspec,vec_size))
    allocate(rhowdot(nspec,vec_size))
    allocate(   rhoH(vec_size))

    !!$OMP PARALLEL DO PRIVATE(i,j,k,cell_valid,rho,x_in,T_in,x_test,x_out,rhowdot,rhoH,sumX,n) FIRSTPRIVATE(ldt) &
    !!$OMP PARALLEL DO PRIVATE(i,j,k,rho,x_in,T_in,x_test,x_out,rhowdot,rhoH,sumX,n) FIRSTPRIVATE(ldt) &
    !!$OMP SCHEDULE(DYNAMIC,1)
    !TODO: Worth it to OMP-ify this loop?
    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)
             ii = i - lo(1) + y_size * (j - lo(2) + z_size * (k-lo(3))) + 1
             rho(ii) = sold(i,j,k,rho_comp)
             x_in(:,ii) = sold(i,j,k,spec_comp:spec_comp+nspec-1) / rho(ii)

             if (drive_initial_convection) then
                T_in(ii) = tempbar_init(k)
             else
                T_in(ii) = sold(i,j,k,temp_comp)
             endif
          end do
       end do
    end do

    ! Call vectorized burner
    !call burner_vec(rho, T_in, x_in, ldt, x_out, rhowdot, rhoH)

    ! Process output
    !TODO: Worth it to OMP-ify this loop?
    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)
             ii = i - lo(1) + y_size * (j - lo(2) + z_size * (k-lo(3))) + 1

             ! Fortran doesn't guarantee short-circuit evaluation of logicals
             ! so we need to test the value of ispec_threshold before using it
             ! as an index in x_in
             if (ispec_threshold > 0) then
                x_test = x_in(ispec_threshold,ii)
             else
                x_test = ZERO
             endif

             ! if the threshold species is in the network, make sure the mass
             ! fraction is above the cutoff.  Otherwise don't use the burner's
             ! output.
             !    TODO: As of now we burn even if we're not going to
             !    use the output assuming that the vectorized burning will be
             !    a net win even if we do some unneeded burner.  Should make
             !    sure this assumption holds and may want develop a more clever
             !    vectorized burning strategy that doesn't do any wasted burning
             if (.not. (rho(ii) > burning_cutoff_density .and.                &
                  ( ispec_threshold < 0 .or.                       &
                  (ispec_threshold > 0 .and.                       &
                  x_test > burner_threshold_cutoff)))) then
                x_out(:,ii) = x_in(:,ii)
                rhowdot(:,ii) = 0.d0
                rhoH(ii) = 0.d0
             endif

             ! check if sum{X_k} = 1
             sumX = ZERO
             do n = 1, nspec
                sumX = sumX + x_out(n,ii)
             enddo
             if (abs(sumX - ONE) > x_err) then
                call bl_error("ERROR: abundances do not sum to 1", abs(sumX-ONE))
             endif

             ! pass the density through
             snew(i,j,k,rho_comp) = sold(i,j,k,rho_comp)

             ! update the species
             snew(i,j,k,spec_comp:spec_comp+nspec-1) = x_out(1:nspec,ii) * rho(ii)

             ! store the energy generation and species create quantities
             rho_omegadot(i,j,k,1:nspec) = rhowdot(1:nspec,ii)
             rho_Hnuc(i,j,k) = rhoH(ii)

             ! update the enthalpy -- include the change due to external heating
             snew(i,j,k,rhoh_comp) = sold(i,j,k,rhoh_comp) &
                  + ldt*rho_Hnuc(i,j,k) + ldt*rho_Hext(i,j,k)

             ! pass the tracers through
             snew(i,j,k,trac_comp:trac_comp+ntrac-1) = &
                  sold(i,j,k,trac_comp:trac_comp+ntrac-1)

          enddo
       enddo
    enddo

    deallocate(rho,T_in,x_in,x_out,rhowdot,rhoH)
  end subroutine burner_loop_3d_vec

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine burner_loop_3d_sph(tempbar_init_cart,ng_tc, &
                                sold,ng_si,snew,ng_so, &
                                rho_omegadot,ng_rw, &
                                rho_Hnuc,ng_hn,rho_Hext,ng_he, &
                                dt,lo,hi,mask)

    use bl_constants_module
    use burner_module
    use variables, only: rho_comp, spec_comp, temp_comp, rhoh_comp, trac_comp, ntrac
    use network, only: nspec, network_species_index
    use probin_module, ONLY: burning_cutoff_density, burner_threshold_species, &
         burner_threshold_cutoff, drive_initial_convection

    integer        , intent(in   ) :: lo(:),hi(:),ng_si,ng_so,ng_rw,ng_he,ng_hn,ng_tc
    real(kind=dp_t), intent(in   ) ::         sold(lo(1)-ng_si:,lo(2)-ng_si:,lo(3)-ng_si:,:)
    real(kind=dp_t), intent(in   ) :: tempbar_init_cart(lo(1)-ng_tc:,lo(2)-ng_tc:,lo(3)-ng_tc:)
    real(kind=dp_t), intent(  out) ::         snew(lo(1)-ng_so:,lo(2)-ng_so:,lo(3)-ng_so:,:)
    real(kind=dp_t), intent(  out) :: rho_omegadot(lo(1)-ng_rw:,lo(2)-ng_rw:,lo(3)-ng_rw:,:)
    real(kind=dp_t), intent(  out) ::     rho_Hnuc(lo(1)-ng_hn:,lo(2)-ng_hn:,lo(3)-ng_hn:)
    real(kind=dp_t), intent(in   ) ::     rho_Hext(lo(1)-ng_he:,lo(2)-ng_he:,lo(3)-ng_he:)
    real(kind=dp_t), intent(in   ) :: dt
    logical        , intent(in   ), optional :: mask(lo(1):,lo(2):,lo(3):)

    !     Local variables
    integer            :: i, j, k, n
    real (kind = dp_t) :: rho,T_in,ldt

    real (kind = dp_t) :: x_in(nspec)
    real (kind = dp_t) :: x_out(nspec)
    real (kind = dp_t) :: rhowdot(nspec)
    real (kind = dp_t) :: rhoH
    real (kind = dp_t) :: x_test
    logical            :: cell_valid
    integer, save      :: ispec_threshold
    logical, save      :: firstCall = .true.

    real (kind = dp_t) :: sumX
    real (kind = dp_t), parameter :: x_err = 1.d-10

    if (firstCall) then
       ispec_threshold = network_species_index(burner_threshold_species)
       firstCall = .false.
    endif

    ldt = dt

    !$OMP PARALLEL DO PRIVATE(i,j,k,cell_valid,rho,x_in,T_in,x_test,x_out,rhowdot,rhoH,sumX,n) &
    !$OMP FIRSTPRIVATE(ldt) &
    !$OMP SCHEDULE(DYNAMIC,1)
    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)

             ! make sure the cell isn't covered by finer cells
             cell_valid = .true.
             if ( present(mask) ) then
                if ( (.not. mask(i,j,k)) ) cell_valid = .false.
             end if

             if (cell_valid) then

                rho = sold(i,j,k,rho_comp)
                x_in = sold(i,j,k,spec_comp:spec_comp+nspec-1) / rho

                if (drive_initial_convection) then
                   T_in = tempbar_init_cart(i,j,k)
                else
                   T_in = sold(i,j,k,temp_comp)
                endif

                ! Fortran doesn't guarantee short-circuit evaluation of logicals
                ! so we need to test the value of ispec_threshold before using it
                ! as an index in x_in
                if (ispec_threshold > 0) then
                   x_test = x_in(ispec_threshold)
                else
                   x_test = ZERO
                endif

                ! if the threshold species is not in the network, then we burn
                ! normally.  if it is in the network, make sure the mass
                ! fraction is above the cutoff.
                if (rho > burning_cutoff_density .and.                      &
                     ( ispec_threshold < 0 .or.                              &
                     (ispec_threshold > 0 .and.                             &
                     x_test > burner_threshold_cutoff)                     &
                     )                                                       &
                     ) then
                   call burner(rho, T_in, x_in, ldt, x_out, rhowdot, rhoH)
                else
                   x_out = x_in
                   rhowdot = 0.d0
                   rhoH = 0.d0
                endif

                ! check if sum{X_k} = 1
                sumX = ZERO
                do n = 1, nspec
                   sumX = sumX + x_out(n)
                enddo
                if (abs(sumX - ONE) > x_err) then
                   call bl_error("ERROR: abundances do not sum to 1", abs(sumX-ONE))
                endif

                ! pass the density through
                snew(i,j,k,rho_comp) = sold(i,j,k,rho_comp)

                ! update the species
                snew(i,j,k,spec_comp:spec_comp+nspec-1) = x_out(1:nspec) * rho

                ! store the energy generation and species create quantities
                rho_omegadot(i,j,k,1:nspec) = rhowdot(1:nspec)
                rho_Hnuc(i,j,k) = rhoH

                ! update the enthalpy -- include the change due to external heating
                snew(i,j,k,rhoh_comp) = sold(i,j,k,rhoh_comp) &
                     + ldt*rho_Hnuc(i,j,k) + ldt*rho_Hext(i,j,k)

                ! pass the tracers through
                snew(i,j,k,trac_comp:trac_comp+ntrac-1) = &
                     sold(i,j,k,trac_comp:trac_comp+ntrac-1)

             end if

          enddo
       enddo
    enddo
    !$OMP END PARALLEL DO

  end subroutine burner_loop_3d_sph

end module react_state_module


      SUBROUTINE BINTGS (X,K)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /SETC/ A(7),B(7),SDUM(3),IDUM(2)
      DIMENSION FACT(17)
C**********************************************************************
C
C     BINTGS FORMS THE "B" INTEGRALS FOR THE OVERLAP CALCULATION.
C
C**********************************************************************
      DATA FACT/1.D0,2.D0,6.D0,24.D0,120.D0,720.D0,5040.D0,40320.D0,
     1362880.D0,3628800.D0,39916800.D0,479001600.D0,6227020800.D0,
     28.71782912D10,1.307674368D12,2.092278989D13,3.556874281D14/
      IO=0
      ABSX = ABS(X)
      IF (ABSX.GT.3.D00) GO TO 40
      IF (ABSX.LE.2.D00) GO TO 10
      IF (K.LE.10) GO TO 40
      LAST=15
      GO TO 60
   10 IF (ABSX.LE.1.D00) GO TO 20
      IF (K.LE.7) GO TO 40
      LAST=12
      GO TO 60
   20 IF (ABSX.LE.0.5D00) GO TO 30
      IF (K.LE.5) GO TO 40
      LAST=7
      GO TO 60
   30 IF (ABSX.LE.1.D-6) GOTO 90
      LAST=6
      GO TO 60
   40 EXPX=EXP(X)
      EXPMX=1.D00/EXPX
      B(1)=(EXPX-EXPMX)/X
      DO 50 I=1,K
   50 B(I+1)=(I*B(I)+(-1.D00)**I*EXPX-EXPMX)/X
      GO TO 110
   60 DO 80 I=IO,K
         Y=0.0D00
         DO 70 M=IO,LAST
            XF=1.0D00
            IF(M.NE.0) XF=FACT(M)
   70    Y=Y+(-X)**M*(2*MOD(M+I+1,2))/(XF*(M+I+1))
   80 B(I+1)=Y
      GO TO 110
   90 DO 100 I=IO,K
  100 B(I+1)=(2*MOD(I+1,2))/(I+1.D0)
  110 CONTINUE
      RETURN
C
      END


      double precision function fpot (r,z,wa)
      implicit double precision (a-h,o-z)
      save
c
c thomas fermi potential at the point r; z=atomic number
c wa=number of electrons-z-1
c **********************************************************************
      wc=sqrt((r*(z+wa)**(1.0/3.0))/0.88530)
      wd=wc*(0.601120*wc+1.810610)+1.0
      we=wc*(wc*(wc*(wc*(0.04793*wc+0.21465)+0.77112)+1.39515)+1
     1 .81061)+1.0
      wc=(z+wa)*(wd/we)**2-wa
      fpot=-wc/r
      return
      end


	SUBROUTINE UPDGDG  ( iret )
C************************************************************************
C* UPDGDG								*
C* 									*
C* This subroutine updates the common areas for graphs in the G 	*
C* coordinate system.							*
C* 									*
C* UPDGDG ( IRET )							*
C* 									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* M. desJardins/GSFC	9/85	GEMPLT Version 3.1			*
C* M. desJardins/GSFC	6/86	Corrected computations of all scalings	*
C* M. desJardins/GSFC	10/86	Added polar coordinate system		*
C* M. desJardins/GSFC	 6/88	Documentation				*
C************************************************************************
	INCLUDE		'DEVCHR.CMN'
	INCLUDE		'XYDEF.CMN'
	INCLUDE		'GEMPRM.PRM'
C-------------------------------------------------------------------------
C*	Do computations for graph mode.
C
	IF  ( ( igmode .eq. 2 ) .and. ggset ) THEN
C*
	    IF  ( ( jgytyp .eq. 1 ) .or. ( jgytyp .eq. 5 ) ) THEN
		yb = gybmg
		yt = gytmg
	      ELSE IF  ( jgytyp .eq. 2 )  THEN
		yb = ALOG ( gybmg )
		yt = ALOG ( gytmg )
	      ELSE IF  ( jgytyp .eq. 3 )  THEN
		yb = gybmg ** RKAPPA
		yt = gytmg ** RKAPPA
	    END IF
C
	    IF  ( ( jgxtyp .eq. 1 ) .or. ( jgxtyp .eq. 5 ) ) THEN
		xl = gxlmg
		xr = gxrmg
	      ELSE IF  ( jgxtyp .eq. 2 )  THEN
		xl = ALOG ( gxlmg )
		xr = ALOG ( gxrmg )
	      ELSE IF  ( jgxtyp .eq. 3 )  THEN
		xl = gxlmg ** RKAPPA
		xr = gxrmg ** RKAPPA
	    END IF
C
C*	    Save grid to linear ( 0. - 1. ) scaling terms for grid coord sys.
C
	    gxx1 = 1.0 / ( gpxr - gpxl )
	    gxx0 =   - ( gpxl * gxx1 )
	    gyy1 = 1.0 / ( gpyt - gpyb )
	    gyy0 =   - ( gpyb * gyy1 )
C
C*	    Compute scaling from (0.-1.) grid sys to values at points.
C
	    gglx1 = 1.0 / ( xr - xl )
	    gglx0 = - (gglx1 * xl)
	    ggly1 = 1.0 / ( yt - yb )
	    ggly0 = - ( ggly1 * yb )
	END IF
C*
	iret = 0
C*
	RETURN
	END


      SUBROUTINE MWATNA(ICAM,WALINE,WASAMP,NALINE,NASAMP,*)
C     11 AUG 93   ...DDK...  PORTED TO UNIX
C     2 SEPT 82   ...GMY...  UPDATE VGR2 USING NOV 79 RAND REPORT
C     3 NOV 80   ...GMY...    INITIAL RELEASE
C ROUTINE TO CONVERT WA (LINE,SAMP) COORDINATES TO NA (LINE,SAMP)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*4 WALINE,WASAMP,NALINE,NASAMP
      REAL*8 C(3,3),R(3)
      REAL*8 VGR1(3,3)/
     * 0.9999950588D0, 0.0031009104D0,-0.0005165310D0,
     *-0.0031011413D0, 0.9999950916D0,-0.0004467931D0,
     * 0.0005151430D0, 0.0004483927D0, 0.9999997668D0/
      REAL*8 VGR2(3,3)/
     * 0.9999966464D0, 0.0025303754D0, 0.0005516696D0,
     *-0.0025304697D0, 0.9999967838D0, 0.0001703842D0,
     *-0.0005512367D0,-0.0001717796D0, 0.9999998333D0/
      INTEGER*2 ICAM
      CHARACTER*50 MSG
C
      ISN = ABS(ICAM)
      IF(ISN.EQ.6.OR.ISN.EQ.7) GOTO 6
      IF(ISN.EQ.4.OR.ISN.EQ.5) GOTO 4
      WRITE(MSG,100) ISN
      CALL XVMESSAGE(MSG,' ')
  100 FORMAT(' **INVALID CAMERA S/N= ',I9)
      RETURN1
C
C          VGR2 WA,NA=4,5
    4 CALL MVE(7,18,VGR2,C,1,1)
      FNA = 1503.49D0
      FWA = 200.77D0
      GOTO 10
C          VGR1 WA,NA=6,7
    6 CALL MVE(7,18,VGR1,C,1,1)
      FNA = 1500.19D0
      FWA = 200.293D0
C
C          CONVERT TO MM (SCALE=PIXELS PER MM)
   10 SCALE = 84.821428D0
      X = (WASAMP-500.D0)/SCALE
      Y = (WALINE-500.D0)/SCALE
      Z = FWA
C          WA TO NA TRANSFORMATION
      DO 20 I=1,3
   20 R(I) = C(I,1)*X + C(I,2)*Y + C(I,3)*Z
C          CONVERT BACK TO PIXELS
      S = SCALE*FNA/R(3)
      NALINE = S*R(2) + 500.D0
      NASAMP = S*R(1) + 500.D0
      RETURN
      END


module mod_time_step_loop
  use mod_wrf_file
  use mod_subrs
  use mod_omega
  use mod_const
  use mod_common_subrs
  implicit none

contains

  subroutine time_step_loop ( wrfin_file, out_file, param, calc_b, debug)
    ! This subroutine contains the main time stepping loop. It gets both
    ! input and output files as input arguments.
    type ( wrf_file ), intent(in) :: wrfin_file, out_file
    type ( parameters), intent(in) :: param
    logical,           intent(in) :: debug, calc_b
    real, dimension ( :, :, : ), pointer :: T, u, v, z
    real, dimension ( :, :, :, : ), allocatable :: omegas, hTends, omegas_QG
    real, dimension ( :, :, : ),    allocatable :: dT_dt, du_dt, dv_dt, dz_dt, &
         fx, fy, q, w, mulfact,zeta, &
         zetatend,ukhi,vkhi,sigma,vadv, dudp, dvdp, &
         tadv,fvort,avortt, zeta_elcorr, sigma_elcorr
    real, dimension ( :, : ),       allocatable :: mu_inv, p_sfc
    integer, dimension ( : ),       allocatable :: tdim
    integer :: time, i

    associate ( &
         time_1 => param % time_1, &
         time_n => param % time_n, &
         alfa => param % alfa, &
         toler => param % toler, &
         ny1 => param % ny1, &
         ny2 => param % ny2, &
         mode => param % mode, &
         calc_omegas => param % calc_omegas, &
         calc_div => param % calc_div, &
         forc => param % forc, &
         ellipticity_correction => param % ellipticity_correction, &

         nlon   => wrfin_file % dims ( 1 ), &
         nlat   => wrfin_file % dims ( 2 ), &
         nlev   => wrfin_file % dims ( 3 ), &
         dx     => wrfin_file % dx(1), &
         dy     => wrfin_file % dy(1), &
         dlev     => wrfin_file % dlev(1), &
         p_levs => wrfin_file % pressure_levels, &
         corpar => wrfin_file % corpar )

    if (calc_b) then
       n_terms = n_terms + 1
    end if

    allocate ( tdim ( time_n-time_1+1 ) )
    allocate ( hTends ( nlon, nlat, nlev, n_terms ) )
    allocate ( omegas ( nlon, nlat, nlev, n_terms ) )
    allocate ( omegas_QG ( nlon, nlat, nlev, 3 ) )
    allocate ( ukhi (nlon, nlat, nlev) )
    allocate ( vkhi (nlon, nlat, nlev) )
    allocate ( avortt (nlon, nlat, nlev) )
    allocate ( fvort (nlon, nlat, nlev) )
    allocate ( sigma_elcorr (nlon, nlat, nlev) )
    allocate ( zeta_elcorr (nlon, nlat, nlev) )

    call read_T_u_v_z ( wrfin_file, time_1 - 2 )
    call read_T_u_v_z ( wrfin_file, time_1 - 1 )
    i=0
    do time = time_1, time_n
       i=i+1
       print *, 'Time step: ', time
       tdim(i)=time
       call read_T_u_v_z ( wrfin_file, time )
       mu_inv = 1.0 / real2d ( wrfin_file, time, [ 'MU ', 'MUB' ]  )
       q      = diabatic_heating ( wrfin_file, time, mu_inv )
       fx     = friction ( wrfin_file, time, 'U', mu_inv )
       fy     = friction ( wrfin_file, time, 'V', mu_inv )
       p_sfc  = real2d ( wrfin_file, time, [ 'PSFC' ]  )
       w      = real3d ( wrfin_file, time, [ 'WW' ]  )
       zeta   = curl_cart ( u, v, dx, dy )
       zetatend = curl_cart ( du_dt, dv_dt, dx, dy )
       mulfact  = calmul(p_sfc, p_levs, nlev)
       sigma = define_sigma(T, p_levs)

       dudp = pder(u,dlev)
       dvdp = pder(v,dlev)

       call calculate_ellipticity_correction (sigma, sigmamin, etamin, zeta, corpar,&
            dudp, dvdp, sigma_elcorr, zeta_elcorr)
       call write3d ( out_file, time-time_1+1, 'zeta_elcorr', zeta_elcorr)
       call write3d ( out_file, time-time_1+1, 'sigma_elcorr', sigma_elcorr)

       !   Calculation of velocity potential
       if(calc_div) call irrotationalWind(u,v,dx,dy,uKhi,vKhi)

       if ( calc_omegas ) then
          call calculate_omegas( wrfin_file, T, u, v, w, z, &
               q, fx, fy, dT_dt, zeta, zetatend, uKhi, vKhi, sigma, &
               mulfact, param, debug, calc_b, &
               omegas, omegas_QG, sigma_elcorr, zeta_elcorr, dudp, dvdp )
       else
          omegas = read_omegas ( out_file, time-time_1+1 )
       end if

       call calculate_tendencies ( omegas, T, u, v, w, z, p_levs, &
            dx, dy, corpar, q, fx, fy, dz_dt, dT_dt, zeta, zetatend, &
            uKhi, vKhi, sigma, mulfact, calc_b, hTends, vadv, tadv, &
            fvort, avortt )

       ! Write data to the output file
       if ( mode .eq. 'Q' ) then
          call write_omegas_QG ( out_file, time-time_1+1, omegas_QG, calc_b )
       else if ( mode .eq. 'G' ) then
          if (calc_omegas) then
             call write_omegas ( out_file, time-time_1+1, calc_b, omegas )
             call write3d ( out_file, time-time_1+1, ome_name, w)
          end if
          call write_height_tendencies(out_file,time-time_1+1,calc_b,hTends)
          call write3d ( out_file, time-time_1+1, ztend_name, dz_dt )
       end if

       call write3d ( out_file, time-time_1+1, 'GHT', z)
       call write2d ( out_file, time-time_1+1, 'PSFC', p_sfc)
       if (forc) then
          call write3d ( out_file, time-time_1+1, 'vadv', vadv)
          call write3d ( out_file, time-time_1+1, 'tadv', tadv)
          call write3d ( out_file, time-time_1+1, 'fvort', fvort)
          call write3d ( out_file, time-time_1+1, 'diab', q)
          call write3d ( out_file, time-time_1+1, 'ageo', avortt)
       end if

    end do

    ! Write dimension data to the output file
    if ( calc_omegas .or. mode .eq. 'Q' ) then
       call write_dimensions ( out_file, tdim )
    end if

  end associate

contains

  subroutine write_dimensions ( file, tdim )
    ! This subroutine writes dimension data to the output file.
    type ( wrf_file ) :: file
    integer,dimension(:) :: tdim
    integer :: varids(4),varid

    do i = 1, 4
       call check ( nf90_inq_varid ( &
            file % ncid, trim ( rname ( i ) ), varid ) )
       varids ( i ) = varid
    end do

    call check( nf90_put_var(file % ncid, varids(1), file%xdim(:)) )
    call check( nf90_put_var(file % ncid, varids(2), file%ydim(:)) )
    call check( nf90_put_var(file % ncid, varids(3), &
         file%pressure_levels(:)/100.) )
    call check( nf90_put_var(file % ncid, varids(4), tdim(:)) )

  end subroutine write_dimensions

  subroutine read_T_u_v_z ( file, time )
    ! This subroutine reads T,u,v and Z fields from the input file
    ! and calculate tendencies of them
    type ( wrf_file ) :: file
    integer, intent ( in ) :: time
    real, dimension ( :, :, :, :, : ), allocatable, target, save :: dtvars
    character ( 3 ), dimension ( 4 ), parameter :: &
         dtvar_names = [ 'TT ', 'UU ', 'VV ', 'GHT' ]
    integer, save :: prev = 1, curr = 2, next = 3
    real :: dt2inv
    integer :: i
    if ( .not. allocated ( dtvars ) ) then
       associate ( &
            nlon => file % dims ( 1 ), &
            nlat => file % dims ( 2 ), &
            nlev => file % dims ( 3 ) )
       allocate ( dtvars ( nlon, nlat, nlev, 4, 3 ) )
     end associate
  end if
  prev = curr
  curr = next
  next = mod ( next, 3 ) + 1
  T => dtvars ( :, :, :, 1, curr )
  u => dtvars ( :, :, :, 2, curr )
  v => dtvars ( :, :, :, 3, curr )
  z => dtvars ( :, :, :, 4, curr )
  do i = 1, 4
     dtvars ( :, :, :, i, next ) = real3d ( file, time + 1, &
          [ trim ( dtvar_names ( i ) ) ] )
  end do
  if ( time .gt. lbound ( file % times, 1 ) ) then
     dt2inv = 1.0 / ( file % times ( time + 1 ) - file % times ( time - 1 ))
     dT_dt = (dtvars( :, :, :, 1, next) - dtvars( :, :, :, 1,prev)) * dt2inv
     du_dt = (dtvars( :, :, :, 2, next) - dtvars( :, :, :, 2,prev)) * dt2inv
     dv_dt = (dtvars( :, :, :, 3, next) - dtvars( :, :, :, 3,prev)) * dt2inv
     dz_dt = (dtvars( :, :, :, 4, next) - dtvars( :, :, :, 4,prev)) * dt2inv
  end if
end subroutine read_T_u_v_z

function read_omegas ( file, time )
  type ( wrf_file ) :: file
  integer, intent ( in ) :: time
  real, dimension ( :, :, :, : ), allocatable :: read_omegas
  integer :: i
  associate ( nlon => file % dims ( 1 ), &
       nlat => file % dims ( 2 ), &
       nlev => file % dims ( 3 ), &
       nterms => size ( omega_term_names ) )
  allocate ( read_omegas ( nlon, nlat, nlev, nterms ) )
  do i = 1, nterms
     read_omegas ( :, :, :, i ) &
          = real3d ( file, time, [ trim ( omega_term_names ( i ) ) ] )
  end do
end associate
end function read_omegas

function diabatic_heating ( file, time, mu_inv ) result ( q )
type ( wrf_file ), intent ( in ) :: file
integer, intent ( in ) :: time
real, dimension ( :, : ), intent ( in ) :: mu_inv
real, dimension ( :, :, : ), allocatable :: q
integer :: lev
real :: a_lev
allocate ( q ( file % dims ( 1 ), file % dims ( 2 ), &
     file % dims ( 3 ) ) )
associate ( plev => file % pressure_levels )
select case ( file % wrf_cu_phys )
case ( 1 )
   !           q = real3d ( file, time, &
   !                [ 'RTHSHTEN', 'RTHCUTEN', 'RTHRATEN', 'RTHBLTEN' ] )
   q = real3d ( file, time, &
        [ 'RTHCUTEN', 'RTHRATEN', 'RTHBLTEN' ] )
end select
do lev = 1, size ( q, 3 )
   q ( :, :, lev ) = q ( :, :, lev ) * mu_inv
end do
q = q + real3d ( file, time, [ 'H_DIABATIC' ] )
do lev = 1, size ( plev )
   a_lev = ( plev ( lev ) / 100000.0 ) ** ( r / cp )
   q ( :, :, lev ) = q ( :, :, lev ) * a_lev
end do
end associate
end function diabatic_heating

function friction ( file, time, direction, mu_inv )
type ( wrf_file ), intent ( in ) :: file
integer, intent ( in ) :: time
character ( 1 ), intent ( in ) :: direction
real, dimension ( :, : ), intent ( in ) :: mu_inv
real, dimension ( :, :, : ), allocatable :: friction
integer :: lev
allocate ( friction ( file % dims ( 1 ), file % dims ( 2 ), &
   file % dims ( 3 ) ) )
select case ( file % wrf_cu_phys )
case ( 1 )
   !         friction = real3d ( file, time, &
   !              [ 'R'//direction//'SHTEN', 'R'//direction//'CUTEN', &
   !              'R'//direction//'BLTEN' ] )
 friction = real3d ( file, time, &
      [ 'R'//direction//'CUTEN', &
      'R'//direction//'BLTEN' ] )
end select
do lev = 1, size ( friction, 3 )
 friction ( :, :, lev ) = friction ( :, :, lev ) * mu_inv
end do
end function friction

subroutine write_height_tendencies ( file, time, calc_b, hTends )
type ( wrf_file ), intent ( in ) :: file
integer, intent ( in ) :: time
logical, intent ( in ) :: calc_b
real, dimension ( :, :, :, : ) :: hTends
integer :: t, varid
associate ( &
   ncid => file % ncid, &
   nlon => file % dims ( 1 ), &
   nlat => file % dims ( 2 ), &
   nlev => file % dims ( 3 ) )
do t = 1, size ( htend_term_names )
 call check ( nf90_inq_varid ( ncid, &
      trim ( htend_term_names ( t ) ), varid ) )
 call check ( nf90_put_var ( ncid, varid, &
      hTends ( :, :, :, t ), &
      [ 1, 1, 1, time ], &
      [ nlon, nlat, nlev, 1 ] ) )
end do

if (calc_b) then
 call check ( nf90_inq_varid ( ncid, &
      trim ( htend_b_name ), varid ) )
 call check ( nf90_put_var ( ncid, varid, &
      hTends ( :, :, :, 8 ), &
      [ 1, 1, 1, time ], &
      [ nlon, nlat, nlev, 1 ] ) )
end if
end associate
end subroutine write_height_tendencies

subroutine write_omegas ( file, time, calc_b, omegas )
type ( wrf_file ), intent ( in ) :: file
integer, intent ( in ) :: time
logical, intent ( in ) :: calc_b
real, dimension ( :, :, :, : ) :: omegas
integer :: t, varid
associate ( &
 ncid => file % ncid, &
 nlon => file % dims ( 1 ), &
 nlat => file % dims ( 2 ), &
 nlev => file % dims ( 3 ) )
do t = 1, size ( omega_term_names )
call check ( nf90_inq_varid ( ncid, &
    trim ( omega_term_names ( t ) ), varid ) )
call check ( nf90_put_var ( ncid, varid, &
    omegas ( :, :, :, t ), &
    [ 1, 1, 1, time ], &
    [ nlon, nlat, nlev, 1 ] ) )
end do

if (calc_b) then
call check ( nf90_inq_varid ( ncid, &
    trim ( ome_b_name ), varid ) )
call check ( nf90_put_var ( ncid, varid, &
    omegas ( :, :, :, 8 ), &
    [ 1, 1, 1, time ], &
    [ nlon, nlat, nlev, 1 ] ) )
end if

end associate
end subroutine write_omegas

subroutine write_omegas_QG ( file, time, omegas_QG, calc_b )
type ( wrf_file ), intent ( in ) :: file
integer, intent ( in ) :: time
logical, intent(in) :: calc_b
real, dimension ( :, :, :, : ) :: omegas_QG
integer :: t, varid
associate ( &
ncid => file % ncid, &
nlon => file % dims ( 1 ), &
nlat => file % dims ( 2 ), &
nlev => file % dims ( 3 ) )
do t = 1, size ( QG_omega_term_names )
call check ( nf90_inq_varid ( ncid, &
  trim ( QG_omega_term_names ( t ) ), varid ) )
call check ( nf90_put_var ( ncid, varid, &
  omegas_QG ( :, :, :, t ), &
  [ 1, 1, 1, time ], &
  [ nlon, nlat, nlev, 1 ] ) )
end do

if (calc_b) then
call check ( nf90_inq_varid ( ncid, &
  trim ( ome_b_name ), varid ) )
call check ( nf90_put_var ( ncid, varid, &
  omegas ( :, :, :, 8 ), &
  [ 1, 1, 1, time ], &
  [ nlon, nlat, nlev, 1 ] ) )
end if

end associate
end subroutine write_omegas_QG

subroutine write3d ( file, time, name, data )
type ( wrf_file ), intent ( in ) :: file
integer, intent ( in ) :: time
character(*) :: name
real, dimension ( :, :, : ) :: data
integer :: varid

associate ( &
ncid => file % ncid, &
nlon => file % dims ( 1 ), &
nlat => file % dims ( 2 ), &
nlev => file % dims ( 3 ) )

call check ( nf90_inq_varid ( ncid, &
trim ( name ), varid ) )
call check ( nf90_put_var ( ncid, varid, &
data ( :, :, : ), &
[ 1, 1, 1, time ], &
[ nlon, nlat, nlev, 1 ] ) )

end associate

end subroutine write3d

subroutine write2d ( file, time, name, data )
type ( wrf_file ), intent ( in ) :: file
integer, intent ( in ) :: time
character(*) :: name
real, dimension ( :, : ) :: data
integer :: varid

associate ( &
ncid => file % ncid, &
nlon => file % dims ( 1 ), &
nlat => file % dims ( 2 ) )

call check ( nf90_inq_varid ( ncid, &
trim ( name ), varid ) )
call check ( nf90_put_var ( ncid, varid, &
data, [ 1, 1, time ], &
[ nlon, nlat, 1 ] ) )

end associate

end subroutine write2d
end subroutine time_step_loop

end module mod_time_step_loop


  module fluid_model_phatdisk
! Standard NT73 thin disk model

  use class_four_vector
  use kerr, only: calc_rms, krolikc, ledd
  use phys_constants, only: G, c2, pi, sigb, msun, h, kb => k
  use fluid_model_thindisk, only: init_thindisk, thindisk_vals, MBH, Mdot
  use math, only: tsum
  use interpolate, only: get_weight

  implicit none

  namelist /phatdisk/ nw, wmin, wmax, nfreq_tab, fmin, fmax, rmax, nr, sigt, fcol

  real :: fmin,fmax, wmin, wmax, rmax, sigt, fcol
  integer :: nw, nfreq_tab, nr
  real, dimension(:), allocatable :: freq_tab, w, r_tab, om_tab
  real(kind=8), dimension(:,:), allocatable :: fnu_tab

  interface phatdisk_vals
    module procedure phatdisk_vals
  end interface

  interface init_phatdisk
     module procedure init_phatdisk
  end interface

  contains

    subroutine read_phatdisk_inputs(ifile)
    character(len=20), intent(in) :: ifile
    integer :: i
    open(unit=8,file=ifile,form='formatted',status='old')
    read(8,nml=phatdisk)
    close(unit=8)
    write(6,*) 'read phat: ',nfreq_tab
    allocate(freq_tab(nfreq_tab)); allocate(w(nw)); allocate(r_tab(nr))
    allocate(om_tab(nr)); allocate(fnu_tab(nr,nfreq_tab))
    if(nfreq_tab==1) then
       freq_tab=(/fmin/)
    else
       freq_tab=fmin*exp((/(i-1,i=1,nfreq_tab)/)*log(fmax/fmin)/(nfreq_tab-1))
    endif
    if(nw==1) then
       w=(/wmin/)
    else
       w=wmin*exp((/(i-1,i=1,nw)/)*log(wmax/wmin)/(nw-1))
    endif
    end subroutine read_phatdisk_inputs

    subroutine init_phatdisk(a,ifile,nwt,wmint,wmaxt,nft,fmint,fmaxt, &
         nrt,sigtt,fcolt)
    real, intent(in) :: a
    character(len=20), intent(in), optional :: ifile
    character(len=20) :: default_ifile='phatdisk.in'
    integer, intent(in), optional :: nwt,nft,nrt
    real, intent(in), optional :: wmint,wmaxt,fmint,fmaxt,sigtt,fcolt
    real :: rh,l10sigt
    real, dimension(:), allocatable :: x, fw, zero, denom
    real, dimension(:), allocatable :: z, T, tsum_arr,igrand
    integer :: i,k
!    write(6,*) 'init phat'
!    write(6,*) 'init phat: ',a
    call init_thindisk(a,ifile)
    if (present(nwt)) then
       nw = nwt
       wmin = wmint
       wmax = wmaxt
       nfreq_tab = nft
       fmin = fmint
       fmax = fmaxt
       nr = nrt
       sigt = sigtt
       fcol = fcolt
    else
       if (present(ifile)) then
          call read_phatdisk_inputs(ifile)
       else
          call read_phatdisk_inputs(default_ifile)
       end if
    endif
    allocate(z(nr)); allocate(T(nr)); allocate(x(nw)); allocate(fw(nw))
    allocate(tsum_arr(nw)); allocate(zero(nw)); allocate(igrand(nw))
    allocate(denom(nw))
    zero=0.
!    write(6,*) 'after phat inputs: ',sigt,nw,a,nr,rmax
    l10sigt=log(10.)*sigt
    x=log(w)
! Set up tables of values
!    rms=calc_rms(a)
    rh=1.+sqrt(1.-a*a)
!    write(6,*) 'r_tab: ',rh,nr,maxval((/(i,i=1,nr)/)),rmax
!    write(6,*) 'array: ',(/(i,i=1,nr)/)
    r_tab=rh*exp((/(i,i=1,nr)/)/real(nr-1)*alog(rmax/rh))
!    write(6,*) 'r_tab: ',maxval(r_tab)
! Thin disk solution:
!    write(6,*) 'before thindisk_vals', size(r_tab), size(T)
    call thindisk_vals(r_tab,r_tab*0.,a,T,om_tab)
!    write(6,*) 'after thindisk: ',r_tab
!    write(6,*) 'after thindisk: ',om_tab
!    write(6,*) 'after thindisk: ',T
! Now calculate log-normal flux:
!    fw=exp(-(log(w)+2.*sigf*sigf)**2/(2.*sigf*sigf))/sigf/sqrt(2.*pi)/w
!    write(6,*) 'l10sigt: ',l10sigt**2., x
    fw=exp(-(x+l10sigt**2.)**2./l10sigt**2.)/l10sigt/sqrt(pi)
!    write(6,*) 'fw: ',fw
!    fw=exp(-(log(w)+(l10sigt)**2.)**2./l10sigt**2.)/w/l10sigt/sqrt(pi)
    write(6,*) 'freq_tab: ',fcol, x(2)-x(1), x(nw)-x(nw-1)
    do k=1,nfreq_tab
       z=h*freq_tab(k)/kb/T/fcol
!       write(6,*) 'z: ',minval(z), maxval(z)
       do i=1,nr
! Set integrand to zero where fw=0
          denom=merge(exp(z(i)/exp(x))-1.,z(i)/exp(x),z(i)/exp(x) > 1.e-4)
          igrand=merge(fw/denom,zero,fw > 0.)
          tsum_arr=tsum(dble(x),dble(igrand))
!          tsum_arr=sum((x(2)-x(1))*igrand)
          fnu_tab(i,k)=fcol**(-4.)*2.*pi*z(i)**3*(kb*fcol*T(i))**3/h/h/c2*tsum_arr(nw)
       enddo
    enddo
!    write(6,*) 'fnu_tab: ',minval(fnu_tab),maxval(fnu_tab),fnu_tab(:,nfreq_tab)
    deallocate(z); deallocate(T); deallocate(x); deallocate(fw)
    deallocate(tsum_arr); deallocate(zero)
    end subroutine init_phatdisk

    subroutine phatdisk_vals(r,a,fnu,omega)
    real, intent(in), dimension(:) :: r
    real, intent(in) :: a
    real, intent(out), dimension(size(r)) :: omega
    real, intent(out), dimension(size(r),nfreq_tab) :: fnu
    integer :: i
    integer, dimension(size(r)) :: indx
    real, dimension(size(r)) :: weight
    call get_weight(r_tab,r,indx,weight)
!    write(6,*) 'weight: ',size(r_tab),size(r)
    do i=1,nfreq_tab
       fnu(:,i)=(1.-weight)*fnu_tab(indx,i)+weight*fnu_tab(indx+1,i)
    enddo
    omega=(1.-weight)*om_tab(indx)+weight*om_tab(indx+1)
    end subroutine phatdisk_vals

    subroutine del_phatdisk()
    deallocate(w); deallocate(freq_tab)
    deallocate(fnu_tab); deallocate(r_tab); deallocate(om_tab)
    end subroutine del_phatdisk

  end module fluid_model_phatdisk


C Various CERNLIB mathematical routines needed for the optimum interval,
C as modified from 2006_src.tar.gz to not call other cernlib routines.
C See http://cernlib.web.cern.ch/cernlib/download/2006_source/tar/
C
      FUNCTION DFREQ(X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C
C
      DIMENSION P1(0:3),Q1(0:3),P2(0:7),Q2(0:7),P3(0:4),Q3(0:4)

      PARAMETER(Z1 = 1, HF = Z1/2)
      PARAMETER(C1 = 0.56418 95835 47756 29D0)
      PARAMETER(W2 = 1.41421 35623 73095 05D0, RW2 = 1/W2)

      DATA (P1(I),Q1(I),I=0,3)
     +/+2.42667 95523 05317 5D+2, +2.15058 87586 98612 0D+2,
     1 +2.19792 61618 29415 2D+1, +9.11649 05404 51490 1D+1,
     2 +6.99638 34886 19135 5D+0, +1.50827 97630 40778 7D+1,
     3 -3.56098 43701 81538 5D-2, +1/

      DATA (P2(I),Q2(I),I=0,7)
     +/+3.00459 26102 01616 01D+2, +3.00459 26095 69832 93D+2,
     1 +4.51918 95371 18729 42D+2, +7.90950 92532 78980 27D+2,
     2 +3.39320 81673 43436 87D+2, +9.31354 09485 06096 21D+2,
     3 +1.52989 28504 69404 04D+2, +6.38980 26446 56311 67D+2,
     4 +4.31622 27222 05673 53D+1, +2.77585 44474 39876 43D+2,
     5 +7.21175 82508 83093 66D+0, +7.70001 52935 22947 30D+1,
     6 +5.64195 51747 89739 71D-1, +1.27827 27319 62942 35D+1,
     7 -1.36864 85738 27167 07D-7, +1/

      DATA (P3(I),Q3(I),I=0,4)
     +/-2.99610 70770 35421 74D-3, +1.06209 23052 84679 18D-2,
     1 -4.94730 91062 32507 34D-2, +1.91308 92610 78298 41D-1,
     2 -2.26956 59353 96869 30D-1, +1.05167 51070 67932 07D+0,
     3 -2.78661 30860 96477 88D-1, +1.98733 20181 71352 56D+0,
     4 -2.23192 45973 41846 86D-2, +1/

      V=RW2*ABS(X)
      IF(V .LT. HF) THEN
       Y=V**2
       AP=P1(3)
       AQ=Q1(3)
       DO 1 I = 2,0,-1
       AP=P1(I)+Y*AP
    1  AQ=Q1(I)+Y*AQ
       H=V*AP/AQ
       HC=1-H
      ELSEIF(V .LT. 4) THEN
       AP=P2(7)
       AQ=Q2(7)
       DO 2 I = 6,0,-1
       AP=P2(I)+V*AP
    2  AQ=Q2(I)+V*AQ
       HC=EXP(-V**2)*AP/AQ
       H=1-HC
      ELSE
       Y=1/V**2
       AP=P3(4)
       AQ=Q3(4)
       DO 3 I = 3,0,-1
       AP=P3(I)+Y*AP
    3  AQ=Q3(I)+Y*AQ
       HC=EXP(-V**2)*(C1+Y*AP/AQ)/V
       H=1-HC
      ENDIF
      IF(X .GT. 0) THEN
       DFREQ=HF+HF*H
      ELSE
       DFREQ=HF*HC
      ENDIF
      RETURN
      END
      FUNCTION DGAUSN(P)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C     Computes a "Normal Deviate"
C     Based on G.W. Hill & A.W. Davis, Algorithm 442 Normal Deviate
C     Collected Algorithms from CACM

C
      PARAMETER (C = 2.50662 82746 31000 50D0)
      PARAMETER (Z1 = 1, HF = Z1/2, C1 = 3*Z1/4, C2 = 7*Z1/8, C3 = Z1/3)

      IF(P .LE. 0 .OR. P .GE. 1) THEN
       H=0
       WRITE(6,101) P
      ELSEIF(P .EQ. HF) THEN
       H=0
      ELSE
       X=P
       IF(P .GT. HF) X=1-P
       X=SQRT(-2*LOG(X))
       X=X-((7.47395*X+494.877)*X+1637.720)/
     1     (((X+117.9407)*X+908.401)*X+659.935)
       IF(P .LT. HF) X=-X
       S=X**2
       Z=C*(P-DFREQ(X))*EXP(HF*S)
       H=(((((C1*S+C2)*Z+X)*X+HF)*C3*Z+HF*X)*Z+1)*Z+X
      ENDIF
      DGAUSN=H
      RETURN
  101 FORMAT('ARGUMENT P =',1P,D15.8,' NOT IN RANGE')
      END

      FUNCTION GAMDIS(X,A)
      IMPLICIT REAL (A-H,O-Z)
C     Calculates the gamma distribution function
C
C        G(x,a) = (1/gamma(a)) * int(0,x)[exp(-t) * t**(a-1)] dt.
C
C     Based on
C        W. Gautschi, ALGORITHM 542 Incomplete Gamma Functions,
C        ACM Trans. Math. Software 5 (1979) 482-489.

      DIMENSION C(14)

      PARAMETER (EPS = 1E-5, EPS1 = 5E-7)
      PARAMETER (ALH = -0.69314 72)
      PARAMETER (Z1 = 1, HALF = Z1/2, QUAR = Z1/4)
      PARAMETER (C1 = 3*Z1/2, KMAX = 300)

      DATA C
     1/ 0.5772157,-0.6558781,-0.0420026, 0.1665386,-0.0421977,
     2 -0.0096220, 0.0072189,-0.0011652,-0.0002152, 0.0001281,
     3 -0.0000201,-0.0000013, 0.0000011,-0.0000002/

      HST=0
      IF(X .EQ. 0) GO TO 99
      IF(X .LT. 0 .OR. A .LE. 0) THEN
       WRITE(6,101) X,A
       GO TO 99
      ELSE
       ALX=LOG(X)
      ENDIF
      IF(X .LT. QUAR) THEN
       ALFA=ALH/ALX
      ELSE
       ALFA=X+QUAR
      ENDIF
      IF(A .GT. ALFA) THEN
       TERM=1
       SUM=1
       DO 1 K = 1,KMAX
       TERM=X*TERM/(A+K)
       SUM=SUM+TERM
       IF(ABS(TERM) .LE. EPS*SUM) GO TO 2
    1  CONTINUE
       GO TO 98
    2  HST=SUM*EXP(A*ALX-X-ALOGAM(1+A))
      ELSEIF(X .GT. C1) THEN
       P=0
       S=1-A
       Q=(X+S)*(X-1-A)
       R=4*(X+S)
       TERM=1
       SUM=1
       RHO=0
       DO 3 K = 2,KMAX
       P=P+S
       Q=Q+R
       R=R+8
       S=S+2
       T=P*(1+RHO)
       RHO=T/(Q-T)
       TERM=RHO*TERM
       SUM=SUM+TERM
       IF(ABS(TERM) .LE. EPS*SUM) GO TO 4
    3  CONTINUE
       GO TO 98
    4  HST=1-(A*SUM/(X+1-A))*EXP(A*ALX-X-ALOGAM(1+A))
      ELSE
       IF(A .LT. HALF) THEN
        SUM=C(14)
        DO 12 K = 13,1,-1
   12   SUM=A*SUM+C(K)
        GA=-SUM/(1+A*SUM)
        Y=A*ALX
        IF(ABS(Y) .GE. 1) THEN
         U=GA-(EXP(Y)-1)/A
        ELSE
         SUM=1
         TERM=1
         DO 7 K = 2,KMAX
         TERM=Y*TERM/K
         SUM=SUM+TERM
         IF(ABS(TERM) .LE. EPS1*SUM) GO TO 8
    7    CONTINUE
         GO TO 98
    8    U=GA-SUM*ALX
        ENDIF
       ELSE
        U=GAMMA(A)-EXP(A*ALX)/A
       ENDIF
       P=A*X
       Q=A+1
       R=A+3
       TERM=1
       SUM=1
       DO 9 K = 2,KMAX
       P=P+X
       Q=Q+R
       R=R+2
       TERM=-P*TERM/Q
       SUM=SUM+TERM
       IF(ABS(TERM) .LE. EPS1*SUM) GO TO 10
    9  CONTINUE
       GO TO 98
   10  HST=1-A*(U+SUM*EXP((1+A)*ALX)/(1+A))/GAMMA(1+A)
      ENDIF
   99 GAMDIS=HST
      RETURN

   98 WRITE(6,102) X,A
      GO TO 99
  101 FORMAT('ILLEGAL ARGUMENT(S) X = ',E15.8,'  A = ',E15.8)
  102 FORMAT('PROBLEMS WITH CONVERGENCE, X = ',E15.8,'  A = ',E15.8)
      END
      SUBROUTINE RZERO(A,B,X0,R,EPS,MXF,F)
      IMPLICIT REAL (A-H,O-Z)

      EXTERNAL F

      PARAMETER (ONE = 1, HALF = ONE/2)

      XA=MIN(A,B)
      XB=MAX(A,B)
      FA=F(XA,1)
      FB=F(XB,2)
      IF(FA*FB .GT. 0) GO TO 5
      MC=0

    1 X0=HALF*(XA+XB)
      R=X0-XA
      EE=EPS*(ABS(X0)+1)
      IF(R .LE. EE) GO TO 4
      F1=FA
      X1=XA
      F2=FB
      X2=XB

    2 FX=F(X0,2)
      MC=MC+1
      IF(MC .GT. MXF) GO TO 6
      IF(FX*FA .GT. 0) THEN
       XA=X0
       FA=FX
      ELSE
       XB=X0
       FB=FX
      END IF

    3 U1=F1-F2
      U2=X1-X2
      U3=F2-FX
      U4=X2-X0
      IF(U2 .EQ. 0 .OR. U4 .EQ. 0) GO TO 1
      F3=FX
      X3=X0
      U1=U1/U2
      U2=U3/U4
      CA=U1-U2
      CB=(X1+X2)*U2-(X2+X0)*U1
      CC=(X1-X0)*F1-X1*(CA*X1+CB)
      IF(CA .EQ. 0) THEN
       IF(CB .EQ. 0) GO TO 1
       X0=-CC/CB
      ELSE
       U3=CB/(2*CA)
       U4=U3*U3-CC/CA
       IF(U4 .LT. 0) GO TO 1
       X0=-U3+SIGN(SQRT(U4),X0+U3)
      END IF
      IF(X0 .LT. XA .OR. X0 .GT. XB) GO TO 1

      R=MIN(ABS(X0-X3),ABS(X0-X2))
      EE=EPS*(ABS(X0)+1)
      IF(R .GT. EE) THEN
       F1=F2
       X1=X2
       F2=F3
       X2=X3
       GO TO 2
      END IF

      FX=F(X0,2)
      IF(FX .EQ. 0) GO TO 4
      IF(FX*FA .LT. 0) THEN
       XX=X0-EE
       IF(XX .LE. XA) GO TO 4
       FF=F(XX,2)
       FB=FF
       XB=XX
      ELSE
       XX=X0+EE
       IF(XX .GE. XB) GO TO 4
       FF=F(XX,2)
       FA=FF
       XA=XX
      END IF
      IF(FX*FF .GT. 0) THEN
       MC=MC+2
       IF(MC .GT. MXF) GO TO 6
       F1=F3
       X1=X3
       F2=FX
       X2=X0
       X0=XX
       FX=FF
       GO TO 3
      END IF

    4 R=EE
      FF=F(X0,3)
      RETURN
    5 Continue
      WRITE(*,100)
      R=-2*(XB-XA)
      X0=0
      RETURN
    6 Continue
      WRITE(*,101)
      R=-HALF*ABS(XB-XA)
      X0=0
      RETURN
  100 FORMAT(1X,'***** Modified RZERO ... F(A) AND F(B)',
     1          ' HAVE THE SAME SIGN')
  101 FORMAT(1X,'***** Modified RZERO ... TOO MANY FUNCTION CALLS')
      END

      FUNCTION ALGAMA(X)
C
C
      DIMENSION P1(7),Q1(7),P2(7),Q2(7),P3(7),Q3(7),C(5)

      PARAMETER (Z1 = 1, HF = Z1/2, HF1 = 1+HF)
      DATA P1
     1/+3.84287 36567 45991D+0, +5.27068 93753 00983D+1,
     2 +5.55840 45723 51531D+1, -2.15135 13573 72570D+2,
     3 -2.45872 61722 29242D+2, -5.75008 93603 04123D+1,
     4 -2.33590 98949 51284D+0/
      DATA Q1
     1/+1.00000 00000 00000D+0, +3.37330 47907 07074D+1,
     2 +1.93877 84034 37713D+2, +3.08829 54973 42428D+2,
     3 +1.50068 39064 89095D+2, +2.01068 51344 33395D+1,
     4 +4.57174 20282 50299D-1/
      DATA P2
     1/+4.87402 01396 83863 6D+0, +2.48845 25168 57407 6D+2,
     2 +2.17973 66058 89591 5D+3, +3.79751 24011 52511 8D+3,
     3 -1.97780 70769 84164 6D+3, -3.69298 34005 59128 2D+3,
     4 -5.60177 73537 80387 7D+2/
      DATA Q2
     1/+1.00000 00000 00000 0D+0, +9.50999 17418 20893 8D+1,
     2 +1.56120 45277 92863 5D+3, +7.23400 87928 94807 1D+3,
     3 +1.04595 76594 05895 9D+4, +4.16994 15153 20023 1D+3,
     4 +2.76785 83623 80410 1D+2/
      DATA P3
     1/-6.88062 40094 59425D+3, -4.30699 69819 57098D+5,
     2 -4.75045 94653 43956D+6, -2.94234 45930 32234D+6,
     3 +3.63218 04931 54257D+7, -3.35677 82814 54576D+6,
     4 -2.48043 69488 28593D+7/
      DATA Q3
     1/+1.00000 00000 00000D+0, -1.42168 29839 65146D+3,
     2 -1.55528 90280 85353D+5, -3.41525 17108 01107D+6,
     3 -2.09696 23255 80444D+7, -3.45441 75093 34395D+7,
     4 -9.16055 82863 71317D+6/
      DATA C
     1/ 1.12249 21356 561D-1,  7.95916 92961 204D-2,
     1 -1.70877 94611 020D-3,  9.18938 53320 467D-1,
     2  1.34699 05627 879D+0/

      ENTRY ALOGAM(X)

      IF(X .LE. 0) THEN
       H=0
       WRITE(6,101) X
      ELSE IF(X .EQ. 1 .OR. X .EQ. 2) THEN
       H=0
      ELSE IF(X .LE. HF) THEN
       Y=X+1
       AP=P1(1)
       AQ=Q1(1)
       DO 2 I = 2,7
       AP=P1(I)+Y*AP
    2  AQ=Q1(I)+Y*AQ
       H=-LOG(X)+X*AP/AQ
      ELSE IF(X .LE. HF1) THEN
       AP=P1(1)
       AQ=Q1(1)
       DO 3 I = 2,7
       AP=P1(I)+X*AP
    3  AQ=Q1(I)+X*AQ
       H=(X-1)*AP/AQ
      ELSE IF(X .LE. 4) THEN
       AP=P2(1)
       AQ=Q2(1)
       DO 4 I = 2,7
       AP=P2(I)+X*AP
    4  AQ=Q2(I)+X*AQ
       H=(X-2)*AP/AQ
      ELSE IF(X .LE. 12) THEN
       AP=P3(1)
       AQ=Q3(1)
       DO 5 I = 2,7
       AP=P3(I)+X*AP
    5  AQ=Q3(I)+X*AQ
       H=AP/AQ
      ELSE
       Y=1/X**2
       H=(X-HF)*LOG(X)-X+C(4)+(C(1)+Y*(C(2)+Y*C(3)))/
     1                                        ((C(5)+Y)*X)
      ENDIF
      ALGAMA=H
      RETURN
  101 FORMAT('NON-POSITIVE ARGUMENT  X = ',1P,E15.6)
      END
      FUNCTION GAMMA(X)
      IMPLICIT REAL (A-H,O-Z)
C
      DIMENSION C(0:15)

      DATA C( 0) /3.65738 77250 83382 44D0/
      DATA C( 1) /1.95754 34566 61268 27D0/
      DATA C( 2) /0.33829 71138 26160 39D0/
      DATA C( 3) /0.04208 95127 65575 49D0/
      DATA C( 4) /0.00428 76504 82129 09D0/
      DATA C( 5) /0.00036 52121 69294 62D0/
      DATA C( 6) /0.00002 74006 42226 42D0/
      DATA C( 7) /0.00000 18124 02333 65D0/
      DATA C( 8) /0.00000 01096 57758 66D0/
      DATA C( 9) /0.00000 00059 87184 05D0/
      DATA C(10) /0.00000 00003 07690 81D0/
      DATA C(11) /0.00000 00000 14317 93D0/
      DATA C(12) /0.00000 00000 00651 09D0/
      DATA C(13) /0.00000 00000 00025 96D0/
      DATA C(14) /0.00000 00000 00001 11D0/
      DATA C(15) /0.00000 00000 00000 04D0/

      U=X
      IF(U .LE. 0) THEN
       WRITE(6,101) U
       H=0
       B0=0
       B2=0
       F=0
       GO TO 9
      ENDIF
    8 F=1
      IF(U .LT. 3) THEN
       DO 1 I = 1,INT(4-U)
       F=F/U
    1  U=U+1
      ELSE
       DO 2 I = 1,INT(U-3)
       U=U-1
    2  F=F*U
      END IF
      H=U+U-7
      ALFA=H+H
      B1=0
      B2=0
      DO 3 I = 15,0,-1
      B0=C(I)+ALFA*B1-B2
      B2=B1
    3 B1=B0
    9 GAMMA =F*(B0-H*B2)
      RETURN
  101 FORMAT('ARGUMENT IS NEGATIVE = ',1P,E15.1)
      END
      SUBROUTINE RANLUX(RVEC,LENV)
C         Subtract-and-borrow random number generator proposed by
C         Marsaglia and Zaman, implemented by F. James with the name
C         RCARRY in 1991, and later improved by Martin Luescher
C         in 1993 to produce "Luxury Pseudorandom Numbers".
C     Fortran 77 coded by F. James, 1993
C
C   LUXURY LEVELS.
C   ------ ------      The available luxury levels are:
C
C  level 0  (p=24): equivalent to the original RCARRY of Marsaglia
C           and Zaman, very long period, but fails many tests.
C  level 1  (p=48): considerable improvement in quality over level 0,
C           now passes the gap test, but still fails spectral test.
C  level 2  (p=97): passes all known tests, but theoretically still
C           defective.
C  level 3  (p=223): DEFAULT VALUE.  Any theoretically possible
C           correlations have very small chance of being observed.
C  level 4  (p=389): highest possible luxury, all 24 bits chaotic.
C
C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C!!!  Calling sequences for RANLUX:                                  ++
C!!!      CALL RANLUX (RVEC, LEN)   returns a vector RVEC of LEN     ++
C!!!                   32-bit random floating point numbers between  ++
C!!!                   zero (not included) and one (also not incl.). ++
C!!!      CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from  ++
C!!!               one 32-bit integer INT and sets Luxury Level LUX  ++
C!!!               which is integer between zero and MAXLEV, or if   ++
C!!!               LUX .GT. 24, it sets p=LUX directly.  K1 and K2   ++
C!!!               should be set to zero unless restarting at a break++
C!!!               point given by output of RLUXAT (see RLUXAT).     ++
C!!!      CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++
C!!!               which can be used to restart the RANLUX generator ++
C!!!               at the current point by calling RLUXGO.  K1 and K2++
C!!!               specify how many numbers were generated since the ++
C!!!               initialization with LUX and INT.  The restarting  ++
C!!!               skips over  K1+K2*E9   numbers, so it can be long.++
C!!!   A more efficient but less convenient way of restarting is by: ++
C!!!      CALL RLUXIN(ISVEC)    restarts the generator from vector   ++
C!!!                   ISVEC of 25 32-bit integers (see RLUXUT)      ++
C!!!      CALL RLUXUT(ISVEC)    outputs the current values of the 25 ++
C!!!                 32-bit integer seeds, to be used for restarting ++
C!!!      ISVEC must be dimensioned 25 in the calling program        ++
C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      DIMENSION RVEC(LENV)
      DIMENSION SEEDS(24), ISEEDS(24), ISDEXT(25)
      PARAMETER (MAXLEV=4, LXDFLT=3)
      DIMENSION NDSKIP(0:MAXLEV)
      DIMENSION NEXT(24)
      PARAMETER (TWOP12=4096., IGIGA=1000000000,JSDFLT=314159265)
      PARAMETER (ITWO24=2**24, ICONS=2147483563)
      SAVE NOTYET, I24, J24, CARRY, SEEDS, TWOM24, TWOM12, LUXLEV
      SAVE NSKIP, NDSKIP, IN24, NEXT, KOUNT, MKOUNT, INSEED
      INTEGER LUXLEV
      LOGICAL NOTYET
      DATA NOTYET, LUXLEV, IN24, KOUNT, MKOUNT /.TRUE., LXDFLT, 0,0,0/
      DATA I24,J24,CARRY/24,10,0./
C                               default
C  Luxury Level   0     1     2   *3*    4
      DATA NDSKIP/0,   24,   73,  199,  365 /
Corresponds to p=24    48    97   223   389
C     time factor 1     2     3     6    10   on slow workstation
C                 1    1.5    2     3     5   on fast mainframe
C
C  NOTYET is .TRUE. if no initialization has been performed yet.
C              Default Initialization by Multiplicative Congruential
      IF (NOTYET) THEN
         NOTYET = .FALSE.
         JSEED = JSDFLT
         INSEED = JSEED
         WRITE(6,'(A,I12)') ' RANLUX DEFAULT INITIALIZATION: ',JSEED
         LUXLEV = LXDFLT
         NSKIP = NDSKIP(LUXLEV)
         LP = NSKIP + 24
         IN24 = 0
         KOUNT = 0
         MKOUNT = 0
         WRITE(6,'(A,I2,A,I4)')  ' RANLUX DEFAULT LUXURY LEVEL =  ',
     +        LUXLEV,'      p =',LP
            TWOM24 = 1.
         DO 25 I= 1, 24
            TWOM24 = TWOM24 * 0.5
         K = JSEED/53668
         JSEED = 40014*(JSEED-K*53668) -K*12211
         IF (JSEED .LT. 0)  JSEED = JSEED+ICONS
         ISEEDS(I) = MOD(JSEED,ITWO24)
   25    CONTINUE
         TWOM12 = TWOM24 * 4096.
         DO 50 I= 1,24
         SEEDS(I) = REAL(ISEEDS(I))*TWOM24
         NEXT(I) = I-1
   50    CONTINUE
         NEXT(1) = 24
         I24 = 24
         J24 = 10
         CARRY = 0.
         IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24
      ENDIF
C
C          The Generator proper: "Subtract-with-borrow",
C          as proposed by Marsaglia and Zaman,
C          Florida State University, March, 1989
C
      DO 100 IVEC= 1, LENV
      UNI = SEEDS(J24) - SEEDS(I24) - CARRY
      IF (UNI .LT. 0.)  THEN
         UNI = UNI + 1.0
         CARRY = TWOM24
      ELSE
         CARRY = 0.
      ENDIF
      SEEDS(I24) = UNI
      I24 = NEXT(I24)
      J24 = NEXT(J24)
      RVEC(IVEC) = UNI
C  small numbers (with less than 12 "significant" bits) are "padded".
      IF (UNI .LT. TWOM12)  THEN
         RVEC(IVEC) = RVEC(IVEC) + TWOM24*SEEDS(J24)
C        and zero is forbidden in case someone takes a logarithm
         IF (RVEC(IVEC) .EQ. 0.)  RVEC(IVEC) = TWOM24*TWOM24
      ENDIF
C        Skipping to luxury.  As proposed by Martin Luscher.
      IN24 = IN24 + 1
      IF (IN24 .EQ. 24)  THEN
         IN24 = 0
         KOUNT = KOUNT + NSKIP
         DO 90 ISK= 1, NSKIP
         UNI = SEEDS(J24) - SEEDS(I24) - CARRY
         IF (UNI .LT. 0.)  THEN
            UNI = UNI + 1.0
            CARRY = TWOM24
         ELSE
            CARRY = 0.
         ENDIF
         SEEDS(I24) = UNI
         I24 = NEXT(I24)
         J24 = NEXT(J24)
   90    CONTINUE
      ENDIF
  100 CONTINUE
      KOUNT = KOUNT + LENV
      IF (KOUNT .GE. IGIGA)  THEN
         MKOUNT = MKOUNT + 1
         KOUNT = KOUNT - IGIGA
      ENDIF
      RETURN
C
C           Entry to input and float integer seeds from previous run
      ENTRY RLUXIN(ISDEXT)
         NOTYET = .FALSE.
         TWOM24 = 1.
         DO 195 I= 1, 24
         NEXT(I) = I-1
  195    TWOM24 = TWOM24 * 0.5
         NEXT(1) = 24
         TWOM12 = TWOM24 * 4096.
      WRITE(6,'(A)') ' FULL INITIALIZATION OF RANLUX WITH 25 INTEGERS:'
      WRITE(6,'(5X,5I12)') ISDEXT
      DO 200 I= 1, 24
      SEEDS(I) = REAL(ISDEXT(I))*TWOM24
  200 CONTINUE
      CARRY = 0.
      IF (ISDEXT(25) .LT. 0)  CARRY = TWOM24
      ISD = IABS(ISDEXT(25))
      I24 = MOD(ISD,100)
      ISD = ISD/100
      J24 = MOD(ISD,100)
      ISD = ISD/100
      IN24 = MOD(ISD,100)
      ISD = ISD/100
      LUXLEV = ISD
        IF (LUXLEV .LE. MAXLEV) THEN
          NSKIP = NDSKIP(LUXLEV)
          WRITE (6,'(A,I2)') ' RANLUX LUXURY LEVEL SET BY RLUXIN TO: ',
     +                         LUXLEV
        ELSE  IF (LUXLEV .GE. 24) THEN
          NSKIP = LUXLEV - 24
          WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXIN TO:',LUXLEV
        ELSE
          NSKIP = NDSKIP(MAXLEV)
          WRITE (6,'(A,I5)') ' RANLUX ILLEGAL LUXURY RLUXIN: ',LUXLEV
          LUXLEV = MAXLEV
        ENDIF
      INSEED = -1
      RETURN
C
C                    Entry to ouput seeds as integers
      ENTRY RLUXUT(ISDEXT)
      DO 300 I= 1, 24
         ISDEXT(I) = INT(SEEDS(I)*TWOP12*TWOP12)
  300 CONTINUE
      ISDEXT(25) = I24 + 100*J24 + 10000*IN24 + 1000000*LUXLEV
      IF (CARRY .GT. 0.)  ISDEXT(25) = -ISDEXT(25)
      RETURN
C
C                    Entry to output the "convenient" restart point
      ENTRY RLUXAT(LOUT,INOUT,K1,K2)
      LOUT = LUXLEV
      INOUT = INSEED
      K1 = KOUNT
      K2 = MKOUNT
      RETURN
C
C                    Entry to initialize from one or three integers
      ENTRY RLUXGO(LUX,INS,K1,K2)
         IF (LUX .LT. 0) THEN
            LUXLEV = LXDFLT
         ELSE IF (LUX .LE. MAXLEV) THEN
            LUXLEV = LUX
         ELSE IF (LUX .LT. 24 .OR. LUX .GT. 2000) THEN
            LUXLEV = MAXLEV
            WRITE (6,'(A,I7)') ' RANLUX ILLEGAL LUXURY RLUXGO: ',LUX
         ELSE
            LUXLEV = LUX
            DO 310 ILX= 0, MAXLEV
              IF (LUX .EQ. NDSKIP(ILX)+24)  LUXLEV = ILX
  310       CONTINUE
         ENDIF
      IF (LUXLEV .LE. MAXLEV)  THEN
         NSKIP = NDSKIP(LUXLEV)
         WRITE(6,'(A,I2,A,I4)') ' RANLUX LUXURY LEVEL SET BY RLUXGO :',
     +        LUXLEV,'     P=', NSKIP+24
      ELSE
          NSKIP = LUXLEV - 24
          WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXGO TO:',LUXLEV
      ENDIF
      IN24 = 0
      IF (INS .LT. 0)  WRITE (6,'(A)')
     +   ' Illegal initialization by RLUXGO, negative input seed'
      IF (INS .GT. 0)  THEN
        JSEED = INS
        WRITE(6,'(A,3I12)') ' RANLUX INITIALIZED BY RLUXGO FROM SEEDS',
     +      JSEED, K1,K2
      ELSE
        JSEED = JSDFLT
        WRITE(6,'(A)')' RANLUX INITIALIZED BY RLUXGO FROM DEFAULT SEED'
      ENDIF
      INSEED = JSEED
      NOTYET = .FALSE.
      TWOM24 = 1.
         DO 325 I= 1, 24
           TWOM24 = TWOM24 * 0.5
         K = JSEED/53668
         JSEED = 40014*(JSEED-K*53668) -K*12211
         IF (JSEED .LT. 0)  JSEED = JSEED+ICONS
         ISEEDS(I) = MOD(JSEED,ITWO24)
  325    CONTINUE
      TWOM12 = TWOM24 * 4096.
         DO 350 I= 1,24
         SEEDS(I) = REAL(ISEEDS(I))*TWOM24
         NEXT(I) = I-1
  350    CONTINUE
      NEXT(1) = 24
      I24 = 24
      J24 = 10
      CARRY = 0.
      IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24
C        If restarting at a break point, skip K1 + IGIGA*K2
C        Note that this is the number of numbers delivered to
C        the user PLUS the number skipped (if luxury .GT. 0).
      KOUNT = K1
      MKOUNT = K2
      IF (K1+K2 .NE. 0)  THEN
        DO 500 IOUTER= 1, K2+1
          INNER = IGIGA
          IF (IOUTER .EQ. K2+1)  INNER = K1
          DO 450 ISK= 1, INNER
            UNI = SEEDS(J24) - SEEDS(I24) - CARRY
            IF (UNI .LT. 0.)  THEN
               UNI = UNI + 1.0
               CARRY = TWOM24
            ELSE
               CARRY = 0.
            ENDIF
            SEEDS(I24) = UNI
            I24 = NEXT(I24)
            J24 = NEXT(J24)
  450     CONTINUE
  500   CONTINUE
C         Get the right value of IN24 by direct calculation
        IN24 = MOD(KOUNT, NSKIP+24)
        IF (MKOUNT .GT. 0)  THEN
           IZIP = MOD(IGIGA, NSKIP+24)
           IZIP2 = MKOUNT*IZIP + IN24
           IN24 = MOD(IZIP2, NSKIP+24)
        ENDIF
C       Now IN24 had better be between zero and 23 inclusive
        IF (IN24 .GT. 23) THEN
           WRITE (6,'(A/A,3I11,A,I5)')
     +    '  Error in RESTARTING with RLUXGO:','  The values', INS,
     +     K1, K2, ' cannot occur at luxury level', LUXLEV
           IN24 = 0
        ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE SORTR(A,NC,NR,NS)
C
C CERN PROGLIB# M107    SORTR           .VERSION KERNFOR  4.21  890323
C ORIG. 15/11/88 FCA.  Modified from CERNLIB source by S. Yellin
C
C A has NC columns and NR rows.  If NS > 0 the column number NS is put
C in increasing order, and all other row entries, if any, move with the
C row entry of column NS.  If NS < 0 the same thing happens but with decreasing
C order.  The convention for storage of A is all NC columns of row 1, then of
C row 2, ..., row NR, which is the Fortran convention for A(NC,NR).  So if
C NC=NS=1 with a 1-dimensional array A(NR), that array will end up in
C increasing order.
C
      DIMENSION A(NC,NR)
C
      NCS=ABS(NS)
      IF(NCS.EQ.0)  GO TO 999
      IF(NCS.GT.NC) GO TO 999
      IF(NR.LE.1)   GO TO 999
      IF (NS.LE.0)           GO TO 31

C----              Ascending order

      DO 30 J=1,NR-1
        LMIN = J
        HMIN = A(NCS,J)
        DO 10 K=J+1,NR
          IF(HMIN.GT.A(NCS,K)) THEN
            HMIN = A(NCS,K)
            LMIN = K
          ENDIF
   10   CONTINUE
        IF(LMIN.NE.J) THEN
          DO 25 L=LMIN, J, -1
            IF(A(NCS,L).EQ.A(NCS,J)) THEN
              DO 20 K=1,NC
                TEMP      = A(K,LMIN)
                A(K,LMIN) = A(K,L)
                A(K,L)    = TEMP
   20         CONTINUE
              LMIN = L
            ENDIF
   25     CONTINUE
        ENDIF
   30 CONTINUE
      GO TO 999

C----              Descending order

   31 DO 60 J=1,NR-1
        LMAX = J
        HMAX = A(NCS,J)
        DO 40 K=J+1,NR
          IF(HMAX.LT.A(NCS,K)) THEN
            HMAX = A(NCS,K)
            LMAX = K
          ENDIF
   40   CONTINUE
        IF(LMAX.NE.J) THEN
          DO 55 L=LMAX, J, -1
            IF(A(NCS,L).EQ.A(NCS,J)) THEN
              DO 50 K=1,NC
                TEMP      = A(K,LMAX)
                A(K,LMAX) = A(K,L)
                A(K,L)    = TEMP
   50         CONTINUE
              LMAX = L
            ENDIF
   55     CONTINUE
        ENDIF
   60 CONTINUE
  999 RETURN
      END


C=======================================================================
C  LINDM, Subroutine
C----------------------------------------------------------------------
C  This subroutine linearly interpolates the between pest observations
C-----------------------------------------------------------------------
C  REVISION HISTORY
C  01/01/90 WDB
C  02/25/98 CHP Modified for PEST Module
C  01/12/99 GH  Incorporated into CROPGRO
C-----------------------------------------------------------------------
C  Called by: PEST
C  Calls:     None
C=======================================================================
      SUBROUTINE LINDM(
     &    DAP, IDAP, PCN, YPL,                            !Input
     &    PL)                                             !Output

!-----------------------------------------------------------------------
      USE ModuleDefs     !Definitions of constructed variable types,
                         ! which contain control information, soil
                         ! parameters, hourly weather data.
      IMPLICIT NONE
      SAVE
!-----------------------------------------------------------------------

      INTEGER DAP, I, PCN
      INTEGER ROW(6)
      INTEGER IDAP(6,MAXPEST)

      REAL RISE, RUNN, SLOPE
      REAL PL(6)
      REAL YPL(6,MAXPEST)
C-----------------------------------------------------------------------
C     Initialize variables
C-----------------------------------------------------------------------
      IF (DAP .LE. 1) THEN
        DO I = 1, 6
          PL(I)  = 0
          ROW(I) = 1
        ENDDO
      ENDIF
C-----------------------------------------------------------------------
C     Linearly interpolate pest levels daily
C-----------------------------------------------------------------------
      DO I = 1, PCN
C-----------------------------------------------------------------------
C     Increment Row Counter
C-----------------------------------------------------------------------
450     CONTINUE
        IF (IDAP(I,ROW(I)) .LT. 0) THEN
          ROW(I) = ROW(I) + 1
          GOTO 450
        ENDIF

        IF (DAP .GT. IDAP(I,ROW(I)) .AND. IDAP(I,ROW(I)) .GT. 0)
     &      ROW(I) = ROW(I) + 1
C-----------------------------------------------------------------------
C    Set beginning of interpolation to zero
C-----------------------------------------------------------------------
        IF (DAP .LT. IDAP(I,1) ) THEN
          PL(I) = 0
C-----------------------------------------------------------------------
C     Set First Interpolated Value if idap(I,1) = 1
C-----------------------------------------------------------------------
        ELSEIF (DAP .EQ. IDAP(I,1)) THEN
          PL(I) = YPL(I,ROW(I))
          ROW(I) = ROW(I) + 1

C-----------------------------------------------------------------------
C Linear Interpolation
! Rewrite logic for Intel compiler -- can't handle composite "IF" clause
! 09/20/2005 CHP, revised 01/04/2006
C-----------------------------------------------------------------------
        ELSEIF (ROW(I) .GT. 1) THEN
          RISE = YPL(I,ROW(I)) - YPL(I,ROW(I)-1)
          RUNN = IDAP(I,ROW(I)) - IDAP(I,ROW(I)-1)
          SLOPE = RISE/RUNN

C-----------------------------------------------------------------------
C   Set first interpolated value if idap < 0, that is
C   there is some pest data before planting date
C-----------------------------------------------------------------------
          IF (DAP .LE. 1 .AND. IDAP(I,ROW(I)-1) .LT. 0) THEN
            PL(I) = YPL(I,ROW(I)-1) + SLOPE * (DAP - IDAP(I,ROW(I)-1))

          ELSEIF(DAP .LE. IDAP(I,ROW(I))) THEN
            PL(I) = PL(I) + SLOPE * 1
          ENDIF
        ENDIF

C-----------------------------------------------------------------------
C Set all damage to zero after last user entered
c value for damage
C-----------------------------------------------------------------------

        IF (DAP .GT. IDAP(I,ROW(I))) THEN
          PL(I) = 0
        ENDIF
      ENDDO

      RETURN
      END SUBROUTINE LINDM

!-----------------------------------------------------------------------
!     Variables definitions
!-----------------------------------------------------------------------
! DAP       Number of days after planting (d)
! IDAP(I,J) Day of pest damage for pest I, observation J
!             (days after planting)
! PCN       Number of pests in FILET
! PL(I)     Pest level from pest progress file (FILET) for pest I (varies)
! RISE      Change in pest damage level between two observations for linear
!             interpolation
! ROW(I)    Counter which points to current row of data for each pest
!             progress curve (I)
! RUNN       Change in date between two observations for linear
!             interpolation
! SLOPE     Slope of pest level curve (RISE/RUNN) between two observations
! YPL(I,J)  Array for storage of pest data for pest or damage type I,
!             observation J
!-----------------------------------------------------------------------
!     End Subroutine LINDM
!-----------------------------------------------------------------------


      real*8 function vettvett(nequ,x,y)
      implicit none
      integer nequ,i
      real*8 x(nequ), y(nequ)
      vettvett=0.d0
      do i=1,nequ
        vettvett=vettvett+x(i)*y(i)
      end do

      return
      end