module shoc_iso_c
  use iso_c_binding
  implicit none

#include "scream_config.f"
#ifdef SCREAM_DOUBLE_PRECISION
# define c_real c_double
#else
# define c_real c_float
#endif

!
! This file contains bridges from scream c++ to shoc fortran.
!

contains
  subroutine append_precision(string, prefix)

    character(kind=c_char, len=128), intent(inout) :: string
    character(*), intent(in) :: prefix
    real(kind=c_real) :: s

    write (string, '(a,i1,a1)') prefix, sizeof(s), C_NULL_CHAR
  end subroutine append_precision

  subroutine shoc_init_c(nlev, gravit, rair, rh2o, cpair, &
                         zvir, latvap, latice, karman) bind(c)
    use shoc, only: shoc_init, npbl

    integer(kind=c_int), value, intent(in) :: nlev ! number of levels

    real(kind=c_real), value, intent(in)  :: gravit ! gravity
    real(kind=c_real), value, intent(in)  :: rair   ! dry air gas constant
    real(kind=c_real), value, intent(in)  :: rh2o   ! water vapor gas constant
    real(kind=c_real), value, intent(in)  :: cpair  ! specific heat of dry air
    real(kind=c_real), value, intent(in)  :: zvir   ! rh2o/rair - 1
    real(kind=c_real), value, intent(in)  :: latvap ! latent heat of vaporization
    real(kind=c_real), value, intent(in)  :: latice ! latent heat of fusion
    real(kind=c_real), value, intent(in)  :: karman ! Von Karman's constant

    real(kind=c_real) :: pref_mid(nlev) ! unused values

    pref_mid = 0
    call shoc_init(nlev, gravit, rair, rh2o, cpair, &
                   zvir, latvap, latice, karman, &
                   pref_mid, nlev, 1)
    npbl = nlev ! set pbl layer explicitly so we don't need pref_mid.
  end subroutine shoc_init_c

  ! shoc_init for shoc_main_bfb testing
  subroutine shoc_init_for_main_bfb_c(nlev, gravit, rair, rh2o, cpair, &
                                      zvir, latvap, latice, karman,pref_mid,&
                                      nbot_shoc, ntop_shoc) bind(c)
    use shoc, only: shoc_init

    integer(kind=c_int), value, intent(in) :: nlev ! number of levels
    integer(kind=c_int), value, intent(in) :: nbot_shoc ! Bottom level to which SHOC is applied
    integer(kind=c_int), value, intent(in) :: ntop_shoc ! Top level to which SHOC is applied

    real(kind=c_real), value, intent(in)  :: gravit ! gravity
    real(kind=c_real), value, intent(in)  :: rair   ! dry air gas constant
    real(kind=c_real), value, intent(in)  :: rh2o   ! water vapor gas constant
    real(kind=c_real), value, intent(in)  :: cpair  ! specific heat of dry air
    real(kind=c_real), value, intent(in)  :: zvir   ! rh2o/rair - 1
    real(kind=c_real), value, intent(in)  :: latvap ! latent heat of vaporization
    real(kind=c_real), value, intent(in)  :: latice ! latent heat of fusion
    real(kind=c_real), value, intent(in)  :: karman ! Von Karman's constant

    real(kind=c_real), intent(in), dimension(nlev) :: pref_mid ! reference pressures at midpoints
    call shoc_init(nlev, gravit, rair, rh2o, cpair, &
                   zvir, latvap, latice, karman, &
                   pref_mid, nbot_shoc, ntop_shoc)
  end subroutine shoc_init_for_main_bfb_c

  subroutine shoc_main_c(shcol,nlev,nlevi,dtime,nadv,host_dx, host_dy, thv,  &
     zt_grid, zi_grid, pres, presi, pdel, wthl_sfc, wqw_sfc, uw_sfc, vw_sfc, &
     wtracer_sfc, num_qtracers, w_field, inv_exner, phis, host_dse, tke, thetal,  &
     qw, u_wind, v_wind, qtracers, wthv_sec, tkh, tk, shoc_ql, shoc_cldfrac, &
     pblh, shoc_mix, isotropy, w_sec, thl_sec, qw_sec, qwthl_sec, wthl_sec,  &
     wqw_sec, wtke_sec, uw_sec, vw_sec, w3, wqls_sec, brunt, shoc_ql2, elapsed_s) bind(C)
    use shoc, only : shoc_main

    integer(kind=c_int), value, intent(in) :: shcol, nlev, nlevi, num_qtracers, nadv
    real(kind=c_real), value, intent(in) :: dtime
    real(kind=c_real), intent(in), dimension(shcol) :: host_dx, host_dy
    real(kind=c_real), intent(in), dimension(shcol, nlev) :: zt_grid
    real(kind=c_real), intent(in), dimension(shcol, nlevi) :: zi_grid
    real(kind=c_real), intent(in), dimension(shcol, nlev) :: pres
    real(kind=c_real), intent(in), dimension(shcol, nlevi) :: presi
    real(kind=c_real), intent(in), dimension(shcol, nlev) :: pdel, thv, w_field
    real(kind=c_real), intent(in), dimension(shcol) :: wthl_sfc, wqw_sfc, uw_sfc, vw_sfc
    real(kind=c_real), intent(in), dimension(shcol, num_qtracers) :: wtracer_sfc
    real(kind=c_real), intent(in), dimension(shcol, nlev) :: inv_exner
    real(kind=c_real), intent(in), dimension(shcol) :: phis

    real(kind=c_real), intent(inout), dimension(shcol, nlev) :: host_dse, tke, &
       thetal, qw, u_wind, v_wind, wthv_sec
    real(kind=c_real), intent(inout), dimension(shcol, nlev, num_qtracers) :: qtracers
    real(kind=c_real), intent(inout), dimension(shcol, nlev) :: tk, tkh

    real(kind=c_real), intent(inout), dimension(shcol, nlev) :: shoc_cldfrac, shoc_ql
    real(kind=c_real), intent(out), dimension(shcol) :: pblh
    real(kind=c_real), intent(out), dimension(shcol, nlev) :: shoc_mix, w_sec
    real(kind=c_real), intent(out), dimension(shcol, nlevi) :: thl_sec, qw_sec, &
       qwthl_sec, wthl_sec, wqw_sec, wtke_sec, uw_sec, vw_sec, w3
    real(kind=c_real), intent(out), dimension(shcol, nlev) :: wqls_sec, isotropy, &
         brunt,shoc_ql2

    real(kind=c_real), intent(out) :: elapsed_s

    call shoc_main(shcol, nlev, nlevi, dtime, nadv, host_dx, host_dy, thv,   &
     zt_grid, zi_grid, pres, presi, pdel, wthl_sfc, wqw_sfc, uw_sfc, vw_sfc, &
     wtracer_sfc, num_qtracers, w_field, inv_exner, phis, host_dse, tke, thetal, &
     qw, u_wind, v_wind, qtracers, wthv_sec, tkh, tk, shoc_ql, shoc_cldfrac, &
     pblh, shoc_mix, isotropy, w_sec, thl_sec, qw_sec, qwthl_sec, wthl_sec,  &
     wqw_sec, wtke_sec, uw_sec, vw_sec, w3, wqls_sec, brunt,shoc_ql2,elapsed_s)
  end subroutine shoc_main_c

  subroutine shoc_use_cxx_c(arg_use_cxx) bind(C)
    use shoc, only: use_cxx

    logical(kind=c_bool), value, intent(in) :: arg_use_cxx

    use_cxx = arg_use_cxx
  end subroutine shoc_use_cxx_c

  subroutine shoc_grid_c(shcol,nlev,nlevi,zt_grid,zi_grid,pdel,dz_zt,dz_zi,rho_zt) bind (C)
    use shoc, only: shoc_grid

    integer(kind=c_int), intent(in), value :: shcol
    integer(kind=c_int), intent(in), value :: nlev
    integer(kind=c_int), intent(in), value :: nlevi
    real(kind=c_real), intent(in) :: zt_grid(shcol,nlev)
    real(kind=c_real), intent(in) :: zi_grid(shcol,nlevi)
    real(kind=c_real), intent(in) :: pdel(shcol,nlev)

    real(kind=c_real), intent(out) :: dz_zt(shcol,nlev)
    real(kind=c_real), intent(out) :: dz_zi(shcol,nlevi)
    real(kind=c_real), intent(out) :: rho_zt(shcol,nlev)

    call shoc_grid(shcol,nlev,nlevi,zt_grid,zi_grid,pdel,dz_zt,dz_zi,rho_zt)

  end subroutine shoc_grid_c

  subroutine shoc_diag_obklen_c(shcol,uw_sfc,vw_sfc,wthl_sfc,wqw_sfc,&
                                thl_sfc,cldliq_sfc,qv_sfc,ustar,&
                                kbfs,obklen) bind(C)

      use shoc, only: shoc_diag_obklen

      integer(kind=c_int), intent(in), value :: shcol
      real(kind=c_real), intent(in) :: uw_sfc(shcol)
      real(kind=c_real), intent(in) :: vw_sfc(shcol)
      real(kind=c_real), intent(in) :: wthl_sfc(shcol)
      real(kind=c_real), intent(in) :: wqw_sfc(shcol)
      real(kind=c_real), intent(in) :: thl_sfc(shcol)
      real(kind=c_real), intent(in) :: cldliq_sfc(shcol)
      real(kind=c_real), intent(in) :: qv_sfc(shcol)

      real(kind=c_real), intent(out) :: ustar(shcol)
      real(kind=c_real), intent(out) :: kbfs(shcol)
      real(kind=c_real), intent(out) :: obklen(shcol)

      call shoc_diag_obklen(shcol,uw_sfc,vw_sfc,wthl_sfc,wqw_sfc,&
                            thl_sfc,cldliq_sfc,qv_sfc,ustar,&
                            kbfs,obklen)

  end subroutine shoc_diag_obklen_c

  subroutine calc_shoc_varorcovar_c(&
       shcol,nlev,nlevi,tunefac,&                ! Input
       isotropy_zi,tkh_zi,dz_zi,invar1,invar2,&  ! Input
       varorcovar)bind (C)                       ! Input/Output

      use shoc, only: calc_shoc_varorcovar

      integer(kind=c_int), intent(in), value :: shcol
      integer(kind=c_int), intent(in), value :: nlev
      integer(kind=c_int), intent(in), value :: nlevi
      real(kind=c_real), intent(in), value :: tunefac
      real(kind=c_real), intent(in) :: isotropy_zi(shcol,nlevi)
      real(kind=c_real), intent(in) :: tkh_zi(shcol,nlevi)
      real(kind=c_real), intent(in) :: dz_zi(shcol,nlevi)
      real(kind=c_real), intent(in) :: invar1(shcol,nlev)
      real(kind=c_real), intent(in) :: invar2(shcol,nlev)

      real(kind=c_real), intent(inout) :: varorcovar(shcol,nlevi)

      call calc_shoc_varorcovar(&
           shcol,nlev,nlevi,tunefac,&               ! Input
           isotropy_zi,tkh_zi,dz_zi,invar1,invar2,& ! Input
           varorcovar)

  end subroutine calc_shoc_varorcovar_c

  subroutine compute_tmpi_c(nlevi, shcol, dtime, rho_zi, dz_zi, tmpi) bind(C)
    use shoc, only: compute_tmpi

    integer(kind=c_int), intent(in), value :: nlevi
    integer(kind=c_int), intent(in), value :: shcol
    real(kind=c_real), intent(in), value :: dtime
    real(kind=c_real), intent(in) :: rho_zi(shcol,nlevi)
    real(kind=c_real), intent(in) :: dz_zi(shcol,nlevi)

    real(kind=c_real), intent(out) :: tmpi(shcol,nlevi)

    call compute_tmpi(nlevi, shcol, dtime, rho_zi, dz_zi, tmpi)

  end subroutine compute_tmpi_c

  subroutine dp_inverse_c(nlev, shcol, rho_zt, dz_zt, rdp_zt) bind(C)
    use shoc, only: dp_inverse

    integer(kind=c_int), intent(in), value :: nlev
    integer(kind=c_int), intent(in), value :: shcol
    real(kind=c_real), intent(in) :: rho_zt(shcol,nlev)
    real(kind=c_real), intent(in) :: dz_zt(shcol,nlev)
    real(kind=c_real), intent(out) :: rdp_zt(shcol,nlev)

    call dp_inverse(nlev, shcol, rho_zt, dz_zt, rdp_zt)

  end subroutine dp_inverse_c

  subroutine sfc_fluxes_c(shcol, num_tracer, dtime, rho_zi_sfc, rdp_zt_sfc, &
                          wthl_sfc, wqw_sfc, wtke_sfc, wtracer_sfc, &
                          thetal, qw, tke, tracer) bind(C)
    use shoc, only: sfc_fluxes

    integer(kind=c_int), intent(in), value :: shcol
    integer(kind=c_int), intent(in), value :: num_tracer
    real(kind=c_real), intent(in), value :: dtime
    real(kind=c_real), intent(in) :: rho_zi_sfc(shcol)
    real(kind=c_real), intent(in) :: rdp_zt_sfc(shcol)
    real(kind=c_real), intent(in) :: wthl_sfc(shcol)
    real(kind=c_real), intent(in) :: wqw_sfc(shcol)
    real(kind=c_real), intent(in) :: wtke_sfc(shcol)
    real(kind=c_real), intent(in) :: wtracer_sfc(shcol,num_tracer)

    real(kind=c_real), intent(inout) :: thetal(shcol)
    real(kind=c_real), intent(inout) :: qw(shcol)
    real(kind=c_real), intent(inout) :: tke(shcol)
    real(kind=c_real), intent(inout) :: tracer(shcol,num_tracer)

    call sfc_fluxes(shcol, num_tracer, dtime, rho_zi_sfc, rdp_zt_sfc, &
                    wthl_sfc, wqw_sfc, wtke_sfc, wtracer_sfc, &
                    thetal, qw, tke, tracer)

  end subroutine sfc_fluxes_c

  subroutine impli_srf_stress_term_c(shcol, rho_zi_sfc, uw_sfc, vw_sfc, &
                                     u_wind_sfc, v_wind_sfc, ksrf) bind(C)
    use shoc, only: impli_srf_stress_term

    integer(kind=c_int), intent(in), value :: shcol
    real(kind=c_real), intent(in) :: rho_zi_sfc(shcol)
    real(kind=c_real), intent(in) :: uw_sfc(shcol)
    real(kind=c_real), intent(in) :: vw_sfc(shcol)
    real(kind=c_real), intent(in) :: u_wind_sfc(shcol)
    real(kind=c_real), intent(in) :: v_wind_sfc(shcol)

    real(kind=c_real), intent(out) :: ksrf(shcol)

    ksrf(1:shcol) = impli_srf_stress_term(shcol, rho_zi_sfc, &
                      uw_sfc, vw_sfc, u_wind_sfc, v_wind_sfc)

  end subroutine impli_srf_stress_term_c

  subroutine tke_srf_flux_term_c(shcol, uw_sfc, vw_sfc, wtke_sfc) bind(C)
    use shoc, only: tke_srf_flux_term

    integer(kind=c_int), intent(in), value :: shcol
    real(kind=c_real), intent(in) :: uw_sfc(shcol)
    real(kind=c_real), intent(in) :: vw_sfc(shcol)

    real(kind=c_real), intent(out) :: wtke_sfc(shcol)

    wtke_sfc(1:shcol) = tke_srf_flux_term(shcol, uw_sfc, vw_sfc)

  end subroutine tke_srf_flux_term_c

  subroutine check_tke_c(shcol, nlev, tke) bind(C)
    use shoc, only: check_tke

    integer(kind=c_int), intent(in), value :: shcol
    integer(kind=c_int), intent(in), value :: nlev

    real(kind=c_real), intent(inout) :: tke(shcol,nlev)

    call check_tke(shcol,nlev,tke)

  end subroutine check_tke_c

  subroutine shoc_tke_c(shcol, nlev, nlevi, dtime, wthv_sec, shoc_mix, dz_zi, &
                        dz_zt, pres, u_wind, v_wind, brunt, obklen, zt_grid, &
                        zi_grid, pblh, tke, tk, tkh, isotropy) bind(C)
    use shoc, only: shoc_tke

    integer(kind=c_int), intent(in), value :: shcol
    integer(kind=c_int), intent(in), value :: nlev
    integer(kind=c_int), intent(in), value :: nlevi
    real(kind=c_real), intent(in), value :: dtime
    real(kind=c_real), intent(in) :: wthv_sec(shcol,nlev)
    real(kind=c_real), intent(in) :: shoc_mix(shcol,nlev)
    real(kind=c_real), intent(in) :: dz_zi(shcol,nlevi)
    real(kind=c_real), intent(in) :: dz_zt(shcol,nlev)
    real(kind=c_real), intent(in) :: pres(shcol,nlev)
    real(kind=c_real), intent(in) :: u_wind(shcol,nlev)
    real(kind=c_real), intent(in) :: v_wind(shcol,nlev)
    real(kind=c_real), intent(in) :: brunt(shcol,nlev)
    real(kind=c_real), intent(in) :: obklen(shcol)
    real(kind=c_real), intent(in) :: zt_grid(shcol,nlev)
    real(kind=c_real), intent(in) :: zi_grid(shcol,nlevi)
    real(kind=c_real), intent(in) :: pblh(shcol)

    real(kind=c_real), intent(inout) :: tke(shcol,nlev)
    real(kind=c_real), intent(inout) :: tk(shcol,nlev)
    real(kind=c_real), intent(inout) :: tkh(shcol,nlev)
    real(kind=c_real), intent(out) :: isotropy(shcol,nlev)

    call shoc_tke(shcol, nlev, nlevi, dtime, wthv_sec, shoc_mix, dz_zi, &
         dz_zt, pres, u_wind, v_wind, brunt, obklen, zt_grid, &
         zi_grid, pblh, tke, tk, tkh, isotropy)

  end subroutine shoc_tke_c

  subroutine integ_column_stability_c(nlev, shcol, dz_zt, pres, brunt, brunt_int) bind (C)
    use shoc, only: integ_column_stability

    integer(kind=c_int), intent(in), value :: nlev
    integer(kind=c_int), intent(in), value :: shcol
    real(kind=c_real), intent(in) :: dz_zt(shcol,nlev)
    real(kind=c_real), intent(in) :: pres(shcol,nlev)
    real(kind=c_real), intent(in) :: brunt(shcol,nlev)

    real(kind=c_real), intent(out) :: brunt_int(shcol)

    call integ_column_stability(nlev, shcol, dz_zt, pres, brunt, brunt_int)

  end subroutine integ_column_stability_c

  subroutine compute_shr_prod_c(nlevi, nlev, shcol, dz_zi, u_wind, v_wind, sterm) bind (C)
    use shoc, only: compute_shr_prod

    integer(kind=c_int), intent(in), value :: nlevi
    integer(kind=c_int), intent(in), value :: nlev
    integer(kind=c_int), intent(in), value :: shcol
    real(kind=c_real), intent(in) :: dz_zi(shcol,nlevi)
    real(kind=c_real), intent(in) :: u_wind(shcol,nlev)
    real(kind=c_real), intent(in) :: v_wind(shcol,nlev)

    real(kind=c_real), intent(out) :: sterm(shcol,nlevi)

    call compute_shr_prod(nlevi, nlev, shcol, dz_zi, u_wind, v_wind, sterm)

  end subroutine compute_shr_prod_c

  subroutine isotropic_ts_c(nlev, shcol, brunt_int, tke, a_diss, brunt, isotropy) bind (C)
    use shoc, only: isotropic_ts

    integer(kind=c_int), intent(in), value :: nlev
    integer(kind=c_int), intent(in), value :: shcol
    real(kind=c_real), intent(in) :: brunt_int(shcol)
    real(kind=c_real), intent(in) :: tke(shcol,nlev)
    real(kind=c_real), intent(in) :: a_diss(shcol,nlev)
    real(kind=c_real), intent(in) :: brunt(shcol,nlev)

    real(kind=c_real), intent(out) :: isotropy(shcol,nlev)

    call isotropic_ts(nlev, shcol, brunt_int, tke, a_diss, brunt, isotropy)

  end subroutine isotropic_ts_c

  subroutine adv_sgs_tke_c(nlev, shcol, dtime, shoc_mix, wthv_sec, &
                           sterm_zt, tk, tke, a_diss) bind (C)
    use shoc, only: adv_sgs_tke

    integer(kind=c_int), intent(in), value :: nlev
    integer(kind=c_int), intent(in), value :: shcol
    real(kind=c_real), intent(in), value :: dtime
    real(kind=c_real), intent(in) :: shoc_mix(shcol,nlev)
    real(kind=c_real), intent(in) :: wthv_sec(shcol,nlev)
    real(kind=c_real), intent(in) :: sterm_zt(shcol,nlev)
    real(kind=c_real), intent(in) :: tk(shcol,nlev)

    real(kind=c_real), intent(inout) :: tke(shcol,nlev)

    real(kind=c_real), intent(out) :: a_diss(shcol,nlev)

    call adv_sgs_tke(nlev, shcol, dtime, shoc_mix, wthv_sec, &
                     sterm_zt, tk, tke, a_diss)

  end subroutine adv_sgs_tke_c

  subroutine eddy_diffusivities_c(nlev, shcol, obklen, pblh, zt_grid, &
                          shoc_mix, sterm_zt, isotropy, tke, tkh, tk) bind (C)
    use shoc, only: eddy_diffusivities

    integer(kind=c_int), intent(in), value :: nlev
    integer(kind=c_int), intent(in), value :: shcol
    real(kind=c_real), intent(in) :: obklen(shcol)
    real(kind=c_real), intent(in) :: pblh(shcol)
    real(kind=c_real), intent(in) :: zt_grid(shcol,nlev)
    real(kind=c_real), intent(in) :: shoc_mix(shcol,nlev)
    real(kind=c_real), intent(in) :: sterm_zt(shcol,nlev)
    real(kind=c_real), intent(in) :: isotropy(shcol,nlev)
    real(kind=c_real), intent(in) :: tke(shcol,nlev)

    real(kind=c_real), intent(out) :: tkh(shcol,nlev)
    real(kind=c_real), intent(out) :: tk(shcol,nlev)

    call eddy_diffusivities(nlev, shcol, obklen, pblh, zt_grid, &
                        shoc_mix, sterm_zt, isotropy, tke, tkh, tk)

  end subroutine eddy_diffusivities_c

  subroutine update_host_dse_c(shcol, nlev, thlm, shoc_ql, inv_exner, zt_grid, &
                               phis, host_dse) bind (C)
    use shoc, only: update_host_dse

    integer(kind=c_int), intent(in), value :: shcol
    integer(kind=c_int), intent(in), value :: nlev
    real(kind=c_real), intent(in) :: thlm(shcol,nlev)
    real(kind=c_real), intent(in) :: shoc_ql(shcol,nlev)
    real(kind=c_real), intent(in) :: inv_exner(shcol,nlev)
    real(kind=c_real), intent(in) :: zt_grid(shcol,nlev)
    real(kind=c_real), intent(in) :: phis(shcol)

    real(kind=c_real), intent(out) :: host_dse(shcol,nlev)

    call update_host_dse(shcol, nlev, thlm, shoc_ql, inv_exner, zt_grid, &
                           phis, host_dse)

  end subroutine update_host_dse_c

  subroutine shoc_energy_fixer_c(shcol, nlev, nlevi, dtime, nadv, &
                                 zt_grid, zi_grid, se_b, ke_b, wv_b, &
                                 wl_b, se_a, ke_a, wv_a, wl_a, wthl_sfc, &
                                 wqw_sfc, rho_zt, tke, pint, &
                                 host_dse) bind (C)
    use shoc, only: shoc_energy_fixer

    integer(kind=c_int), intent(in), value :: shcol
    integer(kind=c_int), intent(in), value :: nlev
    integer(kind=c_int), intent(in), value :: nlevi
    real(kind=c_real), intent(in), value :: dtime
    integer(kind=c_int), intent(in), value :: nadv
    real(kind=c_real), intent(in) :: zt_grid(shcol,nlev)
    real(kind=c_real), intent(in) :: zi_grid(shcol,nlevi)
    real(kind=c_real), intent(in) :: se_b(shcol)
    real(kind=c_real), intent(in) :: ke_b(shcol)
    real(kind=c_real), intent(in) :: wv_b(shcol)
    real(kind=c_real), intent(in) :: wl_b(shcol)
    real(kind=c_real), intent(in) :: se_a(shcol)
    real(kind=c_real), intent(in) :: ke_a(shcol)
    real(kind=c_real), intent(in) :: wv_a(shcol)
    real(kind=c_real), intent(in) :: wl_a(shcol)
    real(kind=c_real), intent(in) :: wthl_sfc(shcol)
    real(kind=c_real), intent(in) :: wqw_sfc(shcol)
    real(kind=c_real), intent(in) :: rho_zt(shcol,nlev)
    real(kind=c_real), intent(in) :: tke(shcol,nlev)
    real(kind=c_real), intent(in) :: pint(shcol,nlevi)

    real(kind=c_real), intent(inout) :: host_dse(shcol,nlev)

    call shoc_energy_fixer(shcol, nlev, nlevi, dtime, nadv, &
                           zt_grid, zi_grid, se_b, ke_b, wv_b, &
                           wl_b, se_a, ke_a, wv_a, wl_a, wthl_sfc, &
                           wqw_sfc, rho_zt, tke, pint, &
                           host_dse)

  end subroutine shoc_energy_fixer_c

  subroutine shoc_energy_integrals_c(shcol, nlev, host_dse, pdel,&
                                     rtm, rcm, u_wind, v_wind,&
                                     se_int, ke_int, wv_int, wl_int) bind (C)
    use shoc, only: shoc_energy_integrals

    integer(kind=c_int), intent(in), value :: shcol
    integer(kind=c_int), intent(in), value :: nlev
    real(kind=c_real), intent(in) :: host_dse(shcol,nlev)
    real(kind=c_real), intent(in) :: pdel(shcol,nlev)
    real(kind=c_real), intent(in) :: rtm(shcol,nlev)
    real(kind=c_real), intent(in) :: rcm(shcol,nlev)
    real(kind=c_real), intent(in) :: u_wind(shcol,nlev)
    real(kind=c_real), intent(in) :: v_wind(shcol,nlev)

    real(kind=c_real), intent(out) :: se_int(shcol)
    real(kind=c_real), intent(out) :: ke_int(shcol)
    real(kind=c_real), intent(out) :: wv_int(shcol)
    real(kind=c_real), intent(out) :: wl_int(shcol)

    call shoc_energy_integrals(shcol, nlev, host_dse, pdel,&
                               rtm, rcm, u_wind, v_wind,&
                               se_int, ke_int, wv_int, wl_int)

  end subroutine shoc_energy_integrals_c

  subroutine shoc_energy_total_fixer_c(&
                                shcol,nlev,nlevi,dtime,nadv,&
                                zt_grid,zi_grid,&
                                se_b,ke_b,wv_b,wl_b,&
                                se_a,ke_a,wv_a,wl_a,&
                                wthl_sfc,wqw_sfc,rho_zt,&
                                te_a,te_b) bind (C)
    use shoc, only: shoc_energy_total_fixer

    integer(kind=c_int), intent(in), value :: shcol
    integer(kind=c_int), intent(in), value :: nlev
    integer(kind=c_int), intent(in), value :: nlevi
    integer(kind=c_int), intent(in), value :: nadv
    real(kind=c_real), intent(in), value :: dtime

    real(kind=c_real), intent(in) :: se_b(shcol)
    real(kind=c_real), intent(in) :: ke_b(shcol)
    real(kind=c_real), intent(in) :: wv_b(shcol)
    real(kind=c_real), intent(in) :: wl_b(shcol)
    real(kind=c_real), intent(in) :: se_a(shcol)
    real(kind=c_real), intent(in) :: ke_a(shcol)
    real(kind=c_real), intent(in) :: wv_a(shcol)
    real(kind=c_real), intent(in) :: wl_a(shcol)
    real(kind=c_real), intent(in) :: wthl_sfc(shcol)
    real(kind=c_real), intent(in) :: wqw_sfc(shcol)
    real(kind=c_real), intent(in) :: zt_grid(shcol,nlev)
    real(kind=c_real), intent(in) :: zi_grid(shcol,nlevi)
    real(kind=c_real), intent(in) :: rho_zt(shcol,nlev)

    real(kind=c_real), intent(out) :: te_a(shcol)
    real(kind=c_real), intent(out) :: te_b(shcol)

    call shoc_energy_total_fixer(shcol,nlev,nlevi,dtime,nadv,&
                                 zt_grid,zi_grid,&
                                 se_b,ke_b,wv_b,wl_b,&
                                 se_a,ke_a,wv_a,wl_a,&
                                 wthl_sfc,wqw_sfc,rho_zt,&
                                 te_a,te_b)

  end subroutine shoc_energy_total_fixer_c

  subroutine shoc_energy_threshold_fixer_c(shcol,nlev,nlevi, &
                                     pint,tke,te_a,te_b, &
                                     se_dis,shoctop) bind (C)
    use shoc, only: shoc_energy_threshold_fixer

    integer(kind=c_int), intent(in), value :: shcol
    integer(kind=c_int), intent(in), value :: nlev
    integer(kind=c_int), intent(in), value :: nlevi

    real(kind=c_real), intent(in) :: pint(shcol,nlevi)
    real(kind=c_real), intent(in) :: tke(shcol,nlev)
    real(kind=c_real), intent(in) :: te_a(shcol)
    real(kind=c_real), intent(in) :: te_b(shcol)

    real(kind=c_real), intent(out) :: se_dis(shcol)
    integer(kind=c_int), intent(out) :: shoctop(shcol)

    call shoc_energy_threshold_fixer(shcol,nlev,nlevi, &
                                     pint,tke,te_a,te_b, &
                                     se_dis,shoctop)

  end subroutine shoc_energy_threshold_fixer_c

  subroutine shoc_energy_dse_fixer_c(shcol,nlev, &
                                     se_dis,shoctop, &
                                     host_dse) bind (C)
    use shoc, only: shoc_energy_dse_fixer

    integer(kind=c_int), intent(in), value :: shcol
    integer(kind=c_int), intent(in), value :: nlev
    integer(kind=c_int), intent(in) :: shoctop(shcol)
    real(kind=c_real), intent(in) :: se_dis(shcol)

    real(kind=c_real), intent(inout) :: host_dse(shcol,nlev)

    call shoc_energy_dse_fixer(shcol,nlev, &
                               se_dis,shoctop, &
                               host_dse)

  end subroutine shoc_energy_dse_fixer_c

  subroutine calc_shoc_vertflux_c(shcol, nlev, nlevi, tkh_zi, dz_zi, invar, vertflux) bind (C)
    use shoc, only: calc_shoc_vertflux

    integer(kind=c_int), intent(in), value :: shcol
    integer(kind=c_int), intent(in), value :: nlev
    integer(kind=c_int), intent(in), value :: nlevi
    real(kind=c_real), intent(in) :: tkh_zi(shcol,nlevi)
    real(kind=c_real), intent(in) :: dz_zi(shcol,nlevi)
    real(kind=c_real), intent(in) :: invar(shcol,nlev)

    real(kind=c_real), intent(inout) :: vertflux(shcol,nlevi)

    call calc_shoc_vertflux(shcol, nlev, nlevi, tkh_zi, dz_zi, invar, vertflux)

  end subroutine calc_shoc_vertflux_c

  subroutine shoc_length_c(shcol, nlev, nlevi, host_dx, host_dy, &
                zt_grid, zi_grid, dz_zt, tke, thv, brunt, &
                shoc_mix) bind (C)
    use shoc, only: shoc_length

    integer(kind=c_int), intent(in), value :: shcol
    integer(kind=c_int), intent(in), value :: nlev
    integer(kind=c_int), intent(in), value :: nlevi
    real(kind=c_real), intent(in) :: host_dx(shcol)
    real(kind=c_real), intent(in) :: host_dy(shcol)
    real(kind=c_real), intent(in) :: tke(shcol,nlev)
    real(kind=c_real), intent(in) :: zt_grid(shcol,nlev)
    real(kind=c_real), intent(in) :: zi_grid(shcol,nlevi)
    real(kind=c_real), intent(in) :: dz_zt(shcol,nlev)
    real(kind=c_real), intent(in) :: thv(shcol,nlev)

    real(kind=c_real), intent(out) :: brunt(shcol,nlev)
    real(kind=c_real), intent(out) :: shoc_mix(shcol,nlev)

    call shoc_length(shcol, nlev, nlevi, host_dx, host_dy, &
                zt_grid, zi_grid, dz_zt, tke, thv, &
                brunt, shoc_mix)

  end subroutine shoc_length_c

  subroutine compute_brunt_shoc_length_c(nlev,nlevi,shcol,dz_zt,thv,thv_zi,brunt) bind (C)
    use shoc, only: compute_brunt_shoc_length

    integer(kind=c_int), intent(in), value :: nlev
    integer(kind=c_int), intent(in), value :: nlevi
    integer(kind=c_int), intent(in), value :: shcol
    real(kind=c_real), intent(in) :: dz_zt(shcol,nlev)
    real(kind=c_real), intent(in) :: thv(shcol,nlev)
    real(kind=c_real), intent(in) :: thv_zi(shcol,nlevi)

    real(kind=c_real), intent(out) :: brunt(shcol,nlev)

    call compute_brunt_shoc_length(nlev,nlevi,shcol,dz_zt,thv,thv_zi,brunt)

  end subroutine compute_brunt_shoc_length_c

  subroutine compute_l_inf_shoc_length_c(nlev,shcol,zt_grid,dz_zt,tke,l_inf) bind (C)
    use shoc, only: compute_l_inf_shoc_length

    integer(kind=c_int), intent(in), value :: nlev
    integer(kind=c_int), intent(in), value :: shcol
    real(kind=c_real), intent(in) :: zt_grid(shcol,nlev)
    real(kind=c_real), intent(in) :: dz_zt(shcol,nlev)
    real(kind=c_real), intent(in) :: tke(shcol,nlev)

    real(kind=c_real), intent(out) :: l_inf(shcol)

    call compute_l_inf_shoc_length(nlev,shcol,zt_grid,dz_zt,tke,l_inf)

  end subroutine compute_l_inf_shoc_length_c

  subroutine compute_shoc_mix_shoc_length_c(nlev,shcol,tke,brunt,&
                                         zt_grid,l_inf,shoc_mix) bind (C)
    use shoc, only: compute_shoc_mix_shoc_length

    integer(kind=c_int), intent(in), value :: nlev
    integer(kind=c_int), intent(in), value :: shcol
    real(kind=c_real), intent(in) :: tke(shcol,nlev)
    real(kind=c_real), intent(in) :: brunt(shcol,nlev)
    real(kind=c_real), intent(in) :: zt_grid(shcol,nlev)
    real(kind=c_real), intent(in) :: l_inf(shcol)

    real(kind=c_real), intent(out) :: shoc_mix(shcol,nlev)

    call compute_shoc_mix_shoc_length(nlev,shcol,tke,brunt,zt_grid,&
                                      l_inf,shoc_mix)

  end subroutine compute_shoc_mix_shoc_length_c

  subroutine check_length_scale_shoc_length_c(nlev,shcol,host_dx,host_dy,shoc_mix) bind (C)
    use shoc, only: check_length_scale_shoc_length

    integer(kind=c_int), intent(in), value :: nlev
    integer(kind=c_int), intent(in), value :: shcol
    real(kind=c_real), intent(in) :: host_dx(shcol)
    real(kind=c_real), intent(in) :: host_dy(shcol)

    real(kind=c_real), intent(inout) :: shoc_mix(shcol,nlev)

    call check_length_scale_shoc_length(nlev,shcol,host_dx,host_dy,shoc_mix)

  end subroutine check_length_scale_shoc_length_c

  subroutine clipping_diag_third_shoc_moments_c(nlevi,shcol,w_sec_zi,w3) bind (C)
    use shoc, only: clipping_diag_third_shoc_moments

    integer(kind=c_int), intent(in), value :: nlevi
    integer(kind=c_int), intent(in), value :: shcol
    real(kind=c_real), intent(in) :: w_sec_zi(shcol,nlevi)

    real(kind=c_real), intent(inout) :: w3(shcol,nlevi)

    call clipping_diag_third_shoc_moments(nlevi,shcol,w_sec_zi,w3)

  end subroutine clipping_diag_third_shoc_moments_c

  subroutine fterms_input_for_diag_third_shoc_moment_c(&
                         dz_zi, dz_zt, dz_zt_kc, &
                         isotropy_zi, brunt_zi, thetal_zi, &
                         thedz, thedz2, iso, isosqrd, buoy_sgs2, bet2) bind (C)
    use shoc, only: fterms_input_for_diag_third_shoc_moment

    real(kind=c_real), intent(in), value :: dz_zi
    real(kind=c_real), intent(in), value :: dz_zt
    real(kind=c_real), intent(in), value :: dz_zt_kc
    real(kind=c_real), intent(in), value :: isotropy_zi
    real(kind=c_real), intent(in), value :: brunt_zi
    real(kind=c_real), intent(in), value :: thetal_zi

    real(kind=c_real), intent(out) :: thedz
    real(kind=c_real), intent(out) :: thedz2
    real(kind=c_real), intent(out) :: iso
    real(kind=c_real), intent(out) :: isosqrd
    real(kind=c_real), intent(out) :: buoy_sgs2
    real(kind=c_real), intent(out) :: bet2

    call fterms_input_for_diag_third_shoc_moment(dz_zi, dz_zt, dz_zt_kc, &
                         isotropy_zi, brunt_zi, thetal_zi, &
                         thedz, thedz2, iso, isosqrd, buoy_sgs2, bet2)

  end subroutine fterms_input_for_diag_third_shoc_moment_c

  subroutine f0_to_f5_diag_third_shoc_moment_c(&
                          thedz, thedz2, bet2, iso, isosqrd, &
                          wthl_sec, wthl_sec_kc, wthl_sec_kb, &
                          thl_sec_kc, thl_sec_kb, &
                          w_sec, w_sec_kc,w_sec_zi, &
                          tke, tke_kc, &
                          f0, f1, f2, f3, f4, f5) bind (C)
    use shoc, only: f0_to_f5_diag_third_shoc_moment

    real(kind=c_real), intent(in), value :: thedz
    real(kind=c_real), intent(in), value :: thedz2
    real(kind=c_real), intent(in), value :: bet2
    real(kind=c_real), intent(in), value :: iso
    real(kind=c_real), intent(in), value :: isosqrd
    real(kind=c_real), intent(in), value :: wthl_sec
    real(kind=c_real), intent(in), value :: wthl_sec_kc
    real(kind=c_real), intent(in), value :: wthl_sec_kb
    real(kind=c_real), intent(in), value :: thl_sec_kc
    real(kind=c_real), intent(in), value :: thl_sec_kb
    real(kind=c_real), intent(in), value :: w_sec
    real(kind=c_real), intent(in), value :: w_sec_kc
    real(kind=c_real), intent(in), value :: w_sec_zi
    real(kind=c_real), intent(in), value :: tke
    real(kind=c_real), intent(in), value :: tke_kc

    real(kind=c_real), intent(out) :: f0
    real(kind=c_real), intent(out) :: f1
    real(kind=c_real), intent(out) :: f2
    real(kind=c_real), intent(out) :: f3
    real(kind=c_real), intent(out) :: f4
    real(kind=c_real), intent(out) :: f5

    call f0_to_f5_diag_third_shoc_moment(&
                          thedz, thedz2, bet2, iso, isosqrd, &
                          wthl_sec, wthl_sec_kc, wthl_sec_kb, &
                          thl_sec_kc, thl_sec_kb, &
                          w_sec, w_sec_kc,w_sec_zi, &
                          tke, tke_kc, &
                          f0, f1, f2, f3, f4, f5)

  end subroutine f0_to_f5_diag_third_shoc_moment_c

  subroutine w3_diag_third_shoc_moment_c(aa0, aa1, x0, x1, f5, w3) bind (c)
    use shoc, only: w3_diag_third_shoc_moment

    real(kind=c_real), intent(in), value :: aa0
    real(kind=c_real), intent(in), value :: aa1
    real(kind=c_real), intent(in), value :: x0
    real(kind=c_real), intent(in), value :: x1
    real(kind=c_real), intent(in), value :: f5

    real(kind=c_real), intent(out) :: w3

    w3 = w3_diag_third_shoc_moment(aa0, aa1, x0, x1, f5)

  end subroutine w3_diag_third_shoc_moment_c

  subroutine omega_terms_diag_third_shoc_moment_c(&
                          buoy_sgs2, f3, f4,&
                          omega0, omega1, omega2) bind (C)
    use shoc, only: omega_terms_diag_third_shoc_moment

    real(kind=c_real), intent(in), value :: buoy_sgs2
    real(kind=c_real), intent(in), value :: f3
    real(kind=c_real), intent(in), value :: f4

    real(kind=c_real), intent(out) :: omega0
    real(kind=c_real), intent(out) :: omega1
    real(kind=c_real), intent(out) :: omega2

    call omega_terms_diag_third_shoc_moment(&
                          buoy_sgs2, f3, f4, &
                          omega0, omega1, omega2)

  end subroutine omega_terms_diag_third_shoc_moment_c

  subroutine x_y_terms_diag_third_shoc_moment_c(&
                          buoy_sgs2, f0, f1, f2,&
                          x0, y0, x1, y1) bind (C)
    use shoc, only: x_y_terms_diag_third_shoc_moment

    real(kind=c_real), intent(in), value :: buoy_sgs2
    real(kind=c_real), intent(in), value :: f0
    real(kind=c_real), intent(in), value :: f1
    real(kind=c_real), intent(in), value :: f2

    real(kind=c_real), intent(out) :: x0
    real(kind=c_real), intent(out) :: y0
    real(kind=c_real), intent(out) :: x1
    real(kind=c_real), intent(out) :: y1

    call x_y_terms_diag_third_shoc_moment(&
                          buoy_sgs2, f0, f1, f2,&
                          x0, y0, x1, y1)

  end subroutine x_y_terms_diag_third_shoc_moment_c

  subroutine aa_terms_diag_third_shoc_moment_c(&
                          omega0, omega1, omega2,&
                          x0, x1, y0, y1, &
                          aa0, aa1) bind (C)
    use shoc, only: aa_terms_diag_third_shoc_moment

    real(kind=c_real), intent(in), value :: omega0
    real(kind=c_real), intent(in), value :: omega1
    real(kind=c_real), intent(in), value :: omega2
    real(kind=c_real), intent(in), value :: x0
    real(kind=c_real), intent(in), value :: x1
    real(kind=c_real), intent(in), value :: y0
    real(kind=c_real), intent(in), value :: y1

    real(kind=c_real), intent(out) :: aa0
    real(kind=c_real), intent(out) :: aa1

    call aa_terms_diag_third_shoc_moment(&
                          omega0, omega1, omega2,&
                          x0, x1, y0, y1, &
                          aa0, aa1)

  end subroutine aa_terms_diag_third_shoc_moment_c

  subroutine shoc_diag_second_moments_srf_c(shcol, wthl_sfc, uw_sfc, vw_sfc, ustar2, wstar) bind(C)
   use shoc, only: diag_second_moments_srf

   ! argmens
   integer(kind=c_int), value, intent(in) :: shcol
   real(kind=c_real), intent(in)  :: wthl_sfc(shcol), uw_sfc(shcol), vw_sfc(shcol)
   real(kind=c_real), intent(out) :: ustar2(shcol), wstar(shcol)

   call diag_second_moments_srf(shcol, wthl_sfc, uw_sfc, vw_sfc, ustar2, wstar)

 end subroutine shoc_diag_second_moments_srf_c

  subroutine diag_third_shoc_moments_c(&
                             shcol, nlev, nlevi, w_sec, thl_sec, &
                             wthl_sec, isotropy, brunt, thetal, &
                             tke, dz_zt, dz_zi, &
                             zt_grid, zi_grid, w3) bind(C)
  use shoc, only: diag_third_shoc_moments

    integer(kind=c_int), intent(in), value :: shcol
    integer(kind=c_int), intent(in), value :: nlev
    integer(kind=c_int), intent(in), value :: nlevi
    real(kind=c_real), intent(in) :: w_sec(shcol,nlev)
    real(kind=c_real), intent(in) :: thl_sec(shcol,nlevi)
    real(kind=c_real), intent(in) :: wthl_sec(shcol,nlevi)
    real(kind=c_real), intent(in) :: isotropy(shcol,nlev)
    real(kind=c_real), intent(in) :: brunt(shcol,nlev)
    real(kind=c_real), intent(in) :: thetal(shcol,nlev)
    real(kind=c_real), intent(in) :: tke(shcol,nlev)
    real(kind=c_real), intent(in) :: dz_zt(shcol,nlev)
    real(kind=c_real), intent(in) :: dz_zi(shcol,nlevi)
    real(kind=c_real), intent(in) :: zt_grid(shcol,nlev)
    real(kind=c_real), intent(in) :: zi_grid(shcol,nlevi)

    real(kind=c_real), intent(out) :: w3(shcol,nlevi)

    call diag_third_shoc_moments(&
                     shcol, nlev, nlevi, w_sec, thl_sec, &
                     wthl_sec, isotropy, brunt, thetal, &
                     tke, dz_zt, dz_zi, zt_grid, zi_grid, w3)

  end subroutine diag_third_shoc_moments_c

  subroutine compute_diag_third_shoc_moment_c(&
                             shcol, nlev, nlevi, w_sec, thl_sec, &
                             wthl_sec, tke, dz_zt, dz_zi, isotropy_zi, &
                             brunt_zi, w_sec_zi, thetal_zi, w3) bind(C)
    use shoc, only: compute_diag_third_shoc_moment

    integer(kind=c_int), intent(in), value :: shcol
    integer(kind=c_int), intent(in), value :: nlev
    integer(kind=c_int), intent(in), value :: nlevi
    real(kind=c_real), intent(in) :: w_sec(shcol,nlev)
    real(kind=c_real), intent(in) :: thl_sec(shcol,nlevi)
    real(kind=c_real), intent(in) :: wthl_sec(shcol,nlevi)
    real(kind=c_real), intent(in) :: tke(shcol,nlev)
    real(kind=c_real), intent(in) :: dz_zt(shcol,nlev)
    real(kind=c_real), intent(in) :: dz_zi(shcol,nlevi)
    real(kind=c_real), intent(in) :: isotropy_zi(shcol,nlevi)
    real(kind=c_real), intent(in) :: brunt_zi(shcol,nlevi)
    real(kind=c_real), intent(in) :: w_sec_zi(shcol,nlevi)
    real(kind=c_real), intent(in) :: thetal_zi(shcol,nlevi)

    real(kind=c_real), intent(out) :: w3(shcol,nlevi)

    call compute_diag_third_shoc_moment(&
                             shcol, nlev, nlevi, w_sec, thl_sec, &
                             wthl_sec, tke, dz_zt, &
                             dz_zi, isotropy_zi, &
                             brunt_zi, w_sec_zi, thetal_zi, &
                             w3)

  end subroutine compute_diag_third_shoc_moment_c

  subroutine linear_interp_c(x1, x2, y1, y2, km1, km2, ncol, minthresh) bind(C)
    use shoc, only : linear_interp

    real(kind=c_real) , intent(in), dimension(ncol, km1) :: x1, y1
    real(kind=c_real) , intent(in), dimension(ncol, km2) :: x2
    real(kind=c_real) , intent(out), dimension(ncol, km2) :: y2
    integer(kind=c_int) , value, intent(in) :: km1, km2, ncol
    real(kind=c_real) , value, intent(in) :: minthresh

    call linear_interp(x1, x2, y1, y2, km1, km2, ncol, minthresh)
  end subroutine linear_interp_c

  subroutine shoc_assumed_pdf_c(shcol, nlev, nlevi, thetal, qw, &
                                w_field, thl_sec, qw_sec, wthl_sec, &
                                w_sec, wqw_sec, qwthl_sec, w3, pres, &
                                zt_grid, zi_grid, shoc_cldfrac, &
                                shoc_ql, wqls, wthv_sec, shoc_ql2) bind(C)
    use shoc, only: shoc_assumed_pdf

    integer(kind=c_int), intent(in), value :: shcol
    integer(kind=c_int), intent(in), value :: nlev
    integer(kind=c_int), intent(in), value :: nlevi
    real(kind=c_real), intent(in) :: thetal(shcol,nlev)
    real(kind=c_real), intent(in) :: qw(shcol,nlev)
    real(kind=c_real), intent(in) :: w_field(shcol,nlev)
    real(kind=c_real), intent(in) :: thl_sec(shcol,nlevi)
    real(kind=c_real), intent(in) :: qw_sec(shcol,nlevi)
    real(kind=c_real), intent(in) :: wthl_sec(shcol,nlevi)
    real(kind=c_real), intent(in) :: w_sec(shcol,nlev)
    real(kind=c_real), intent(in) :: wqw_sec(shcol,nlevi)
    real(kind=c_real), intent(in) :: qwthl_sec(shcol,nlevi)
    real(kind=c_real), intent(in) :: w3(shcol,nlevi)
    real(kind=c_real), intent(in) :: pres(shcol,nlev)
    real(kind=c_real), intent(in) :: zt_grid(shcol,nlev)
    real(kind=c_real), intent(in) :: zi_grid(shcol,nlevi)

    real(kind=c_real), intent(out) :: shoc_cldfrac(shcol,nlev)
    real(kind=c_real), intent(out) :: shoc_ql(shcol,nlev)
    real(kind=c_real), intent(out) :: wqls(shcol,nlev)
    real(kind=c_real), intent(out) :: wthv_sec(shcol,nlev)
    real(kind=c_real), intent(out) :: shoc_ql2(shcol,nlev)

    call shoc_assumed_pdf(shcol, nlev, nlevi, thetal, qw, &
                          w_field, thl_sec, qw_sec, wthl_sec, &
                          w_sec, wqw_sec, qwthl_sec, w3, pres, &
                          zt_grid, zi_grid, shoc_cldfrac, &
                          shoc_ql, wqls, wthv_sec, shoc_ql2)

  end subroutine shoc_assumed_pdf_c

  subroutine shoc_assumed_pdf_tilde_to_real_c(w_first, sqrtw2, w1) bind (C)
    use shoc, only: shoc_assumed_pdf_tilde_to_real

    real(kind=c_real), intent(in), value :: w_first
    real(kind=c_real), intent(in), value :: sqrtw2

    real(kind=c_real), intent(inout) :: w1

    call shoc_assumed_pdf_tilde_to_real(w_first, sqrtw2, w1)

  end subroutine shoc_assumed_pdf_tilde_to_real_c

  subroutine shoc_assumed_pdf_vv_parameters_c(w_first,w_sec,w3var,&
                                              Skew_w,w1_1,w1_2,w2_1,w2_2,a) bind (C)
    use shoc, only: shoc_assumed_pdf_vv_parameters

    real(kind=c_real), intent(in), value :: w_first
    real(kind=c_real), intent(in), value :: w_sec
    real(kind=c_real), intent(in), value :: w3var

    real(kind=c_real), intent(out) :: Skew_w
    real(kind=c_real), intent(out) :: w1_1
    real(kind=c_real), intent(out) :: w1_2
    real(kind=c_real), intent(out) :: w2_1
    real(kind=c_real), intent(out) :: w2_2
    real(kind=c_real), intent(out) :: a

    call shoc_assumed_pdf_vv_parameters(w_first,w_sec,w3var,&
                                        Skew_w,w1_1,w1_2,w2_1,w2_2,a)

  end subroutine shoc_assumed_pdf_vv_parameters_c

  subroutine shoc_assumed_pdf_thl_parameters_c(&
                           wthlsec,sqrtw2,sqrtthl,thlsec,thl_first,&
                           w1_1,w1_2,Skew_w,a,dothetal_skew,&
                           thl1_1,thl1_2,thl2_1,thl2_2,sqrtthl2_1,&
                           sqrtthl2_2) bind (C)
    use shoc, only: shoc_assumed_pdf_thl_parameters

    real(kind=c_real), intent(in), value :: wthlsec
    real(kind=c_real), intent(in), value :: sqrtw2
    real(kind=c_real), intent(in), value :: sqrtthl
    real(kind=c_real), intent(in), value :: thlsec
    real(kind=c_real), intent(in), value :: thl_first
    real(kind=c_real), intent(in), value :: w1_1
    real(kind=c_real), intent(in), value :: w1_2
    real(kind=c_real), intent(in), value :: Skew_w
    real(kind=c_real), intent(in), value :: a
    logical(kind=c_bool), intent(in), value :: dothetal_skew

    real(kind=c_real), intent(out) :: thl1_1
    real(kind=c_real), intent(out) :: thl1_2
    real(kind=c_real), intent(out) :: thl2_1
    real(kind=c_real), intent(out) :: thl2_2
    real(kind=c_real), intent(out) :: sqrtthl2_1
    real(kind=c_real), intent(out) :: sqrtthl2_2

    call shoc_assumed_pdf_thl_parameters(&
                           wthlsec,sqrtw2,sqrtthl,thlsec,thl_first,&
                           w1_1,w1_2,Skew_w,a,dothetal_skew,&
                           thl1_1,thl1_2,thl2_1,thl2_2,sqrtthl2_1,&
                           sqrtthl2_2)

  end subroutine shoc_assumed_pdf_thl_parameters_c

  subroutine shoc_assumed_pdf_qw_parameters_c(&
                           wqwsec,sqrtw2,Skew_w,sqrtqt,qwsec,&
                           w1_1,w1_2,qw_first,a,&
                           qw1_1,qw1_2,qw2_1,qw2_2,sqrtqw2_1,&
                           sqrtqw2_2) bind (C)
    use shoc, only: shoc_assumed_pdf_qw_parameters

    real(kind=c_real), intent(in), value :: wqwsec
    real(kind=c_real), intent(in), value :: sqrtw2
    real(kind=c_real), intent(in), value :: sqrtqt
    real(kind=c_real), intent(in), value :: qwsec
    real(kind=c_real), intent(in), value :: qw_first
    real(kind=c_real), intent(in), value :: w1_1
    real(kind=c_real), intent(in), value :: w1_2
    real(kind=c_real), intent(in), value :: Skew_w
    real(kind=c_real), intent(in), value :: a

    real(kind=c_real), intent(out) :: qw1_1
    real(kind=c_real), intent(out) :: qw1_2
    real(kind=c_real), intent(out) :: qw2_1
    real(kind=c_real), intent(out) :: qw2_2
    real(kind=c_real), intent(out) :: sqrtqw2_1
    real(kind=c_real), intent(out) :: sqrtqw2_2

    call shoc_assumed_pdf_qw_parameters(&
                          wqwsec,sqrtw2,Skew_w,sqrtqt,qwsec,&
                          w1_1,w1_2,qw_first,a,&
                          qw1_1,qw1_2,qw2_1,qw2_2,sqrtqw2_1,&
                          sqrtqw2_2)

  end subroutine shoc_assumed_pdf_qw_parameters_c

  subroutine shoc_assumed_pdf_inplume_correlations_c(&
                sqrtqw2_1,sqrtthl2_1,a,sqrtqw2_2,sqrtthl2_2,&
                qwthlsec,qw1_1,qw_first,thl1_1,thl_first,qw1_2,thl1_2,&
                r_qwthl_1) bind (C)
    use shoc, only: shoc_assumed_pdf_inplume_correlations

    real(kind=c_real), intent(in), value :: sqrtqw2_1
    real(kind=c_real), intent(in), value :: sqrtthl2_1
    real(kind=c_real), intent(in), value :: a
    real(kind=c_real), intent(in), value :: sqrtqw2_2
    real(kind=c_real), intent(in), value :: sqrtthl2_2
    real(kind=c_real), intent(in), value :: qwthlsec
    real(kind=c_real), intent(in), value :: qw1_1
    real(kind=c_real), intent(in), value :: qw_first
    real(kind=c_real), intent(in), value :: thl1_1
    real(kind=c_real), intent(in), value :: thl_first
    real(kind=c_real), intent(in), value :: qw1_2
    real(kind=c_real), intent(in), value :: thl1_2

    real(kind=c_real), intent(out) :: r_qwthl_1

    call shoc_assumed_pdf_inplume_correlations(&
                sqrtqw2_1,sqrtthl2_1,a,sqrtqw2_2,sqrtthl2_2,&
                qwthlsec,qw1_1,qw_first,thl1_1,thl_first,qw1_2,thl1_2,&
                r_qwthl_1)

  end subroutine shoc_assumed_pdf_inplume_correlations_c

  subroutine shoc_assumed_pdf_compute_temperature_c(&
                                   thl1,basepres,pval,Tl1) bind (C)
    use shoc, only: shoc_assumed_pdf_compute_temperature

    real(kind=c_real), intent(in), value :: thl1
    real(kind=c_real), intent(in), value :: basepres
    real(kind=c_real), intent(in), value :: pval

    real(kind=c_real), intent(out) :: Tl1

    call shoc_assumed_pdf_compute_temperature(thl1,basepres,pval,Tl1)

  end subroutine shoc_assumed_pdf_compute_temperature_c

  subroutine shoc_assumed_pdf_compute_qs_c(&
                              Tl1_1,Tl1_2,pval,&
                              qs1,beta1,qs2,beta2) bind (C)
    use shoc, only: shoc_assumed_pdf_compute_qs

    real(kind=c_real), intent(in), value :: Tl1_1
    real(kind=c_real), intent(in), value :: Tl1_2
    real(kind=c_real), intent(in), value :: pval

    real(kind=c_real), intent(out) :: qs1
    real(kind=c_real), intent(out) :: beta1
    real(kind=c_real), intent(out) :: qs2
    real(kind=c_real), intent(out) :: beta2

    call shoc_assumed_pdf_compute_qs(&
                              Tl1_1,Tl1_2,pval,&
                              qs1,beta1,qs2,beta2)

  end subroutine shoc_assumed_pdf_compute_qs_c

  subroutine shoc_assumed_pdf_compute_s_c(&
                              qw1,qs1,beta,pval,thl2,&
                              qw2,sqrtthl2,sqrtqw2,r_qwthl,&
                              s,std_s,qn,C) bind (C)
    use shoc, only: shoc_assumed_pdf_compute_s

    real(kind=c_real), intent(in), value :: qw1
    real(kind=c_real), intent(in), value :: qs1
    real(kind=c_real), intent(in), value :: beta
    real(kind=c_real), intent(in), value :: pval
    real(kind=c_real), intent(in), value :: thl2
    real(kind=c_real), intent(in), value :: qw2
    real(kind=c_real), intent(in), value :: sqrtthl2
    real(kind=c_real), intent(in), value :: sqrtqw2
    real(kind=c_real), intent(in), value :: r_qwthl

    real(kind=c_real), intent(out) :: s
    real(kind=c_real), intent(out) :: std_s
    real(kind=c_real), intent(out) :: qn
    real(kind=c_real), intent(out) :: C

    call shoc_assumed_pdf_compute_s(&
                              qw1,qs1,beta,pval,thl2,&
                              qw2,sqrtthl2,sqrtqw2,r_qwthl,&
                              s,std_s,qn,C)

  end subroutine shoc_assumed_pdf_compute_s_c

  subroutine shoc_assumed_pdf_compute_sgs_liquid_c(&
                              a,ql1,ql2,shoc_ql) bind (C)
    use shoc, only: shoc_assumed_pdf_compute_sgs_liquid

    real(kind=c_real), intent(in), value :: a
    real(kind=c_real), intent(in), value :: ql1
    real(kind=c_real), intent(in), value :: ql2

    real(kind=c_real), intent(out) :: shoc_ql

    call shoc_assumed_pdf_compute_sgs_liquid(&
                              a,ql1,ql2,shoc_ql)

  end subroutine shoc_assumed_pdf_compute_sgs_liquid_c

  subroutine shoc_assumed_pdf_compute_cloud_liquid_variance_c(&
                                           a,s1,ql1,C1,std_s1,&
                                           s2,ql2,C2,std_s2,shoc_ql,&
                                           shoc_ql2) bind (C)
    use shoc, only: shoc_assumed_pdf_compute_cloud_liquid_variance

    real(kind=c_real), intent(in), value :: a
    real(kind=c_real), intent(in), value :: s1
    real(kind=c_real), intent(in), value :: ql1
    real(kind=c_real), intent(in), value :: C1
    real(kind=c_real), intent(in), value :: std_s1
    real(kind=c_real), intent(in), value :: s2
    real(kind=c_real), intent(in), value :: ql2
    real(kind=c_real), intent(in), value :: C2
    real(kind=c_real), intent(in), value :: std_s2
    real(kind=c_real), intent(in), value :: shoc_ql

    real(kind=c_real), intent(out) :: shoc_ql2

    call shoc_assumed_pdf_compute_cloud_liquid_variance(&
                                           a,s1,ql1,C1,std_s1,&
                                           s2,ql2,C2,std_s2,shoc_ql,&
                                           shoc_ql2)

  end subroutine shoc_assumed_pdf_compute_cloud_liquid_variance_c

  subroutine shoc_assumed_pdf_compute_liquid_water_flux_c(&
                                     a,w1_1,w_first,ql1,w1_2,ql2,&
                                     wqls) bind (C)
    use shoc, only: shoc_assumed_pdf_compute_liquid_water_flux

    real(kind=c_real), intent(in), value :: a
    real(kind=c_real), intent(in), value :: w1_1
    real(kind=c_real), intent(in), value :: w_first
    real(kind=c_real), intent(in), value :: ql1
    real(kind=c_real), intent(in), value :: w1_2
    real(kind=c_real), intent(in), value :: ql2

    real(kind=c_real), intent(out) :: wqls

    call shoc_assumed_pdf_compute_liquid_water_flux(&
                                     a,w1_1,w_first,ql1,w1_2,ql2,&
                                     wqls)

  end subroutine shoc_assumed_pdf_compute_liquid_water_flux_c

  subroutine shoc_assumed_pdf_compute_buoyancy_flux_c(&
                                     wthlsec,epsterm,wqwsec,pval,wqls,&
                                     wthv_sec) bind (C)
    use shoc, only: shoc_assumed_pdf_compute_buoyancy_flux

    real(kind=c_real), intent(in), value :: wthlsec
    real(kind=c_real), intent(in), value :: epsterm
    real(kind=c_real), intent(in), value :: wqwsec
    real(kind=c_real), intent(in), value :: pval
    real(kind=c_real), intent(in), value :: wqls

    real(kind=c_real), intent(out) :: wthv_sec

    call shoc_assumed_pdf_compute_buoyancy_flux(&
                                     wthlsec,epsterm,wqwsec,pval,wqls,&
                                     wthv_sec)

  end subroutine shoc_assumed_pdf_compute_buoyancy_flux_c

 subroutine shoc_diag_second_moments_ubycond_c(shcol, thl_sec, qw_sec, wthl_sec, wqw_sec, qwthl_sec, uw_sec, vw_sec, wtke_sec) bind(C)
   use shoc, only: diag_second_moments_ubycond

   ! argmens
   integer(kind=c_int), value, intent(in) :: shcol
   real(kind=c_real), intent(out)  :: thl_sec(shcol), qw_sec(shcol), qwthl_sec(shcol),wthl_sec(shcol),wqw_sec(shcol), uw_sec(shcol), vw_sec(shcol), wtke_sec(shcol)

   call diag_second_moments_ubycond(shcol, thl_sec, qw_sec, wthl_sec, wqw_sec, qwthl_sec, uw_sec, vw_sec, wtke_sec)
 end subroutine shoc_diag_second_moments_ubycond_c

 subroutine shoc_pblintd_init_pot_c(shcol, nlev, thl, ql, q, thv) bind(C)
   use shoc, only: pblintd_init_pot

   integer(kind=c_int), value, intent(in) :: shcol, nlev
   real(kind=c_real), intent(in)  :: thl(shcol, nlev), ql(shcol, nlev), q(shcol, nlev)
   real(kind=c_real), intent(out) :: thv(shcol, nlev)

   call pblintd_init_pot(shcol, nlev, thl, ql, q, thv)

 end subroutine shoc_pblintd_init_pot_c

  subroutine diag_second_moments_lbycond_c(shcol, wthl_sfc, wqw_sfc, uw_sfc, vw_sfc, ustar2, wstar, wthl_sec, wqw_sec, uw_sec, vw_sec, wtke_sec, thl_sec, qw_sec, qwthl_sec) bind(C)
    use shoc, only : diag_second_moments_lbycond

    integer(kind=c_int) , value, intent(in) :: shcol
    real(kind=c_real) , intent(in), dimension(shcol) :: wthl_sfc, wqw_sfc, uw_sfc, vw_sfc, ustar2, wstar
    real(kind=c_real) , intent(out), dimension(shcol) :: wthl_sec, wqw_sec, uw_sec, vw_sec, wtke_sec, thl_sec, qw_sec, qwthl_sec

    call diag_second_moments_lbycond(shcol, wthl_sfc, wqw_sfc, uw_sfc, vw_sfc, ustar2, wstar, wthl_sec, wqw_sec, uw_sec, vw_sec, wtke_sec, thl_sec, qw_sec, qwthl_sec)
  end subroutine diag_second_moments_lbycond_c

  subroutine diag_second_moments_c(shcol, nlev, nlevi, thetal, qw, u_wind, v_wind, tke, isotropy, tkh, tk, dz_zi, zt_grid, zi_grid, shoc_mix, thl_sec, qw_sec, &
                                   wthl_sec, wqw_sec, qwthl_sec, uw_sec, vw_sec, wtke_sec, w_sec) bind(C)
    use shoc, only : diag_second_moments

    integer(kind=c_int) , value, intent(in) :: shcol, nlev, nlevi
    real(kind=c_real) , intent(in), dimension(shcol, nlev) :: thetal, qw, u_wind, v_wind, tke, isotropy, tkh, tk, zt_grid, shoc_mix
    real(kind=c_real) , intent(in), dimension(shcol, nlevi) :: dz_zi, zi_grid
    real(kind=c_real) , intent(inout), dimension(shcol, nlevi) :: thl_sec, qw_sec, wthl_sec, wqw_sec, qwthl_sec, uw_sec, vw_sec, wtke_sec
    real(kind=c_real) , intent(out), dimension(shcol, nlev) :: w_sec

    call diag_second_moments(shcol, nlev, nlevi, thetal, qw, u_wind, v_wind, tke, isotropy, tkh, tk, dz_zi, zt_grid, zi_grid, shoc_mix, thl_sec, &
                             qw_sec, wthl_sec, wqw_sec, qwthl_sec, uw_sec, vw_sec, wtke_sec, w_sec)

  end subroutine diag_second_moments_c

  subroutine diag_second_shoc_moments_c(shcol, nlev, nlevi, thetal, qw, u_wind, v_wind, tke, isotropy, tkh, tk, dz_zi, zt_grid, &
                                        zi_grid, shoc_mix, wthl_sfc, wqw_sfc, uw_sfc, vw_sfc, thl_sec, qw_sec, wthl_sec, wqw_sec, &
                                        qwthl_sec, uw_sec, vw_sec, wtke_sec, w_sec) bind(C)
    use shoc, only : diag_second_shoc_moments

    integer(kind=c_int) , value, intent(in) :: shcol, nlev, nlevi
    real(kind=c_real) , intent(in), dimension(shcol, nlev) :: thetal, qw, u_wind, v_wind, tke, isotropy, tkh, tk, zt_grid, shoc_mix
    real(kind=c_real) , intent(in), dimension(shcol, nlevi) :: dz_zi, zi_grid
    real(kind=c_real) , intent(in), dimension(shcol) :: wthl_sfc, wqw_sfc, uw_sfc, vw_sfc
    real(kind=c_real) , intent(out), dimension(shcol, nlevi) :: thl_sec, qw_sec, wthl_sec, wqw_sec, qwthl_sec, uw_sec, vw_sec, wtke_sec
    real(kind=c_real) , intent(out), dimension(shcol, nlev) :: w_sec

    call diag_second_shoc_moments(shcol, nlev, nlevi, thetal, qw, u_wind, v_wind, tke, isotropy, tkh, tk, dz_zi, zt_grid, &
                                  zi_grid, shoc_mix, wthl_sfc, wqw_sfc, uw_sfc, vw_sfc, thl_sec, qw_sec, wthl_sec, wqw_sec, &
                                  qwthl_sec, uw_sec, vw_sec, wtke_sec, w_sec)
  end subroutine diag_second_shoc_moments_c

  subroutine shoc_pblintd_cldcheck_c(shcol, nlev, nlevi, zi, cldn, pblh) bind(C)
    use shoc, only: pblintd_cldcheck

    integer(kind=c_int), value, intent(in) :: shcol, nlev, nlevi
    real(kind=c_real), intent(in) :: zi(shcol, nlevi), cldn(shcol, nlev)
    real(kind=c_real), intent(inout) :: pblh(shcol)

    call pblintd_cldcheck(shcol, nlev, nlevi, zi, cldn, pblh)
  end subroutine shoc_pblintd_cldcheck_c

  subroutine compute_shoc_vapor_c(shcol, nlev, qw, ql, qv) bind(C)
    use shoc, only : compute_shoc_vapor

    integer(kind=c_int) , value, intent(in) :: shcol, nlev
    real(kind=c_real) , intent(in), dimension(shcol, nlev) :: qw, ql
    real(kind=c_real) , intent(out), dimension(shcol, nlev) :: qv

    call compute_shoc_vapor(shcol, nlev, qw, ql, qv)
  end subroutine compute_shoc_vapor_c

  subroutine update_prognostics_implicit_c(shcol, nlev, nlevi, num_tracer, dtime, dz_zt, dz_zi, rho_zt, zt_grid, zi_grid, tk, tkh, uw_sfc, vw_sfc, wthl_sfc, wqw_sfc, wtracer_sfc, thetal, qw, tracer, tke, u_wind, v_wind) bind(C)
    use shoc, only : update_prognostics_implicit

    integer(kind=c_int) , value, intent(in) :: shcol, nlev, nlevi, num_tracer
    real(kind=c_real) , value, intent(in) :: dtime
    real(kind=c_real) , intent(in), dimension(shcol, nlev) :: dz_zt, rho_zt, zt_grid, tk, tkh
    real(kind=c_real) , intent(in), dimension(shcol, nlevi) :: dz_zi, zi_grid
    real(kind=c_real) , intent(in), dimension(shcol) :: uw_sfc, vw_sfc, wthl_sfc, wqw_sfc
    real(kind=c_real) , intent(in), dimension(shcol, num_tracer) :: wtracer_sfc
    real(kind=c_real) , intent(inout), dimension(shcol, nlev) :: thetal, qw, tke, u_wind, v_wind
    real(kind=c_real) , intent(inout), dimension(shcol, nlev, num_tracer) :: tracer

    call update_prognostics_implicit(shcol, nlev, nlevi, num_tracer, dtime, dz_zt, dz_zi, rho_zt, zt_grid, zi_grid, tk, tkh, uw_sfc, vw_sfc, wthl_sfc, wqw_sfc, wtracer_sfc, thetal, qw, tracer, tke, u_wind, v_wind)
  end subroutine update_prognostics_implicit_c

  subroutine pblintd_height_c(shcol, nlev, z, u, v, ustar, thv, thv_ref, pblh, rino, check) bind(C)
    use shoc, only : npbl, pblintd_height

    integer(kind=c_int) , value, intent(in) :: shcol, nlev
    real(kind=c_real) , intent(in), dimension(shcol, nlev) :: z, u, v, thv
    real(kind=c_real) , intent(in), dimension(shcol) :: ustar, thv_ref
    real(kind=c_real) , intent(out), dimension(shcol) :: pblh
    real(kind=c_real) , intent(inout), dimension(shcol, nlev) :: rino
    logical(kind=c_bool) , intent(inout), dimension(shcol) :: check

    ! setup npbl
    npbl = nlev
    call pblintd_height(shcol, nlev, z, u, v, ustar, thv, thv_ref, pblh, rino, check)
  end subroutine pblintd_height_c

  subroutine vd_shoc_decomp_c(shcol, nlev, nlevi, kv_term, tmpi, rdp_zt, dtime, flux, du, dl, d) bind(C)
    use shoc, only : vd_shoc_decomp

    integer(kind=c_int) , value, intent(in) :: shcol, nlev, nlevi
    real(kind=c_real) , intent(in), dimension(shcol, nlevi) :: kv_term, tmpi
    real(kind=c_real) , intent(in), dimension(shcol, nlev) :: rdp_zt
    real(kind=c_real) , value, intent(in) :: dtime
    real(kind=c_real) , intent(in), dimension(shcol) :: flux
    real(kind=c_real) , intent(out), dimension(shcol, nlev) :: du, dl, d

    call vd_shoc_decomp(shcol, nlev, nlevi, kv_term, tmpi, rdp_zt, dtime, flux, du, dl, d)
  end subroutine vd_shoc_decomp_c

  subroutine vd_shoc_solve_c(shcol, nlev, du, dl, d, var) bind(C)
    use shoc, only : vd_shoc_solve

    integer(kind=c_int) , value, intent(in) :: shcol, nlev
    real(kind=c_real) , intent(in), dimension(shcol, nlev) :: du, dl, d
    real(kind=c_real) , intent(inout), dimension(shcol, nlev) :: var

    call vd_shoc_solve(shcol, nlev, du, dl, d, var)
  end subroutine vd_shoc_solve_c

  subroutine pblintd_surf_temp_c(shcol, nlev, nlevi, z, ustar, obklen, kbfs, thv, tlv, pblh, check, rino) bind(C)
    use shoc, only : npbl, pblintd_surf_temp

    integer(kind=c_int) , value, intent(in) :: shcol, nlev, nlevi
    real(kind=c_real) , intent(in), dimension(shcol, nlev) :: z, thv
    real(kind=c_real) , intent(in), dimension(shcol) :: ustar, obklen, kbfs
    real(kind=c_real) , intent(out), dimension(shcol) :: tlv
    real(kind=c_real) , intent(inout), dimension(shcol) :: pblh
    logical(kind=c_bool) , intent(inout), dimension(shcol) :: check
    real(kind=c_real) , intent(inout), dimension(shcol, nlev) :: rino

    ! setup npbl
    npbl = nlev
    call pblintd_surf_temp(shcol, nlev, nlevi, z, ustar, obklen, kbfs, thv, tlv, pblh, check, rino)
  end subroutine pblintd_surf_temp_c

  subroutine pblintd_check_pblh_c(shcol, nlev, nlevi, z, ustar, check, pblh) bind(C)
    use shoc, only : npbl,pblintd_check_pblh

    integer(kind=c_int) , value, intent(in) :: shcol, nlev, nlevi
    real(kind=c_real) , intent(in), dimension(shcol, nlev) :: z
    real(kind=c_real) , intent(in), dimension(shcol) :: ustar
    logical(kind=c_bool) , intent(in), dimension(shcol) :: check
    real(kind=c_real) , intent(out), dimension(shcol) :: pblh

    ! setup npbl
    npbl = nlev
    call pblintd_check_pblh(shcol, nlev, nlevi, z, ustar, check, pblh)
  end subroutine pblintd_check_pblh_c

  subroutine pblintd_c(shcol, nlev, nlevi, z, zi, thl, ql, q, u, v, ustar, obklen, kbfs, cldn, pblh) bind(C)
    use shoc, only : pblintd

    integer(kind=c_int) , value, intent(in) :: shcol, nlev, nlevi
    real(kind=c_real) , intent(in), dimension(shcol, nlev) :: z, thl, ql, q, u, v, cldn
    real(kind=c_real) , intent(in), dimension(shcol, nlevi) :: zi
    real(kind=c_real) , intent(in), dimension(shcol) :: ustar, obklen, kbfs
    real(kind=c_real) , intent(out), dimension(shcol) :: pblh

    call pblintd(shcol, nlev, nlevi, z, zi, thl, ql, q, u, v, ustar, obklen, kbfs, cldn, pblh)
  end subroutine pblintd_c
end module shoc_iso_c


      double precision
     . ro,omro,xm,xm2,U,T,f1,f2,f3,INVG,
     . xlm,vlpm,vlsm,vltm,vlwm,vlbl,vdmp,vdmb,
     . vdt,vdw,xlf,rmuom2,tbar,ubar,b,xlp,t1,t2,brackt,brackw,bracks
      common/virtexp/
     . ro,omro,xm,xm2,U,T,f1,f2,f3,INVG,
     . xlm,vlpm,vlsm,vltm,vlwm,vlbl,vdmp,vdmb,
     . vdt,vdw,xlf,rmuom2,tbar,ubar,b,xlp,t1,t2,brackt,brackw,bracks


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     subroutine ff_hb_two: energies and gradients of hydrogen/halogen
!         bond terms of the second QMDFF
!
!     part of QMDFF
!
subroutine ff_hb_two(n,at,xyz,eh,g)
use qmdff
implicit none
integer::n,at(*)
real(kind=8)::xyz(3,n),g(3,n),eh
integer::i1,i2,i,k,j
real(kind=8)::c1,c2,r,er,el,step,edum,dum

if (nhb_two.lt.1) return
!
!     loop over all hydrogen/halogen bonds:
!     first determine distance between donor/acceptor
!     count only if distance is smaller than 15 bohr
!
do k=1,nhb_two
   i1 =hb_two(1,k)
   i2 =hb_two(2,k)
   r=sqrt((xyz(1,i1)-xyz(1,i2))**2 &
     &   +(xyz(2,i1)-xyz(2,i2))**2 &
     &   +(xyz(3,i1)-xyz(3,i2))**2)
   if (r.gt.15.0d0) cycle
   i=hb_two(3,k)
!
!     if an H-atom takes part, calculate hydrogen bond
!
   if (at(i).eq.1) then
      c1 =vhb_two(1,k)
      c2 =vhb_two(2,k)
      call eabhag(n,i1,i2,i,xyz,c1,c2,eh,g)
   else
      c1 =vhb_two(1,k)
      call eabxag(n,i1,i2,i,xyz,c1,eh,g)
   end if
end do

return
end subroutine ff_hb_two


      subroutine ovrlp (iph, iphat, rat, iatph, novr, iphovr,
     1                nnovr, rovr, iz, nat, rho, dmag,
     2                rhoval, vcoul, edens, edenvl, vclap, rnrm)

c     Overlaps coulomb potentials and electron densities for current
c     unique potential
      implicit double precision (a-h, o-z)

      include '../HEADERS/const.h'
      include '../HEADERS/dim.h'

      dimension iphat(natx)
      dimension rat(3,natx)
      dimension iatph(0:nphx)
      dimension novr(0:nphx)
      dimension iphovr(novrx,0:nphx)
      dimension nnovr(novrx,0:nphx)
      dimension rovr(novrx,0:nphx)
      dimension iz(0:nphx)
      dimension rho(251,0:nphx+1), dmag(251,0:nphx+1)
      dimension vcoul(251,0:nphx+1), rhoval(251,0:nphx+1)
      dimension edens(251,0:nphx), edenvl(251,0:nphx)
      dimension vclap(251,0:nphx)
      dimension rnrm(0:nphx)
c#mn
       external dist

c     start with free atom values for current atom
      do 100  i = 1, 251
         vclap(i,iph) = vcoul(i,iph)
         edens(i,iph) = rho  (i,iph)

cc       investigate effect of central atom spin only
c        if (iph.ge.1) dmag(i,iph) = 0.0

         edenvl(i,iph) = rhoval  (i,iph)
  100 continue

      if (novr(iph) .gt. 0)  then
         do 104  iovr = 1, novr(iph)
            rnn  = rovr(iovr,iph)
            ann  = nnovr(iovr,iph)
            infr = iphovr(iovr,iph)
            call sumax (rnn, ann, vcoul(1,infr), vclap(1,iph))
            call sumax (rnn, ann, rho  (1,infr), edens(1,iph))
            call sumax (rnn, ann, rho  (1,infr), edenvl(1,iph))
  104    continue
      else
c        Do overlapping from geometry with model atom iat
         iat = iatph(iph)

c        overlap with all atoms within r overlap max (rlapx)
c        12 au = 6.35 ang  This number pulled out of a hat...
         rlapx = 12
c        inat is Index of Neighboring ATom
         do 110  inat = 1, nat
c           don't overlap atom with itself
            if (inat .eq. iat)  goto 110

c           if neighbor is too far away, don't overlap it
            rnn = dist (rat(1,inat), rat(1,iat))
            if (rnn .gt. rlapx)  goto 110

            infr = iphat(inat)
            call sumax (rnn, one, vcoul(1,infr), vclap(1,iph))
            call sumax (rnn, one, rho  (1,infr), edens(1,iph))
            call sumax (rnn, one, rho  (1,infr), edenvl(1,iph))
cala        call sumax (rnn, one, rhoval(1,infr), edenvl(1,iph))
  110       continue
      endif

c     set norman radius
      call frnrm (edens(1,iph), iz(iph), rnrm(iph))

c     remember ratio dmag/edens , not dmag itself
      do 200 i = 1,251
        if (edens(i,iph) .gt. 0.d0) then
          dmag(i,iph) = dmag(i,iph) / edens(i,iph)
        else
          dmag(i,iph) = 0.d0
        endif
 200  continue

      return
      end


      subroutine  dpdpfa
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C***********************************************************************
CD1
CD1  PURPOSE
CD1
CD1  To load the double porosity/double permeability solution into the
CD1  solution matrix for an isothermal air-water simulation.
CD1
C***********************************************************************
CD2
CD2  REVISION HISTORY
CD2
CD2 $Log:   /pvcs.config/fehm90/src/dpdpfa.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:42:54   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:03:00   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:08:32   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:23:22   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 11:59:50   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:40:52 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.8   Thu Feb 15 09:50:46 1996   zvd
CD2 Corrected purpose and requirements.
CD2
CD2    Rev 1.7   Wed Jan 10 11:08:50 1996   hend
CD2 Corrected ECD Number
CD2
CD2    Rev 1.6   Wed Jan 10 09:33:16 1996   hend
CD2 Revised Prolog
CD2
CD2    Rev 1.5   Wed Jan 10 08:44:48 1996   hend
CD2 Added Prolog
CD2
CD2    Rev 1.4   11/15/95 16:19:42   gaz
CD2 fixes so upwind perms except fracture matrix interaction
CD2
CD2    Rev 1.3   08/07/95 11:09:04   awolf
CD2 Loads last part of a_axy with connection fluxes between
CD2 matrix and fracture for dpdp transport use later.
CD2
CD2    Rev 1.2   03/23/94 14:41:02   robinson
CD2 Additional cleanup of memory management
CD2
CD2    Rev 1.1   03/18/94 15:47:22   gaz
CD2 Added solve_new and cleaned up memory management.
CD2
CD2    Rev 1.0   01/20/94 10:23:10   pvcs
CD2 original version in process of being certified
CD2
C***********************************************************************
CD3
CD3  REQUIREMENTS TRACEABILITY
CD3
CD3 2.3.2 Heat- and mass-transfer equations
CD3 2.4.9 Double-porosity/double-permeability formulation
CD3 2.5.2  Solve nonlinear equation set at each time step
CD3
C***********************************************************************
CD4
CD4  SPECIAL COMMENTS AND REFERENCES
CD4
CD4 Requirements from SDN: 10086-RD-2.20-00
CD4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
CD4   FEHM Application Version 2.20
CD4
C***********************************************************************

      use comflow
      use davidi
      use comji
      use comhi
      use comgi
      use comfi
      use comei
      use comdi
      use comci
      use combi
      use comdti
      use comai
      implicit none

      integer i, id, idg, idl, idum, isl, iz, jm
      integer kb, kz, neighc, neq2, neqp1, nmat2avw
      real*8  alen, al0, al1, area
      real*8  axkb, axy, axyd, axyf
      real*8  coef1, coefmx
      real*8  dfmlis, dfmlkbs, dfmvis, dfmvkbs
      real*8  dilci, dilckb, dili, dilei, dilekb, dilkb, dilpi, dilpkb
      real*8  divci, divckb, divei, divekb, divi, divkb, divpi, divpkb
      real*8  dist01
      real*8  dlaei, dlaekb, dlapi, dlapkb
      real*8  dlei, dlekb, dlpi, dlpkb, dpvti
      real*8  dvaei, dvaekb, dvapi, dvapkb
      real*8  dvei, dvekb, dvpi, dvpkb
      real*8  fid, fid1, fmkb, fmli, fmlkb, fmvi, fmvkb, frac0, frac1
      real*8  phii, phikb, pvii, pvikb, pvxy, pxy, pxyh, pxyi
      real*8  radi, radkb
      real*8  swi, sx2c, sx2t, sx4d, sx4h
      real*8  ti, tot
      real*8  vxy, vxyd, vxyf
      parameter (coefmx=1000000000.0)

      neq2   =  neq+neq
      neqp1  =  neq+1
      nmat2avw = 2*(nelm(neqp1)-neqp1)
                                ! Guessed at value for fmkb
      fmkb = 1.0
c
c     zero out transfer terms
c
      do i=1,nmat(2)
         if (jswitch .ne. 0) then
            a(i+nmat(3))=0.
            a(i+nmat(4))=0.
            a(i+nmat(5))=0.
            a(i+nmat(6))=0.
         else
            a(i+nmat(3))=0.
            a(i+nmat(4))=0.
            a(i+nmat(7))=0.
            a(i+nmat(8))=0.
            a(i+nmat(9))=0.
            a(i+nmat(10))=0.
            a(i+nmat(13))=0.
            a(i+nmat(14))=0.
         end if
      enddo
c
c     compute the fracture-matrix transfer terms
c
c     loop on nodes
      do id=1,neq
c     identify diagonal member
         idg =  nelmdg(id)
         idum =  idg-neqp1
c     identify matrix node
         i=id
         idl=id+neq
         tot=sx1(id)+sx1(idl)
         frac0=sx1(id)/tot
         frac1=sx1(idl)/tot
         alen=apuv1(id)
         al0=frac0*alen
         al1=frac1*alen
c
c     determine contribution to node id
c
         dist01=0.5*(al0+al1)
         if(dist01.le.1.e-15) dist01=1.e-15
         area=tot/alen
         pvii=phi(i)
         phii=pvii-pcp(i)
         dpvti=dpcef(i)
         kb=idl
         if(irlpt(irlp(i)).eq.7) then
c     add fracture-matrix factors(Sandia)
            fmvi=fmvf(i)
            dfmvis=dfmvf(i)
            fmvkb=fmvf(kb)
            dfmvkbs=dfmvf(kb)
            fmli=fmlf(i)
            dfmlis=dfmlf(i)
            fmlkb=fmlf(kb)
            dfmlkbs=dfmlf(kb)
         else
            fmvi=1.0
            dfmvis=0.0
            fmvkb=1.0
            dfmvkbs=0.0
            fmli=1.0
            dfmlis=0.0
            fmlkb=1.0
            dfmlkbs=0.0
         endif
         if(iupk.ne.0) then
c
c     even with iupk set pny contains the correct permeability
c     this will allow for harmonic weighting of the transfer perms
c
            dili=dil(i)/pny(i)*fmli
            divi=div(i)/pny(i)*fmvi
            dilpi=dilp(i)/pny(i)*fmli
            dilei=dile(i)/pny(i)*fmli + dil(i)/pny(i)*dfmlis
            divpi=divp(i)/pny(i)*fmvi
            divei=dive(i)/pny(i)*fmvi + div(i)/pny(i)*dfmvis
            dilkb=dil(kb)/pny(kb)*fmlkb
            divkb=div(kb)/pny(kb)*fmvkb
            dilpkb=dilp(kb)/pny(kb)*fmkb
            dilekb=dile(kb)/pny(kb)*fmlkb+ dil(kb)/pny(kb)*dfmlkbs
            divpkb=divp(kb)/pny(kb)*fmvkb
            divekb=dive(kb)/pny(kb)*fmvkb+ div(kb)/pny(kb)*dfmvkbs
         else
            dili=dil(i)*fmli
            divi=div(i)*fmvi
            dilpi=dilp(i)*fmli
            dilei=dile(i)*fmli + dil(i)*dfmlis
            divpi=divp(i)*fmvi
            divei=dive(i)*fmvi + div(i)*dfmvis
            dilkb=dil(kb)*fmlkb
            divkb=div(kb)*fmvkb
            dilpkb=dilp(kb)*fmkb
            dilekb=dile(kb)*fmlkb+ dil(kb)*dfmlkbs
            divpkb=divp(kb)*fmvkb
            divekb=dive(kb)*fmvkb+ div(kb)*dfmvkbs
         endif
         ti=t(i)
         swi=s(i)
c
c     form constants for i>neq
c
         iz=i
         coef1=-area/dist01
         if(coef1.lt.-coefmx) coef1=coefmx
         if(iupk.ne.0) then
            axkb=max(pny(idl),zero_t)*pnx(idl)
         else
            if(idpdp.eq.1) then
               axkb =  max( pnx(idl),zero_t)
            else if(idpdp.eq.2) then
               axkb =  max( pny(idl),zero_t)
            else if(idpdp.eq.3) then
               axkb =  max( pnz(idl),zero_t)
            else
               axkb =  max( pnx(idl  ),pny(idl  ),
     *              pnz(idl  ),zero_t )
            endif
         endif
c
c     2-d geometry
c
         if (icnl.ne.0)  then
            radi=cord(iz,3)
         elseif (icnl.eq.0)  then
            radi=1.0
         endif
         jm=1
         kb=idl
         kz=kb
         neighc=1
         perml(1)=axkb
         permv(1)=perml(1)
         radkb=radi
         sx2c=radkb*coef1
         pvikb=phi(kb)
         phikb=pvikb-pcp(kb)
         pxy=sx2c*perml(1)
         pvxy=sx2c*permv(1)
         pxyi=pxy*(phikb-phii)
         pxyh=pvxy*(pvikb-pvii)
         t1(neighc)=pxyi
         t2(neighc)=pxyh
         t3(neighc)=pxy
         t4(neighc)=pvxy
         t5(neighc)=0.0
         t6(neighc)=0.0
         t7(neighc)=0.0
c
c     liquid phase calculations
c
         jm=1
         kb=idl
         kz=kb
         neighc=1
         pxyi=t1(neighc)
         sx4d=t6(neighc)
         axyd=pxyi+0.5*sx4d*(rolf(i)+rolf(kb))
     *        *(cord(kz,igrav)-cord(iz,igrav))
         t8(neighc)=axyd
c
c     determine upwind nodes and if liquid phase exists
c
         isl=0
         jm=1
         kb=idl
         kz=kb
         neighc=1
         fid=.5
         axyd=t8(neighc)
         if(axyd.lt.0.0) fid=dnwgt
         if(axyd.gt.0.0) fid=upwgt
         if(t3(neighc).lt.0.0) t9(neighc)=fid
         if(t3(neighc).gt.0.0) t9(neighc)=fid
         if(swi+s(kb).ne.0.0) isl=1
c
c     form equations
c
         if(isl.ne.0) then
            jm=1
            kb=idl
            kz=kb
            neighc=1
            axyd=t8(neighc)
            fid=t9(neighc)
            fid1=1.0-fid
            pxyi=t1(neighc)
            pxy=t3(neighc)
            sx4d=t6(neighc)
            dlpi=-pxy+0.5*sx4d*dglp(i)*(cord(kz,igrav)-cord(iz,igrav))
            dlpkb=pxy+0.5*sx4d*dglp(kb)*(cord(kz,igrav)-cord(iz,igrav))
            dlei=pxy*dpvti+0.5*sx4d*dgle(i)*(cord(kz,igrav)-
     &           cord(iz,igrav))
            dlekb=-pxy*dpcef(kb)+0.5*sx4d*dgle(kb)
     *           *(cord(kz,igrav)-cord(iz,igrav))
            axyf=(fid*dilkb+fid1*dili)
            axy=axyd*axyf
            dlapi=dlpi*axyf+axyd*fid1*dilpi
            dlapkb=dlpkb*axyf+axyd*fid*dilpkb
            dlaei=dlei*axyf+axyd*fid1*dilei
            dlaekb=dlekb*axyf+axyd*fid*dilekb
            a_axy(nmat2avw+i) = axy

            bp(i+nrhs(1))=bp(i+nrhs(1))+axy
            bp(i+nrhs(3))=bp(i+nrhs(3))-axy
            a(idum+nmat(1))=a(idum+nmat(1))+dlapi
            a(idum+nmat(2))=a(idum+nmat(2))+dlaei
            a(idum+nmat(9-joff))=a(idum+nmat(9-joff))-dlapi
            a(idum+nmat(10-joff))=a(idum+nmat(10-joff))-dlaei
            a(idum+nmat(3))=a(idum+nmat(3))+dlapkb
            a(idum+nmat(4))=a(idum+nmat(4))+dlaekb
            a(idum+nmat(11-joff))=a(idum+nmat(11-joff))-dlapkb
            a(idum+nmat(12-joff))=a(idum+nmat(12-joff))-dlaekb
         endif
c
c     vapour phase calculations
c
         jm=1
         kb=idl
         kz=kb
         neighc=1
         pxyh=t2(neighc)
         sx4h=t7(neighc)
         vxyd=pxyh+0.5*sx4h*(rovf(i)+rovf(kb))
     *        *(cord(kz,igrav)-cord(iz,igrav))
         t8(neighc)=vxyd
c
c     determine upwind nodes and if vapour phase exists
c
c     isl=0
         jm=1
         kb=idl
         kz=kb
         neighc=1
         fid=.5
         vxyd=t8(neighc)
         if(vxyd.lt.0.0) fid=dnwgt
         if(vxyd.gt.0.0) fid=upwgt
         if(t4(neighc).lt.0.0) t9(neighc)=fid
         if(t4(neighc).gt.0.0) t9(neighc)=fid

c     form equations
c
         if(isl.ne.0 .and. jswitch .eq. 0) then
            jm=1
            kb=idl
            kz=kb
            neighc=1
            fid=t9(neighc)
            fid1=1.0-fid
            pxyh=t2(neighc)
            pvxy=t4(neighc)
            sx4h=t7(neighc)
            vxyd=t8(neighc)
            dvpi=-pvxy+0.5*sx4h*dgvp(i)*(cord(kz,igrav)-
     &           cord(iz,igrav))
            dvpkb=pvxy+0.5*sx4h*dgvp(kb)*(cord(kz,igrav)-
     &           cord(iz,igrav))
            dvei=0.5*sx4h*dgve(i)*(cord(kz,igrav)-cord(iz,igrav))
            dvekb=0.5*sx4h*dgve(kb)
     *           *(cord(kz,igrav)-cord(iz,igrav))
            vxyf=(fid*divkb+fid1*divi)
            vxy=vxyd*vxyf
            dvapi=dvpi*vxyf+vxyd*fid1*divpi
            dvapkb=dvpkb*vxyf+vxyd*fid*divpkb
            dvaei=dvei*vxyf+vxyd*fid1*divei
            dvaekb=dvekb*vxyf+vxyd*fid*divekb
            a_vxy(nmat2avw+i) = vxy

            bp(i+nrhs(2))=bp(i+nrhs(2))+vxy
            bp(i+nrhs(4))=bp(i+nrhs(4))-vxy
            a(idum+nmat(5))=a(idum+nmat(5))+dvapi
            a(idum+nmat(6))=a(idum+nmat(6))+dvaei
            a(idum+nmat(13))=a(idum+nmat(13))-dvapi
            a(idum+nmat(14))=a(idum+nmat(14))-dvaei
            a(idum+nmat(7))=a(idum+nmat(7))+dvapkb
            a(idum+nmat(8))=a(idum+nmat(8))+dvaekb
            a(idum+nmat(15))=a(idum+nmat(15))-dvapkb
            a(idum+nmat(16))=a(idum+nmat(16))-dvaekb
         endif
      enddo

      return
      end


!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      function umagi   (xp    , yp    , vz     , &
                        np    , mp    , kp     , &
                        nmax  , mmax  , layt   , &
                        flow  , depth , lgrid  , &
                        vol   , xcor  , ycor   , &
                        lgrid2, mnmaxk, acomp  , &
                        tcktot)
!
!
!                   Deltares (former: Deltares)
!
!                        d e l p a r    v3.22
!
!
!     system administration : r.j. vos
!
!
!     created               : june 1996, by r.j. vos
!
!     function              : higher order interpolation on horizontal
!                             flows and jacobian for accuarte displacement
!
!     modified              : 25/11/96: adapted for analytic test pred-corr scheme
!
!
!     notes                 : velocity correction in
!                             predictor-corrector method for delpar
!                             function computes correction factor in
!                             particle velocity during advection step
!                             (differs from vcipcm from dunsbergen)
!                             application: curvilinear grid
!
! umagp = magnitude of particle velocity at particle location obtained
!         by (up,vp,wp) determined by advection procedure
! umagi = magnitude of particle velocity at particle location obtained
!         by (higher order) linear interpolation
!
! umagp = sqrt( up*up + vp*vp + wp*wp )
!
! umagi = (1/j)* sqrt( (h*dy*u)**2 + (h*dx*v)**2 + (w/h)**2 )
!
!***********************************************************************
!
!     logical unit numbers  : none.
!
!     subroutines called    : none.
!
!     functions   called    : none.
!
!     parameters            :
!
!     name    kind     length     funct.  description
!     ====    ====     ======     ======  ===========
!     acomp   real        1       input   use an analytical function
!     c2      real        1       input   depth curve of the wind component
!     c3      real        1       input   depth curve vertical velocities
!     depth   real      mnmax2    input   depth of segment  (in m)
!     dx      real      mnmax2    input   delta x for the segments
!     dy      real      mnmax2    input   delta y for the segments
!     flow    real    2*mnmaxk    input   flows in two directions
!     mp      integer     1       in/out  1th grid index particles
!     np      integer     1       in/out  2th grid index particles
!     kp      integer     1       in/out  3th grid index particles
!     layt    integer             input   number of layers of hydr. database
!     lgrid   integer nmax*mmax   input   grid numbering active table
!     lgrid2  integer nmax*mmax   input   grid numbering all cells (total)
!     mmax    integer     1       input   nr. grid cells in m dir.
!     nmax    integer     1       input   nr. grid cells in n dir.
!     tcktot  real      layt      input   rel. thickness hydro. layers
!     umagi   real        1       input   accurate magn. part.velo at pred.pos
!     umagp   real        1       input   mass-conserv. magn.velo at pred.pos
!     vol     real        1       input   volume (jacobian of this cel)
!     xcor    real        1       input   x-coordinates bottom points
!     ycor    real        1       input   y-coordinates bottom points
!     xp      real        1       input   predicted x-coordinate
!     yp      real        1       input   predicted y-coordinate
!     zp      real        1       input   predicted z-coordinate
!     xpold   real        1       input   initial   x-coordinate
!     ypold   real        1       input   initial   y-coordinate
!     zpold   real        1       input   initial   z-coordinate
!
      use precision_part    ! single/double precision
      use timers
!
      implicit none    ! force explicit typing
!
      integer(ip), dimension(:,: ) :: lgrid , lgrid2
      real   (sp), dimension(:)    :: flow  , depth
      real   (sp), dimension(:)    :: xcor  , ycor , tcktot

      logical  :: acomp, ldepth
!
!     local scalars
!
      integer (ip) :: im     , in    , inr    , mmid  , nmid
      integer (ip) :: kdep   , kp    , layt   , mdn
      integer (ip) :: mmax   , mn    , mn2    , mnd2
      integer (ip) :: mnd    , mnu   , mp     , mun   , mund   , np
      integer (ip) :: mnmaxk , imr
      integer (ip) :: mdn2   , mdnu  , mdnd2  , mdnd  , nmax
!
!     local scalars
!
      real    (sp) :: ac11   , ac12  , ac21   , ac22  , corj
      real    (sp) :: ddx    , ddy   , ddz    , dpx   , dpy
      real    (sp) :: ha     , hb    , hc     , hd    , he
      real    (sp) :: qxf    , qyf   , umagi
      real    (sp) :: qxl    , qyl   , rxf    , rxl   , ryf    , ryl
      real    (sp) :: radius , sqrt  , tperio , twopi , up1    , vd
      real    (sp) :: ua     , ub    , uc     , ud
      real    (sp) :: umdndk , umdnk , umdnuk , umndk , umnk
      real    (sp) :: va     , vb    , vc
      real    (sp) :: velo   , vol   , vp1    , vz    , wp1
      real    (sp) :: vmdndk , vmdnk , vmndk  , vmnk  , vmundk , vmunk
      real    (sp) :: xp     , xq    , yp     , yq
      integer(4) ithndl              ! handle to time this subroutine
      data       ithndl / 0 /
      if ( timon ) call timstrt( "umagi", ithndl )
!
      if(.not.acomp) then
!
!
!..compute an accurate velocity from an accurate jacobian and flow
!
!         linear interpolation
!         the method will be restricted to 2dh application
!
!                 ---+-------+---
!                    |       |
!                  umdnu    umnu
!                    |       |
!         ---+-------d-------c-------+---
!            |       |       |       |
!            |     umdn     umn      |
!            |       |       |       |
!         ---+-------a-------b-------+---
!                    |       |
!                  umdnd    umnd
!                    |       |
!                 ---+-------+---
!
!.. m // u // x-intern // y-national grid
!.. n // v // y-intern // x-national grid
!.. (internal coordinates are natural coordinates between 0 and 1,
!.. for curvilinear grids these are curvilinear coordinates epsilon and nu)
!
         if(np==1.or.mp==mmax) then
            stop ' Particle outside domain in umagi '
         endif
         mn    = lgrid ( np, mp )
         if(mn <= 0) stop ' MN at forbidden position in umagi '
         mn2   = lgrid2( np, mp )
         kdep = (kp-1)*nmax*mmax
!
         mdn   = lgrid ( np  , mp-1 )
         mdn2  = lgrid2( np  , mp-1 )
!
         mnd   = lgrid ( np-1, mp )
         mnd2  = lgrid2( np-1, mp )
!
         mdnd   = lgrid ( np-1, mp-1 )
         mdnd2  = lgrid2( np-1, mp-1 )
!
         mun    = lgrid( np, mp+1 )
!
         mund   = lgrid( np-1, mp+1 )
!
         mnu    = lgrid( np+1, mp )
!
         mdnu   = lgrid( np+1, mp-1 )
!
!  determine accurate water depth, and accurate flows at corner points
!
!  start with water depth he
!
         ldepth = .true.
         if(ldepth) then
!
!.. x//m; y//n (x,y are the internal or natural coordinates)
!.. 5 points interpolation
!..
!..
!..     d------c
!.. ^   |      |
!.. |   |      |
!.. y   a------b
!.. n,
!..   m, x =>
!..
!
            if(xp <= (0.5)) then
               xq = 2*xp
               if(mdn > 0) then
                  hd = 0.5*(depth(mdn)+depth(mn))
                  hc = depth(mn)
               else
                  hd = depth(mn)
                  hc = depth(mn)
               endif
            else
               xq = 2*xp-1.0
               if(mun > 0) then
                  hd = depth(mn)
                  hc = 0.5*(depth(mun)+depth(mn))
               else
                  hd = depth(mn)
                  hc = depth(mn)
               endif
            endif
!
            if(yp <= (0.5)) then
               yq = 2*yp
               if(mnd > 0) then
                  ha = 0.5*(depth(mnd)+depth(mn))
                  hb = depth(mn)
               else
                  ha = depth(mn)
                  hb = depth(mn)
               endif
            else
               yq = 2*yp - 1.0
               ha = hc
               hb = hd
               if(mnu > 0) then
                  hc = depth(mn)
                  hd = 0.5*(depth(mnu)+depth(mn))
               else
                  hc = depth(mn)
                  hd = depth(mn)
               endif
            endif
            he = (1.0-xq)*(1.0-yq)*ha
            he = he + xq*(1.0-yq)*hb
            he = he + xq*yq*hc
            he = he + (1.0-xq)*yq*hd
            if(kp <= 0.or.kp > layt) then
               stop  ' KP out of range in umagi '
            endif
            he = he*tcktot(kp)
!
            if(he <= (1.0e-15)) stop 'HP to small or negative in umagi'
         else
            he = depth(mn)
         endif
!
!.. accurate ground surface (determinant)
!
         qxf  = (1.-yp)*xcor(mdnd2) + yp*xcor(mdn2)
         qyf  = (1.-yp)*ycor(mdnd2) + yp*ycor(mdn2)
         qxl  = (1.-yp)*xcor(mnd2 ) + yp*xcor(mn2 )
         qyl  = (1.-yp)*ycor(mnd2 ) + yp*ycor(mn2 )
!
         rxf  = (1.-xp)*xcor(mdnd2) + xp*xcor(mnd2)
         ryf  = (1.-xp)*ycor(mdnd2) + xp*ycor(mnd2)
         rxl  = (1.-xp)*xcor(mdn2 ) + xp*xcor(mn2 )
         ryl  = (1.-xp)*ycor(mdn2 ) + xp*ycor(mn2 )
!
         ac11 = qxl-qxf
         ac21 = qyl-qyf
!
         ac12 = rxl-rxf
         ac22 = ryl-ryf
!
!  the jacobian of the transformation: h*sqrt(g)
!
         corj  = (ac11*ac22 - ac12*ac21)*he
!
!  determine flows at corner points (a, b, c, d)
!
!  first  flow direction:  v // n // y
!  second flow direction:  u // m // x
!
!.. correct for lateral variations , i.e. for u in n direction:
!.. note that delpar is based on the trisula regular ordering
!.. note: interpolation on flows is done, not on velocities
!.. zero flows in cell itself are accounted for, of neighbouring cells
!.. these zero's are neglected.
!
!===flows current cell
!
         umnk  = flow (mn + kdep + mnmaxk)
         vmnk  = flow (mn + kdep)
!
!=== a ===
!
         if(mdn > 0) then
            umdnk = flow (mdn + kdep + mnmaxk)
!.. for d:
            vmdnk = flow (mdn + kdep)
         else
            umdnk = 0.0
            vmdnk = 0.0
         endif
         if(mnd > 0) then
            vmndk = flow (mnd + kdep)
         else
            vmndk = 0.0
         endif
         if(mdnd > 0) then
            umdndk = flow (mdnd + kdep + mnmaxk)
            vmdndk = flow (mdnd + kdep)
         else
            umdndk = umdnk
            vmdndk = vmndk
         endif
         ua = 0.5*(umdnk + umdndk)
         va = 0.5*(vmndk + vmdndk)
!
!=== b ===
!
         if(mnd > 0) then
            umndk = flow (mnd + kdep + mnmaxk)
            vmndk = flow (mnd + kdep)
         else
            umndk = umnk
            vmndk = 0.0
         endif
         if(mund > 0) then
            vmundk = flow(mund+kdep)
         else
            vmundk = vmndk
         endif
         ub = 0.5*(umnk  + umndk)
         vb = 0.5*(vmundk+ vmndk)
!
!=== c ===
!
         if(mnd > 0) then
            umndk = flow (mnu + kdep + mnmaxk)
         else
            umndk = umnk
         endif
         if(mun > 0) then
            vmunk = flow (mun + kdep)
         else
            vmunk = vmnk
         endif
         uc = 0.5*(umnk + umndk)
         vc = 0.5*(vmnk + vmunk)
!
!=== d ===
!
        if(mdnu > 0) then
           umdnuk = flow (mdnu + kdep + mnmaxk)
        else
           umdnuk = umdnk
        endif
        ud = 0.5*(umdnk + umdnuk)
        vd = 0.5*(vmdnk + vmnk  )
!
!
!.. bilinear intepolation in curvilinear space
!
         up1 = (1.-xp)*( (1.-yp)*ua + yp*ud )  &
                  +xp *( (1.-yp)*ub + yp*uc )
!
         vp1 = (1.-xp)*( (1.-yp)*va + yp*vd )  &
                  +xp *( (1.-yp)*vb + yp*vc )
!
!   better approximations for wp1 should be considered in future
!
         wp1 = vol*vz
         umagi = sqrt( up1**2 + vp1**2 + wp1**2   )
         umagi = umagi/corj
!
!  determine umagi analytically
!
      else
         ddx   = 100.0*int(20/(nmax+1))
         ddy   = 100.0*int(20/(mmax+1))
         ddz   = 1.0
         vol   = ddx*ddy*ddz
         twopi = 8.0*atan(1.0)
         tperio= 7200.0
         mmid  = int(mmax/2) + 1
         nmid  = int(nmax/2) + 1
         im  = mp
         in  = np
         inr = in-nmid
         dpy = inr*ddy + (yp-0.5)*ddy
         imr = im-mmid
         dpx = imr*ddx + (xp-0.5)*ddx
         radius = sqrt(dpx*dpx + dpy*dpy)
         velo   = twopi*radius/tperio
!.. ok since ddx = ddy
!        umagi  = ddz*ddx*velo/vol
         umagi  = velo/ddy
      endif
!
      if ( timon ) call timstop ( ithndl )
      return
      end function


Subroutine pi2ro2(i1, i2, lbb1, lbb2, ei1, ei2, iblock, iseed)
  Parameter (maxstr=150001)
  Parameter (ap1=0.13496, ap2=0.13957)
  Common /ee/id(maxstr), lb(maxstr)
  Common /ppb1/ene, factr2(6), fsum, ppinnb, s, wtot
  Common /ppmm/pprr, ppee, pppe, rpre, xopoe, rree
  Common /rndf77/nseed
  Save
  If ((lb(i1)>=3 .And. lb(i1)<=5) .And. (lb(i2)>=3 .And. lb(i2)<=5)) Then
    iblock = 1850
    ei1 = 0.77
    ei2 = 0.77
    lbb1 = 25 + int(3*ranart(nseed))
    lbb2 = 25 + int(3*ranart(nseed))
  Else If ((lb(i1)>=25 .And. lb(i1)<=27) .And. (lb(i2)>=25 .And. lb(i2)<=27)) Then
    iblock = 1851
    lbb1 = 3 + int(3*ranart(nseed))
    lbb2 = 3 + int(3*ranart(nseed))
    ei1 = ap2
    ei2 = ap2
    If (lbb1==4) ei1 = ap1
    If (lbb2==4) ei2 = ap1
  End If
  Return
End Subroutine pi2ro2