Module cohesive_mod
  ! Module for checking for cohesive damage initiation and calculating the cohesive damage variable

  Interface cohesive_damage
    Module Procedure cohesive_damage_matProp, cohesive_damage_toughnessListed, cohesive_damage_propsListed
  End Interface

Contains

  Subroutine cohesive_damage_matProp(m, p, delta, Pen, delta_n_init, B, FI, damage, dGdGc)
    ! Uses the properties in a matProps struct

    Use forlog_Mod
    Use matProp_Mod
    Use parameters_Mod

    ! Arguments
    Type(matProps), intent(IN) :: m
    Type(parameters), intent(IN) :: p
    Double Precision, intent(IN) :: delta(3)
    Double Precision, intent(IN) :: Pen(3), delta_n_init
    Double Precision, intent(INOUT) :: B
    Double Precision, intent(OUT) :: FI
    Double Precision, optional, intent(INOUT) :: damage
    Double Precision, optional, intent(OUT) :: dGdGc
    ! -------------------------------------------------------------------- !

    Call cohesive_damage_propsListed(m%YT,m%SL,m%ST,m%GYT,m%GSL,m%etaL,m%etaT,m%eta_BK,p,delta,Pen,delta_n_init,B,FI,damage,dGdGc)
  End Subroutine cohesive_damage_matProp

  Subroutine cohesive_damage_toughnessListed(GYT, GSL, m, p, delta, Pen, delta_n_init, B, FI, damage, dGdGc)
    ! Uses the properties in a matProps struct

    Use forlog_Mod
    Use matProp_Mod
    Use parameters_Mod

    ! Arguments
    Double Precision, intent(IN) :: GYT, GSL
    Type(matProps), intent(IN) :: m
    Type(parameters), intent(IN) :: p
    Double Precision, intent(IN) :: delta(3)
    Double Precision, intent(IN) :: Pen(3), delta_n_init
    Double Precision, intent(INOUT) :: B
    Double Precision, intent(OUT) :: FI
    Double Precision, optional, intent(INOUT) :: damage
    Double Precision, optional, intent(OUT) :: dGdGc
    ! -------------------------------------------------------------------- !

    Call cohesive_damage_propsListed(m%YT,m%SL,m%ST,GYT,GSL,m%etaL,m%etaT,m%eta_BK,p,delta,Pen,delta_n_init,B,FI,damage,dGdGc)
  End Subroutine cohesive_damage_toughnessListed

  Subroutine cohesive_damage_propsListed(YT, SL, ST, GYT, GSL, etaL, etaT, eta_BK, p, delta, Pen, delta_n_init, B, FI, damage, dGdGc)
    ! All properties are passed in as arguments

    Use forlog_Mod
    Use parameters_Mod

    ! Arguments
    Double Precision, intent(IN) :: YT,SL,ST,GYT,GSL,etaL,etaT,eta_BK        ! Material properties
    Type(parameters), intent(IN) :: p
    Double Precision, intent(IN) :: delta(3)
    Double Precision, intent(IN) :: Pen(3), delta_n_init
    Double Precision, intent(INOUT) :: B
    Double Precision, intent(OUT) :: FI
    Double Precision, optional, intent(INOUT) :: damage
    Double Precision, optional, intent(OUT) :: dGdGc                        ! Normalized energy dissipation

    ! Locals
    Double Precision :: del                                                  ! Magnitude of current cohesive displacement
    Double Precision :: del_n, del_s1, del_s2, del_s                         ! Temporary values used to calculate del
    Double Precision :: del0n, del0s                                         ! Initiation displacements for pure Mode I and Mode II
    Double Precision :: delfn, delfs                                         ! Final displacements for pure Mode I and Mode II
    Double Precision :: d0, df                                               ! Initiation and final displacements for current mode-mixity ratio
    Double Precision :: del0nB, del0sB, delfnB, delfsB                       ! Temporary, used to calculate d0 and df
    Double Precision :: damage_max                                           ! Maximum value for damage variable
    Double Precision :: beta                                                 ! Placeholder (temp.) variables for Mode-mixity
    Double Precision :: KS                                                   ! Shear penalty stiffness
    Double Precision :: B_old, damage_old
    Double Precision :: mode_mix_limit
    Double Precision, parameter :: zero=0.d0, one=1.d0, two=2.d0, ten=10.d0

    ! Fatigue
    Double Precision :: R_old, R_fatigue, R_fatigue_inc, R_max               ! Damage measures
    Double Precision :: damage_static                                        ! Temporary, used to compare static and fatigue damage
    Double Precision :: XLam                                                 ! Normalized fatigue displacement jump
    Double Precision :: fatigue_beta, fatigue_gamma                          ! Fatigue damage parameters
    Integer :: fatigue_parameters(2)
    Double Precision :: cycles_per_increment(1)
    Pointer(ptr_fatigue_int, fatigue_parameters)
    Pointer(ptr_fatigue_dbl, cycles_per_increment)

#ifndef PYEXT
    Interface

      Function SMAIntArrayAccess(ID)
        ! Access an existing global integer array.
        Integer(kind=8) :: SMAIntArrayAccess  ! Returns an address that can be associated with a Fortran pointer
        Integer(kind=4) :: ID       ! Array ID
      End Function SMAIntArrayAccess

      Function SMARealArrayAccess(ID)
        ! Access an existing global real array.
        Integer(kind=8) :: SMARealArrayAccess  ! Returns an address that can be associated with a Fortran pointer
        Integer(kind=4) :: ID   ! Array ID
      End Function SMARealArrayAccess

    End Interface
#endif
    ! -------------------------------------------------------------------- !

    damage_max = one  ! Maximum value for damage variables
    mode_mix_limit = 1.d-6

    ! Cohesive displacement-jumps
    del_s1 = delta(1)
    del_s2 = delta(3)
    del_n  = delta(2)
    del_s  = SQRT(del_s1*del_s1 + del_s2*del_s2)
    del    = SQRT(MAX(zero, del_n)*del_n + del_s*del_s)

    ! Account for LaRC04 and calculate "mixed shear" strengths and stiffnesses
    If (del_s > zero) Then
      ds1_str = SL - etaL*Pen(2)*MIN(zero, delta_n_init)  ! LaRC04 longitudinal shear strength
      ds2_str = ST - etaT*Pen(2)*MIN(zero, delta_n_init)  ! LaRC04 transverse shear strength
      KS = SQRT((Pen(1)*del_s1)**2 + (Pen(3)*del_s2)**2)/del_s  ! Combined shear penalty stiffness
      ds_str = KS*del_s/SQRT((Pen(1)*del_s1/ds1_str)**2 + (Pen(3)*del_s2/ds2_str)**2)
    Else
      ds_str = SL
      KS = Pen(1)
    End If

    ! Cohesive displacements for initiation for pure mode I and mode II
    del0n = YT/Pen(2)  ! mode I cohesive initiation disp.
    del0s = ds_str/KS  ! mode II cohesive initiation disp.

    ! Mode mixity
    beta = del_s*del_s + MAX(zero, del_n)*del_n
    If (beta == zero) Then
      beta = one
    Else
      beta = del_s*del_s/beta
    End If
    B_old = B
    B = KS*beta/(KS*beta + Pen(2)*(one - beta))

    ! Mixed-mode initiation displacements
    If (B >= one - mode_mix_limit) Then
      beta = one
      B = one
      d0 = del0s
    Else If (B <= mode_mix_limit) Then
      beta = zero
      B = zero
      d0 = del0n
    Else
      del0nB = SQRT(((one - B**eta_BK)*del0n*del0n + KS/Pen(2)*B**eta_BK*del0s*del0s)*(one - B))
      del0sB = SQRT(beta/(one - beta))*del0nB
      d0 = SQRT(del0nB*del0nB + del0sB*del0sB)
    End If

    FI = MIN(one, del/d0)

    DamageEvolution: If (present(damage)) Then
      dGdGc = zero

      ! Cohesive displacements for final failure for pure mode I and mode II
      delfn = two*GYT/del0n/Pen(2)  ! mode I cohesive final disp.
      delfs = two*GSL/del0s/KS  ! mode II cohesive final disp.

      ! Mixed-mode final failure displacements
      If (B >= one - mode_mix_limit) Then
        df = delfs
      Else If (B <= mode_mix_limit) Then
        df = delfn
      Else
        delfnB = ((one - B**eta_BK)*del0n*delfn + KS/Pen(2)*B**eta_BK*del0s*delfs)*(one - B)/del0nB
        delfsB = SQRT(beta/(one - beta))*delfnB
        df = SQRT(delfnB*delfnB + delfsB*delfsB)
      End If

      ! Determine the new damage state
      damage_old = damage  ! Store the current damage variable
      If (del == zero) Then
        damage = zero
      Else
        damage = df*(del - d0)/del/(df - d0)  ! Calculate the new damage variable
      End If
      damage = MIN(damage, damage_max)  ! Cap damage variable
      damage = MAX(damage_old, damage)  ! Ensure no healing

#ifndef PYEXT
      ptr_fatigue_int = SMAIntArrayAccess(1)

      ! If this is a fatigue step, and static damage progression has not occurred, and the damage is not already fully developed...
      FatigueStep: If (fatigue_parameters(1) == 1 .AND. damage < damage_max) Then

        ptr_fatigue_dbl = SMARealArrayAccess(2)

        damage_static = damage

        R_old = damage_old*d0/((one - damage_old)*df + damage_old*d0)  ! Transform old damage to R form
        R_max = damage_max*d0/((one - damage_max)*df + damage_max*d0)  ! Transform damage_max to R form

        Call fatigue_coefficients(B, p%fatigue_R_ratio, fatigue_beta, fatigue_gamma)  ! Calculate fatigue damage model coefficients
        XLam = del/((one - R_old)*d0 + R_old*df)
        R_fatigue_inc = (R_old + fatigue_gamma)*XLam**fatigue_beta*cycles_per_increment(1)  ! Incremental fatigue damage
        R_fatigue_inc = MIN(R_fatigue_inc, R_max - R_old)
        R_fatigue = R_old + R_fatigue_inc  ! Updated fatigue damage variable

        ! Compare the current incremental fatigue growth to the upper and lower limit parameters
        If (R_fatigue_inc > p%fatigue_damage_max_threshold) Then
          fatigue_parameters(2) = MAX(fatigue_parameters(2), 2)
        Else If (R_fatigue_inc > p%fatigue_damage_min_threshold) Then
          fatigue_parameters(2) = MAX(fatigue_parameters(2), 1)
        End If

        damage = df*R_fatigue/(d0*(one - R_fatigue) + df*R_fatigue)  ! Transform R_fatigue to penalty stiffness form
        damage = MIN(damage, damage_max)  ! Cap the damage variable
        damage = MAX(damage_old, damage, damage_static)  ! Ensure no healing and use the greater of the static and fatigue damage

      End If FatigueStep
#endif

      ! If there is damage progression, calculate the normalized energy dissipation.
      If (damage > damage_old) dGdGc = damage/(df/d0*(one - damage) + damage) - damage_old/(df/d0*(one - damage_old) + damage_old)

    End If DamageEvolution

    Return
  End Subroutine cohesive_damage_propsListed

  Pure Function cohesive_traction(delta, penalty, damage) result(traction)
    ! Calculates the cohesive tractions from displacement, penalty stiffness, and damage.

    ! Arguments
    Double Precision, intent(IN) :: delta(3)    ! cohesive displacement-jump vector
    Double Precision, intent(IN) :: penalty(3)  ! cohesive penalty stiffness
    Double Precision, intent(IN) :: damage      ! cohesive damage variable
    Double Precision :: traction(3)

    ! Locals
    Double Precision, parameter :: zero=0.d0, one=1.d0
    ! -------------------------------------------------------------------- !
    traction(:) = penalty(:)*(one - damage)*delta(:)
    If (delta(2) < zero) traction(2) = penalty(2)*delta(2)  ! normal direction

    Return
  End Function cohesive_traction

  Subroutine fatigue_coefficients(mode_mixity, R_Load, Bet, Gam)
    ! Returns fatigue coefficients beta and gamma as a function of mode mixity and fatigue R ratio.
    ! See Dávila, C. G., "From S-N to the Paris Law with a New Mixed-Mode Cohesive Fatigue Model" NASA/TP-2018-219838 for details.

    Use forlog_Mod

    ! Arguments
    Double Precision, intent(IN) :: mode_mixity  ! mode mixity
    Double Precision, intent(IN) :: R_Load       ! stress ratio
    Double precision, intent(OUT) :: Bet, Gam

    ! Locals
    Double Precision :: RTable(50), BetTable(50), GamTable(50)
    Double Precision :: R_effective    ! effective stress ratio
    Double Precision :: interpolation  ! lookup table interpolation coefficient
    Logical :: iFound
    Double Precision, parameter :: one=1.d0, two=2.d0
    ! -------------------------------------------------------------------- !
    Do i = 1,50; RTable(i) = -1.50d0 + 0.05d0*(i-1); End Do

    BetTable(1)=	11.916971
    BetTable(2)=	12.058467
    BetTable(3)=	12.205484
    BetTable(4)=	12.358368
    BetTable(5)=	12.517489
    BetTable(6)=	12.683265
    BetTable(7)=	12.856132
    BetTable(8)=	13.036582
    BetTable(9)=	13.225149
    BetTable(10)=	13.422418
    BetTable(11)=	13.62903
    BetTable(12)=	13.845697
    BetTable(13)=	14.073205
    BetTable(14)=	14.312421
    BetTable(15)=	14.564311
    BetTable(16)=	14.829949
    BetTable(17)=	15.110542
    BetTable(18)=	15.407437
    BetTable(19)=	15.722153
    BetTable(20)=	16.056402
    BetTable(21)=	16.41213
    BetTable(22)=	16.79155
    BetTable(23)=	17.197189
    BetTable(24)=	17.63196
    BetTable(25)=	18.099216
    BetTable(26)=	18.602858
    BetTable(27)=	19.147438
    BetTable(28)=	19.738302
    BetTable(29)=	20.381792
    BetTable(30)=	21.085445
    BetTable(31)=	21.858343
    BetTable(32)=	22.711489
    BetTable(33)=	23.658363
    BetTable(34)=	24.71566
    BetTable(35)=	25.904301
    BetTable(36)=	27.250877
    BetTable(37)=	28.789688
    BetTable(38)=	30.565781
    BetTable(39)=	32.639507
    BetTable(40)=	35.093624
    BetTable(41)=	38.044724
    BetTable(42)=	41.662594
    BetTable(43)=	46.204231
    BetTable(44)=	52.07832
    BetTable(45)=	59.976353
    BetTable(46)=	71.167618
    BetTable(47)=	88.262215
    BetTable(48)=	117.610985
    BetTable(49)=	179.723572
    BetTable(50)=	397.755554

    GamTable(1)=	0.00186604
    GamTable(2)=	0.00186981
    GamTable(3)=	0.00187372
    GamTable(4)=	0.0018778
    GamTable(5)=	0.00188205
    GamTable(6)=	0.00188649
    GamTable(7)=	0.00189112
    GamTable(8)=	0.00189596
    GamTable(9)=	0.00190103
    GamTable(10)=	0.00190634
    GamTable(11)=	0.00191191
    GamTable(12)=	0.00191777
    GamTable(13)=	0.00192392
    GamTable(14)=	0.00193041
    GamTable(15)=	0.00193726
    GamTable(16)=	0.00194449
    GamTable(17)=	0.00195216
    GamTable(18)=	0.00196028
    GamTable(19)=	0.00196892
    GamTable(20)=	0.00197812
    GamTable(21)=	0.00198794
    GamTable(22)=	0.00199845
    GamTable(23)=	0.00200971
    GamTable(24)=	0.00202183
    GamTable(25)=	0.00203491
    GamTable(26)=	0.00204907
    GamTable(27)=	0.00206444
    GamTable(28)=	0.0020812
    GamTable(29)=	0.00209955
    GamTable(30)=	0.00211972
    GamTable(31)=	0.00214202
    GamTable(32)=	0.0021668
    GamTable(33)=	0.00219451
    GamTable(34)=	0.00222572
    GamTable(35)=	0.00226112
    GamTable(36)=	0.00230166
    GamTable(37)=	0.00234853
    GamTable(38)=	0.00240337
    GamTable(39)=	0.00246841
    GamTable(40)=	0.0025468
    GamTable(41)=	0.00264314
    GamTable(42)=	0.00276437
    GamTable(43)=	0.00292155
    GamTable(44)=	0.0031333
    GamTable(45)=	0.0034336
    GamTable(46)=	0.00389128
    GamTable(47)=	0.00466899
    GamTable(48)=	0.00625619
    GamTable(49)=	0.01098453
    GamTable(50)=	0.06479965

    R_effective = (R_Load - two)/(one - mode_mixity*0.42d0) + two  ! Eq. 25 from NASA/TP-2018-219838

    iFound = .FALSE.
    Lookup: Do i=2,50
      If (R_effective > RTable(i-1) .AND. R_effective <= RTable(i)) Then
        interpolation = (R_effective - RTable(i-1))/(RTable(i) - RTable(i-1))
        Bet = BetTable(i-1) + interpolation*(BetTable(i) - BetTable(i-1))
        Gam = GamTable(i-1) + interpolation*(GamTable(i) - GamTable(i-1))
        iFound = .TRUE.
        Exit Lookup
      End If
    End Do Lookup
    If (.NOT. iFound) Then
      Call log%error("Fatigue coefficients not found. Mode mix:" // trim(str(mode_mixity)) // "R ratio:" // trim(str(R_Load)))
    End If

    Return
  End Subroutine fatigue_coefficients

End Module cohesive_mod


MODULE icevar
  USE dom_oce
  USE phycst
  USE sbc_oce, ONLY: sss_m
  USE ice
  USE ice1D
  USE in_out_manager
  USE lib_mpp
  USE lib_fortran
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: ice_var_agg
  PUBLIC :: ice_var_glo2eqv
  PUBLIC :: ice_var_eqv2glo
  PUBLIC :: ice_var_salprof
  PUBLIC :: ice_var_salprof1d
  PUBLIC :: ice_var_zapsmall
  PUBLIC :: ice_var_zapneg
  PUBLIC :: ice_var_itd
  PUBLIC :: ice_var_itd2
  PUBLIC :: ice_var_bv
  PUBLIC :: ice_var_enthalpy
  CONTAINS
  SUBROUTINE ice_var_agg(kn)
    INTEGER, INTENT( IN ) :: kn
    INTEGER :: ji, jj, jk, jl
    REAL(KIND = wp), ALLOCATABLE, DIMENSION(:, :) :: z1_at_i, z1_vt_i, z1_vt_s
    vt_i(:, :) = SUM(v_i(:, :, :), dim = 3)
    vt_s(:, :) = SUM(v_s(:, :, :), dim = 3)
    at_i(:, :) = SUM(a_i(:, :, :), dim = 3)
    et_s(:, :) = SUM(SUM(e_s(:, :, :, :), dim = 4), dim = 3)
    et_i(:, :) = SUM(SUM(e_i(:, :, :, :), dim = 4), dim = 3)
    at_ip(:, :) = SUM(a_ip(:, :, :), dim = 3)
    vt_ip(:, :) = SUM(v_ip(:, :, :), dim = 3)
    !$ACC KERNELS
    ato_i(:, :) = 1._wp - at_i(:, :)
    !$ACC END KERNELS
    IF (kn > 1) THEN
      ALLOCATE(z1_at_i(jpi, jpj), z1_vt_i(jpi, jpj), z1_vt_s(jpi, jpj))
      WHERE (at_i(:, :) > epsi20)
        z1_at_i(:, :) = 1._wp / at_i(:, :)
      ELSEWHERE
        z1_at_i(:, :) = 0._wp
      END WHERE
      WHERE (vt_i(:, :) > epsi20)
        z1_vt_i(:, :) = 1._wp / vt_i(:, :)
      ELSEWHERE
        z1_vt_i(:, :) = 0._wp
      END WHERE
      WHERE (vt_s(:, :) > epsi20)
        z1_vt_s(:, :) = 1._wp / vt_s(:, :)
      ELSEWHERE
        z1_vt_s(:, :) = 0._wp
      END WHERE
      !$ACC KERNELS
      hm_i(:, :) = vt_i(:, :) * z1_at_i(:, :)
      hm_s(:, :) = vt_s(:, :) * z1_at_i(:, :)
      !$ACC END KERNELS
      tm_su(:, :) = SUM(t_su(:, :, :) * a_i(:, :, :), dim = 3) * z1_at_i(:, :)
      tm_si(:, :) = SUM(t_si(:, :, :) * a_i(:, :, :), dim = 3) * z1_at_i(:, :)
      om_i(:, :) = SUM(oa_i(:, :, :), dim = 3) * z1_at_i(:, :)
      sm_i(:, :) = SUM(sv_i(:, :, :), dim = 3) * z1_vt_i(:, :)
      !$ACC KERNELS
      tm_i(:, :) = 0._wp
      tm_s(:, :) = 0._wp
      DO jl = 1, jpl
        DO jk = 1, nlay_i
          tm_i(:, :) = tm_i(:, :) + r1_nlay_i * t_i(:, :, jk, jl) * v_i(:, :, jl) * z1_vt_i(:, :)
        END DO
        DO jk = 1, nlay_s
          tm_s(:, :) = tm_s(:, :) + r1_nlay_s * t_s(:, :, jk, jl) * v_s(:, :, jl) * z1_vt_s(:, :)
        END DO
      END DO
      !$ACC END KERNELS
      WHERE (at_i(:, :) <= epsi20)
        tm_su(:, :) = rt0
        tm_si(:, :) = rt0
        tm_i(:, :) = rt0
        tm_s(:, :) = rt0
      END WHERE
      DEALLOCATE(z1_at_i, z1_vt_i, z1_vt_s)
    END IF
  END SUBROUTINE ice_var_agg
  SUBROUTINE ice_var_glo2eqv
    INTEGER :: ji, jj, jk, jl
    REAL(KIND = wp) :: ze_i
    REAL(KIND = wp) :: ze_s, ztmelts, zbbb, zccc
    REAL(KIND = wp) :: zhmax, z1_zhmax
    REAL(KIND = wp) :: zlay_i, zlay_s
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpl) :: z1_a_i, z1_v_i
    WHERE (a_i(:, :, :) > epsi20)
      z1_a_i(:, :, :) = 1._wp / a_i(:, :, :)
    ELSEWHERE
      z1_a_i(:, :, :) = 0._wp
    END WHERE
    WHERE (v_i(:, :, :) > epsi20)
      z1_v_i(:, :, :) = 1._wp / v_i(:, :, :)
    ELSEWHERE
      z1_v_i(:, :, :) = 0._wp
    END WHERE
    !$ACC KERNELS
    h_i(:, :, :) = v_i(:, :, :) * z1_a_i(:, :, :)
    zhmax = hi_max(jpl)
    z1_zhmax = 1._wp / hi_max(jpl)
    !$ACC END KERNELS
    WHERE (h_i(:, :, jpl) > zhmax)
      h_i(:, :, jpl) = zhmax
      a_i(:, :, jpl) = v_i(:, :, jpl) * z1_zhmax
      z1_a_i(:, :, jpl) = zhmax * z1_v_i(:, :, jpl)
    END WHERE
    !$ACC KERNELS
    h_s(:, :, :) = v_s(:, :, :) * z1_a_i(:, :, :)
    o_i(:, :, :) = oa_i(:, :, :) * z1_a_i(:, :, :)
    a_ip_frac(:, :, :) = a_ip(:, :, :) * z1_a_i(:, :, :)
    !$ACC END KERNELS
    WHERE (a_ip_frac(:, :, :) > epsi20)
      h_ip(:, :, :) = v_ip(:, :, :) * z1_a_i(:, :, :) / a_ip_frac(:, :, :)
    ELSEWHERE
      h_ip(:, :, :) = 0._wp
    END WHERE
    IF (nn_icesal == 2) THEN
      WHERE (v_i(:, :, :) > epsi20)
        s_i(:, :, :) = MAX(rn_simin, MIN(rn_simax, sv_i(:, :, :) * z1_v_i(:, :, :)))
      ELSEWHERE
        s_i(:, :, :) = rn_simin
      END WHERE
    END IF
    CALL ice_var_salprof
    zlay_i = REAL(nlay_i, wp)
    !$ACC KERNELS
    DO jl = 1, jpl
      DO jk = 1, nlay_i
        DO jj = 1, jpj
          DO ji = 1, jpi
            IF (v_i(ji, jj, jl) > epsi20) THEN
              ze_i = e_i(ji, jj, jk, jl) * z1_v_i(ji, jj, jl) * zlay_i
              ztmelts = - sz_i(ji, jj, jk, jl) * rTmlt
              zbbb = (rcp - rcpi) * ztmelts + ze_i * r1_rhoi - rLfus
              zccc = SQRT(MAX(zbbb * zbbb - 4._wp * rcpi * rLfus * ztmelts, 0._wp))
              t_i(ji, jj, jk, jl) = MAX(- 100._wp, MIN(- (zbbb + zccc) * 0.5_wp * r1_rcpi, ztmelts)) + rt0
            ELSE
              t_i(ji, jj, jk, jl) = rt0
            END IF
          END DO
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    zlay_s = REAL(nlay_s, wp)
    DO jk = 1, nlay_s
      WHERE (v_s(:, :, :) > epsi20)
        t_s(:, :, jk, :) = rt0 + MAX(- 100._wp, MIN(r1_rcpi * (- r1_rhos * (e_s(:, :, jk, :) / v_s(:, :, :) * zlay_s) + rLfus), 0._wp))
      ELSEWHERE
        t_s(:, :, jk, :) = rt0
      END WHERE
    END DO
    vt_i(:, :) = SUM(v_i, dim = 3)
    vt_s(:, :) = SUM(v_s, dim = 3)
    at_i(:, :) = SUM(a_i, dim = 3)
  END SUBROUTINE ice_var_glo2eqv
  SUBROUTINE ice_var_eqv2glo
    !$ACC KERNELS
    v_i(:, :, :) = h_i(:, :, :) * a_i(:, :, :)
    v_s(:, :, :) = h_s(:, :, :) * a_i(:, :, :)
    sv_i(:, :, :) = s_i(:, :, :) * v_i(:, :, :)
    v_ip(:, :, :) = h_ip(:, :, :) * a_ip(:, :, :)
    !$ACC END KERNELS
  END SUBROUTINE ice_var_eqv2glo
  SUBROUTINE ice_var_salprof
    INTEGER :: ji, jj, jk, jl
    REAL(KIND = wp) :: zsal, z1_dS
    REAL(KIND = wp) :: zargtemp, zs0, zs
    REAL(KIND = wp), ALLOCATABLE, DIMENSION(:, :, :) :: z_slope_s, zalpha
    REAL(KIND = wp), PARAMETER :: zsi0 = 3.5_wp
    REAL(KIND = wp), PARAMETER :: zsi1 = 4.5_wp
    SELECT CASE (nn_icesal)
    CASE (1)
      !$ACC KERNELS
      sz_i(:, :, :, :) = rn_icesal
      s_i(:, :, :) = rn_icesal
      !$ACC END KERNELS
    CASE (2)
      ALLOCATE(z_slope_s(jpi, jpj, jpl), zalpha(jpi, jpj, jpl))
      !$ACC KERNELS
      DO jl = 1, jpl
        DO jk = 1, nlay_i
          sz_i(:, :, jk, jl) = s_i(:, :, jl)
        END DO
      END DO
      !$ACC END KERNELS
      WHERE (h_i(:, :, :) > epsi20)
        z_slope_s(:, :, :) = 2._wp * s_i(:, :, :) / h_i(:, :, :)
      ELSEWHERE
        z_slope_s(:, :, :) = 0._wp
      END WHERE
      !$ACC KERNELS
      z1_dS = 1._wp / (zsi1 - zsi0)
      DO jl = 1, jpl
        DO jj = 1, jpj
          DO ji = 1, jpi
            zalpha(ji, jj, jl) = MAX(0._wp, MIN((zsi1 - s_i(ji, jj, jl)) * z1_dS, 1._wp))
            IF (2._wp * s_i(ji, jj, jl) >= sss_m(ji, jj)) zalpha(ji, jj, jl) = 0._wp
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      DO jl = 1, jpl
        DO jk = 1, nlay_i
          DO jj = 1, jpj
            DO ji = 1, jpi
              zs0 = z_slope_s(ji, jj, jl) * (REAL(jk, wp) - 0.5_wp) * h_i(ji, jj, jl) * r1_nlay_i
              zs = zalpha(ji, jj, jl) * zs0 + (1._wp - zalpha(ji, jj, jl)) * s_i(ji, jj, jl)
              sz_i(ji, jj, jk, jl) = MIN(rn_simax, MAX(zs, rn_simin))
            END DO
          END DO
        END DO
      END DO
      DEALLOCATE(z_slope_s, zalpha)
    CASE (3)
      !$ACC KERNELS
      s_i(:, :, :) = 2.30_wp
      !$ACC END KERNELS
      DO jl = 1, jpl
        DO jk = 1, nlay_i
          zargtemp = (REAL(jk, wp) - 0.5_wp) * r1_nlay_i
          !$ACC KERNELS
          sz_i(:, :, jk, jl) = 1.6_wp * (1._wp - COS(rpi * zargtemp ** (0.407_wp / (0.573_wp + zargtemp))))
          !$ACC END KERNELS
        END DO
      END DO
    END SELECT
  END SUBROUTINE ice_var_salprof
  SUBROUTINE ice_var_salprof1d
    INTEGER :: ji, jk
    REAL(KIND = wp) :: zargtemp, zsal, z1_dS
    REAL(KIND = wp) :: zs, zs0
    REAL(KIND = wp), ALLOCATABLE, DIMENSION(:) :: z_slope_s, zalpha
    REAL(KIND = wp), PARAMETER :: zsi0 = 3.5_wp
    REAL(KIND = wp), PARAMETER :: zsi1 = 4.5_wp
    SELECT CASE (nn_icesal)
    CASE (1)
      !$ACC KERNELS
      sz_i_1d(1 : npti, :) = rn_icesal
      !$ACC END KERNELS
    CASE (2)
      ALLOCATE(z_slope_s(jpij), zalpha(jpij))
      WHERE (h_i_1d(1 : npti) > epsi20)
        z_slope_s(1 : npti) = 2._wp * s_i_1d(1 : npti) / h_i_1d(1 : npti)
      ELSEWHERE
        z_slope_s(1 : npti) = 0._wp
      END WHERE
      !$ACC KERNELS
      z1_dS = 1._wp / (zsi1 - zsi0)
      DO ji = 1, npti
        zalpha(ji) = MAX(0._wp, MIN((zsi1 - s_i_1d(ji)) * z1_dS, 1._wp))
        IF (2._wp * s_i_1d(ji) >= sss_1d(ji)) zalpha(ji) = 0._wp
      END DO
      !$ACC END KERNELS
      DO jk = 1, nlay_i
        DO ji = 1, npti
          zs0 = z_slope_s(ji) * (REAL(jk, wp) - 0.5_wp) * h_i_1d(ji) * r1_nlay_i
          zs = zalpha(ji) * zs0 + (1._wp - zalpha(ji)) * s_i_1d(ji)
          sz_i_1d(ji, jk) = MIN(rn_simax, MAX(zs, rn_simin))
        END DO
      END DO
      DEALLOCATE(z_slope_s, zalpha)
    CASE (3)
      s_i_1d(1 : npti) = 2.30_wp
      DO jk = 1, nlay_i
        zargtemp = (REAL(jk, wp) - 0.5_wp) * r1_nlay_i
        !$ACC KERNELS
        zsal = 1.6_wp * (1._wp - COS(rpi * zargtemp ** (0.407_wp / (0.573_wp + zargtemp))))
        DO ji = 1, npti
          sz_i_1d(ji, jk) = zsal
        END DO
        !$ACC END KERNELS
      END DO
    END SELECT
  END SUBROUTINE ice_var_salprof1d
  SUBROUTINE ice_var_zapsmall
    INTEGER :: ji, jj, jl, jk
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zswitch
    DO jl = 1, jpl
      WHERE (a_i(:, :, jl) > epsi10)
        h_i(:, :, jl) = v_i(:, :, jl) / a_i(:, :, jl)
      ELSEWHERE
        h_i(:, :, jl) = 0._wp
      END WHERE
      WHERE (a_i(:, :, jl) < epsi10 .OR. v_i(:, :, jl) < epsi10 .OR. h_i(:, :, jl) < epsi10)
        zswitch(:, :) = 0._wp
      ELSEWHERE
        zswitch(:, :) = 1._wp
      END WHERE
      !$ACC KERNELS
      DO jk = 1, nlay_i
        DO jj = 1, jpj
          DO ji = 1, jpi
            hfx_res(ji, jj) = hfx_res(ji, jj) - (1._wp - zswitch(ji, jj)) * e_i(ji, jj, jk, jl) * r1_rdtice
            e_i(ji, jj, jk, jl) = e_i(ji, jj, jk, jl) * zswitch(ji, jj)
            t_i(ji, jj, jk, jl) = t_i(ji, jj, jk, jl) * zswitch(ji, jj) + rt0 * (1._wp - zswitch(ji, jj))
          END DO
        END DO
      END DO
      DO jk = 1, nlay_s
        DO jj = 1, jpj
          DO ji = 1, jpi
            hfx_res(ji, jj) = hfx_res(ji, jj) - (1._wp - zswitch(ji, jj)) * e_s(ji, jj, jk, jl) * r1_rdtice
            e_s(ji, jj, jk, jl) = e_s(ji, jj, jk, jl) * zswitch(ji, jj)
            t_s(ji, jj, jk, jl) = t_s(ji, jj, jk, jl) * zswitch(ji, jj) + rt0 * (1._wp - zswitch(ji, jj))
          END DO
        END DO
      END DO
      DO jj = 1, jpj
        DO ji = 1, jpi
          sfx_res(ji, jj) = sfx_res(ji, jj) + (1._wp - zswitch(ji, jj)) * sv_i(ji, jj, jl) * rhoi * r1_rdtice
          wfx_res(ji, jj) = wfx_res(ji, jj) + (1._wp - zswitch(ji, jj)) * v_i(ji, jj, jl) * rhoi * r1_rdtice
          wfx_res(ji, jj) = wfx_res(ji, jj) + (1._wp - zswitch(ji, jj)) * v_s(ji, jj, jl) * rhos * r1_rdtice
          a_i(ji, jj, jl) = a_i(ji, jj, jl) * zswitch(ji, jj)
          v_i(ji, jj, jl) = v_i(ji, jj, jl) * zswitch(ji, jj)
          v_s(ji, jj, jl) = v_s(ji, jj, jl) * zswitch(ji, jj)
          t_su(ji, jj, jl) = t_su(ji, jj, jl) * zswitch(ji, jj) + t_bo(ji, jj) * (1._wp - zswitch(ji, jj))
          oa_i(ji, jj, jl) = oa_i(ji, jj, jl) * zswitch(ji, jj)
          sv_i(ji, jj, jl) = sv_i(ji, jj, jl) * zswitch(ji, jj)
          h_i(ji, jj, jl) = h_i(ji, jj, jl) * zswitch(ji, jj)
          h_s(ji, jj, jl) = h_s(ji, jj, jl) * zswitch(ji, jj)
          a_ip(ji, jj, jl) = a_ip(ji, jj, jl) * zswitch(ji, jj)
          v_ip(ji, jj, jl) = v_ip(ji, jj, jl) * zswitch(ji, jj)
        END DO
      END DO
      !$ACC END KERNELS
    END DO
    at_i(:, :) = SUM(a_i(:, :, :), dim = 3)
    vt_i(:, :) = SUM(v_i(:, :, :), dim = 3)
    WHERE (at_i(:, :) == 0._wp) ato_i(:, :) = 1._wp
  END SUBROUTINE ice_var_zapsmall
  SUBROUTINE ice_var_zapneg(pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pe_s, pe_i)
    INTEGER :: ji, jj, jl, jk
    REAL(KIND = wp), DIMENSION(:, :), INTENT(INOUT) :: pato_i
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: pv_i
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: pv_s
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: psv_i
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: poa_i
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: pa_i
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: pa_ip
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: pv_ip
    REAL(KIND = wp), DIMENSION(:, :, :, :), INTENT(INOUT) :: pe_s
    REAL(KIND = wp), DIMENSION(:, :, :, :), INTENT(INOUT) :: pe_i
    WHERE (pato_i(:, :) < 0._wp) pato_i(:, :) = 0._wp
    WHERE (poa_i(:, :, :) < 0._wp) poa_i(:, :, :) = 0._wp
    WHERE (pa_i(:, :, :) < 0._wp) pa_i(:, :, :) = 0._wp
    WHERE (pa_ip(:, :, :) < 0._wp) pa_ip(:, :, :) = 0._wp
    WHERE (pv_ip(:, :, :) < 0._wp) pv_ip(:, :, :) = 0._wp
    !$ACC KERNELS
    DO jl = 1, jpl
      DO jk = 1, nlay_i
        DO jj = 1, jpj
          DO ji = 1, jpi
            IF (pe_i(ji, jj, jk, jl) < 0._wp) THEN
              hfx_res(ji, jj) = hfx_res(ji, jj) - pe_i(ji, jj, jk, jl) * r1_rdtice
              pe_i(ji, jj, jk, jl) = 0._wp
            END IF
          END DO
        END DO
      END DO
      DO jk = 1, nlay_s
        DO jj = 1, jpj
          DO ji = 1, jpi
            IF (pe_s(ji, jj, jk, jl) < 0._wp) THEN
              hfx_res(ji, jj) = hfx_res(ji, jj) - pe_s(ji, jj, jk, jl) * r1_rdtice
              pe_s(ji, jj, jk, jl) = 0._wp
            END IF
          END DO
        END DO
      END DO
      DO jj = 1, jpj
        DO ji = 1, jpi
          IF (pv_i(ji, jj, jl) < 0._wp) THEN
            wfx_res(ji, jj) = wfx_res(ji, jj) + pv_i(ji, jj, jl) * rhoi * r1_rdtice
            pv_i(ji, jj, jl) = 0._wp
          END IF
          IF (pv_s(ji, jj, jl) < 0._wp) THEN
            wfx_res(ji, jj) = wfx_res(ji, jj) + pv_s(ji, jj, jl) * rhos * r1_rdtice
            pv_s(ji, jj, jl) = 0._wp
          END IF
          IF (psv_i(ji, jj, jl) < 0._wp) THEN
            sfx_res(ji, jj) = sfx_res(ji, jj) + psv_i(ji, jj, jl) * rhoi * r1_rdtice
            psv_i(ji, jj, jl) = 0._wp
          END IF
        END DO
      END DO
    END DO
    !$ACC END KERNELS
  END SUBROUTINE ice_var_zapneg
  SUBROUTINE ice_var_itd(zhti, zhts, zati, zh_i, zh_s, za_i)
    INTEGER :: ji, jk, jl
    INTEGER :: idim, i_fill, jl0
    REAL(KIND = wp) :: zarg, zV, zconv, zdh, zdv
    REAL(KIND = wp), DIMENSION(:), INTENT(IN) :: zhti, zhts, zati
    REAL(KIND = wp), DIMENSION(:, :), INTENT(INOUT) :: zh_i, zh_s, za_i
    INTEGER, DIMENSION(4) :: itest
    idim = SIZE(zhti, 1)
    !$ACC KERNELS
    zh_i(1 : idim, 1 : jpl) = 0._wp
    zh_s(1 : idim, 1 : jpl) = 0._wp
    za_i(1 : idim, 1 : jpl) = 0._wp
    !$ACC END KERNELS
    DO ji = 1, idim
      IF (zhti(ji) > 0._wp) THEN
        jl0 = jpl
        DO jl = 1, jpl
          IF ((zhti(ji) >= hi_max(jl - 1)) .AND. (zhti(ji) < hi_max(jl))) THEN
            jl0 = jl
            CYCLE
          END IF
        END DO
        itest(:) = 0
        i_fill = jpl + 1
        DO WHILE ((SUM(itest(:)) /= 4) .AND. (i_fill >= 2))
          i_fill = i_fill - 1
          zh_i(ji, 1 : jpl) = 0._wp
          za_i(ji, 1 : jpl) = 0._wp
          itest(:) = 0
          IF (i_fill == 1) THEN
            zh_i(ji, 1) = zhti(ji)
            za_i(ji, 1) = zati(ji)
          ELSE
            DO jl = 1, i_fill - 1
              zh_i(ji, jl) = hi_mean(jl)
            END DO
            za_i(ji, jl0) = zati(ji) / SQRT(REAL(jpl))
            DO jl = 1, i_fill - 1
              IF (jl /= jl0) THEN
                zarg = (zh_i(ji, jl) - zhti(ji)) / (zhti(ji) * 0.5_wp)
                za_i(ji, jl) = za_i(ji, jl0) * EXP(- zarg ** 2)
              END IF
            END DO
            za_i(ji, i_fill) = zati(ji) - SUM(za_i(ji, 1 : i_fill - 1))
            zV = SUM(za_i(ji, 1 : i_fill - 1) * zh_i(ji, 1 : i_fill - 1))
            zh_i(ji, i_fill) = (zhti(ji) * zati(ji) - zV) / MAX(za_i(ji, i_fill), epsi10)
            IF (jl0 /= jpl) THEN
              DO jl = jpl, jl0 + 1, - 1
                IF (za_i(ji, jl) > za_i(ji, jl - 1)) THEN
                  zdv = zh_i(ji, jl) * za_i(ji, jl)
                  zh_i(ji, jl) = 0._wp
                  za_i(ji, jl) = 0._wp
                  za_i(ji, 1 : jl - 1) = za_i(ji, 1 : jl - 1) + zdv / MAX(REAL(jl - 1) * zhti(ji), epsi10)
                END IF
              END DO
            END IF
          END IF
          zconv = ABS(zati(ji) - SUM(za_i(ji, 1 : jpl)))
          IF (zconv < epsi06) itest(1) = 1
          zconv = ABS(zhti(ji) * zati(ji) - SUM(za_i(ji, 1 : jpl) * zh_i(ji, 1 : jpl)))
          IF (zconv < epsi06) itest(2) = 1
          IF (zh_i(ji, i_fill) >= hi_max(i_fill - 1)) itest(3) = 1
          itest(4) = 1
          DO jl = 1, i_fill
            IF (za_i(ji, jl) < 0._wp) itest(4) = 0
          END DO
        END DO
      END IF
    END DO
    !$ACC KERNELS
    DO jl = 1, jpl
      DO ji = 1, idim
        IF (za_i(ji, jl) > 0._wp) THEN
          zh_s(ji, jl) = zh_i(ji, jl) * (zhts(ji) / zhti(ji))
          zdh = MAX(0._wp, (rhos * zh_s(ji, jl) + (rhoi - rau0) * zh_i(ji, jl)) * r1_rau0)
          zh_i(ji, jl) = MIN(hi_max(jl), zh_i(ji, jl) + zdh)
          zh_s(ji, jl) = MAX(0._wp, zh_s(ji, jl) - zdh * rhoi * r1_rhos)
        END IF
      END DO
    END DO
    !$ACC END KERNELS
  END SUBROUTINE ice_var_itd
  SUBROUTINE ice_var_itd2(zhti, zhts, zati, zh_i, zh_s, za_i)
    INTEGER :: ji, jl, jl1, jl2
    INTEGER :: idim, icat
    INTEGER, PARAMETER :: ztrans = 0.25_wp
    REAL(KIND = wp), DIMENSION(:, :), INTENT(IN) :: zhti, zhts, zati
    REAL(KIND = wp), DIMENSION(:, :), INTENT(INOUT) :: zh_i, zh_s, za_i
    INTEGER, DIMENSION(:, :), ALLOCATABLE :: jlfil, jlfil2
    INTEGER, DIMENSION(:), ALLOCATABLE :: jlmax, jlmin
    idim = SIZE(zhti, 1)
    icat = SIZE(zhti, 2)
    ALLOCATE(jlfil(idim, jpl), jlfil2(idim, jpl))
    ALLOCATE(jlmin(idim), jlmax(idim))
    !$ACC KERNELS
    zh_i(1 : idim, 1 : jpl) = 0._wp
    zh_s(1 : idim, 1 : jpl) = 0._wp
    za_i(1 : idim, 1 : jpl) = 0._wp
    !$ACC END KERNELS
    jlmax(:) = 0
    jlmin(:) = 999
    !$ACC KERNELS
    jlfil(:, :) = 0
    DO jl1 = 1, jpl
      DO jl2 = 1, icat
        DO ji = 1, idim
          IF (hi_max(jl1 - 1) <= zhti(ji, jl2) .AND. hi_max(jl1) > zhti(ji, jl2)) THEN
            zh_i(ji, jl1) = zhti(ji, jl2)
            zh_s(ji, jl1) = zhts(ji, jl2)
            za_i(ji, jl1) = zati(ji, jl2)
            jlmax(ji) = MAX(jlmax(ji), jl1)
            jlmin(ji) = MIN(jlmin(ji), jl1)
            jlfil(ji, jl1) = jl1
          END IF
        END DO
      END DO
    END DO
    DO ji = 1, idim
      jl1 = jlmin(ji)
      jl2 = jlmax(ji)
      IF (jl1 > 1) THEN
        za_i(ji, jl1 - 1) = ztrans * za_i(ji, jl1)
        zh_i(ji, jl1 - 1) = hi_mean(jl1 - 1)
        za_i(ji, jl1) = (1._wp - ztrans) * za_i(ji, jl1)
      END IF
      IF (jl2 < jpl) THEN
        za_i(ji, jl2 + 1) = ztrans * za_i(ji, jl2)
        zh_i(ji, jl2 + 1) = hi_mean(jl2 + 1)
        za_i(ji, jl2) = (1._wp - ztrans) * za_i(ji, jl2)
      END IF
    END DO
    jlfil2(:, :) = jlfil(:, :)
    DO jl = 2, jpl - 1
      DO ji = 1, idim
        IF (jlfil(ji, jl - 1) /= 0 .AND. jlfil(ji, jl) == 0) THEN
          za_i(ji, jl) = ztrans * za_i(ji, jl - 1)
          zh_i(ji, jl) = hi_mean(jl)
          jlfil(ji, jl) = jl
          za_i(ji, jl - 1) = (1._wp - ztrans) * za_i(ji, jl - 1)
        END IF
      END DO
    END DO
    DO jl = jpl - 1, 2, - 1
      DO ji = 1, idim
        IF (jlfil2(ji, jl + 1) /= 0 .AND. jlfil2(ji, jl) == 0) THEN
          za_i(ji, jl) = za_i(ji, jl) + ztrans * za_i(ji, jl + 1)
          zh_i(ji, jl) = hi_mean(jl)
          jlfil2(ji, jl) = jl
          za_i(ji, jl + 1) = (1._wp - ztrans) * za_i(ji, jl + 1)
        END IF
      END DO
    END DO
    !$ACC END KERNELS
    DEALLOCATE(jlfil, jlfil2)
    DEALLOCATE(jlmin, jlmax)
  END SUBROUTINE ice_var_itd2
  SUBROUTINE ice_var_bv
    INTEGER :: ji, jj, jk, jl
    !$ACC KERNELS
    bv_i(:, :, :) = 0._wp
    !$ACC END KERNELS
    DO jl = 1, jpl
      DO jk = 1, nlay_i
        WHERE (t_i(:, :, jk, jl) < rt0 - epsi10)
          bv_i(:, :, jl) = bv_i(:, :, jl) - rTmlt * sz_i(:, :, jk, jl) * r1_nlay_i / (t_i(:, :, jk, jl) - rt0)
        END WHERE
      END DO
    END DO
    WHERE (vt_i(:, :) > epsi20)
      bvm_i(:, :) = SUM(bv_i(:, :, :) * v_i(:, :, :), dim = 3) / vt_i(:, :)
    ELSEWHERE
      bvm_i(:, :) = 0._wp
    END WHERE
  END SUBROUTINE ice_var_bv
  SUBROUTINE ice_var_enthalpy
    INTEGER :: ji, jk
    REAL(KIND = wp) :: ztmelts
    !$ACC KERNELS
    DO jk = 1, nlay_i
      DO ji = 1, npti
        ztmelts = - rTmlt * sz_i_1d(ji, jk)
        t_i_1d(ji, jk) = MIN(t_i_1d(ji, jk), ztmelts + rt0)
        e_i_1d(ji, jk) = rhoi * (rcpi * (ztmelts - (t_i_1d(ji, jk) - rt0)) + rLfus * (1._wp - ztmelts / (t_i_1d(ji, jk) - rt0)) - rcp * ztmelts)
      END DO
    END DO
    DO jk = 1, nlay_s
      DO ji = 1, npti
        e_s_1d(ji, jk) = rhos * (rcpi * (rt0 - t_s_1d(ji, jk)) + rLfus)
      END DO
    END DO
    !$ACC END KERNELS
  END SUBROUTINE ice_var_enthalpy
END MODULE icevar


	INCLUDE 'VICMAIN_FOR'
	SUBROUTINE MAIN44
C
	INTEGER IBUF(1926)
	LOGICAL*1 BUF(7704)
	EQUIVALENCE (BUF,IBUF)
	CHARACTER*4 IBUFTST
C								open input
	CALL XVUNIT(INUNIT,'INP',1,ISTAT,' ')
	CALL XVOPEN(INUNIT,ISTAT,'OPEN_ACT','SA','IO_ACT','SA',' ')
	CALL XVGET(INUNIT,ISTAT,'NL',NLIN,'NS',NSIN,' ')
C
	DO I=1,NLIN
	    CALL XVREAD(INUNIT,BUF,ISTAT,' ')
	    CALL CEBCDC(BUF,4)
	    CALL MVLC(IBUF(1), IBUFTST, 4)
	    IF (IBUFTST .EQ. 'DIR ') THEN
		CALL READ_DIR(IBUF(7),NL,NS,NB,NBPP,ISKIP,IOUTUNIT)
	    ELSE IF (IBUFTST .EQ. 'WORD') THEN
		CALL READ_DATA(IBUF(7),IBUF(7),IBUF(7),NL,NS,NB,NBPP,
     +			       ISKIP,IOUTUNIT)
	    END IF
	END DO
	RETURN
	END
C***********************************************************************
	SUBROUTINE READ_DIR(IBUF,NL,NS,NB,NBPP,ISKIP,IOUTUNIT)
C
	INTEGER IBUF(64),NCHAN(32)
	INTEGER ID(96)/  1, 3, 2, 3, 4, 5, 6, 7, 8, 3,
     +			 3, 3, 9,10,11,12,13,14,15,16,
     +			17,18,19,20,21,22,23,24,25,26,
     +			27,28,29,30, 3, 3,31,31,31,31,
     +			31,32,33,34,35,36,37,37,37,37,
     +			37,38,38,38,38,38, 3, 3, 3, 3,
     +			 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
     +			 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
     +			39, 3, 3, 3, 3, 3, 3, 3, 3, 3,
     +			 3, 3, 3, 3, 3,40/
	CHARACTER*18 SENSOR(40)/
     +	'Non-Image Derived ','Graphics          ','Miscellaneous     ',
     +	'Meteosat Visible  ','Meteosat Infrared ','Meteosat Water Vap',
     +  'Radar             ','Misc Aircraft-MAMS','GMS Visible       ',
     +  'GMS Infrared      ','ATS 6 Visible     ','ATS 6 Infrared    ',
     +  'SMS-1 Visible     ','SMS-1 Infrared    ','SMS-2 Visible     ',
     +  'SMS-2 Infrared    ','GOES-1 Visible    ','GOES-1 Infrared   ',
     +  'GOES-2 Visible    ','GOES-2 Infrared   ','GOES-3 Visible    ',
     +  'GOES-3 Infrared   ','GOES-4 Visible VAS','GOES-4 IR & Wv VAS',
     +  'GOES-5 Visible    ','GOES-5 IR & Wv VAS','GOES-6 Visible    ',
     +  'GOES-6 Infrared   ','GOES-7 Visible    ','GOES-7 Infrared   ',
     +  'NOAA Series Sat   ','TIROS-N           ','NOAA-6            ',
     +  'NOAA-7            ','NOAA-8            ','NIMBUS Satellites ',
     +	'Mariner X Sats    ','Digitized Radar   ','ERBE              ',
     +  'NOAA-9            '/
	CHARACTER*80 PRT
	CHARACTER*21 DATESTR
	CHARACTER*4 FORMAT(4)/'BYTE','HALF','XXXX','FULL'/
	CHARACTER*3 ORG
C						decode data from IBM format
	IDNUM = IBUF(3)
	NL    = IBUF(9)
	NS    = IBUF(10)
	NBPP  = IBUF(11)
	LINC  = IBUF(12)
	ISINC = IBUF(13)
	NB    = IBUF(14)
	ISKIP = IBUF(15)
	ICHAN = IBUF(19)
	JDATE = IBUF(46)
	JTIME = IBUF(47)
	CALL CEBCDC(IBUF(52),8)
C							     open output dataset
	IF (NB.EQ.1) THEN
	    ORG = 'BSQ'
	ELSE
	    ORG = 'BIP'
	END IF
	CALL XVUNIT(IOUTUNIT,'OUT',1,ISTAT,' ')
	CALL XVOPEN(IOUTUNIT,ISTAT,'U_NL',NL,'U_NS',NS,'U_NB',NB,
     +		'U_ORG',ORG,'OP','WRITE','OPEN_ACT','SA','IO_ACT','SA',
     +		'O_FORMAT',FORMAT(NBPP),'U_FORMAT',FORMAT(NBPP),' ')
C							 put sensor name, date,
C							 and time in VICAR label
	CALL XLADD(IOUTUNIT,'HISTORY','SENSOR',SENSOR(ID(IDNUM)+1),
     +		   ISTAT,'FORMAT','STRING',' ')
	CALL XVMESSAGE(SENSOR(ID(IDNUM)+1),' ')
	CALL DATIME(JDATE,JTIME,DATESTR)
	CALL XLADD(IOUTUNIT,'HISTORY','DATE_TIME',DATESTR,ISTAT,
     +		   'FORMAT','STRING','ULEN',21,' ')
	CALL XVMESSAGE(DATESTR,' ')
C						 compute and report band numbers
	N = 0
	DO I=1,32
	    IF (BTEST(ICHAN,I-1)) THEN
		N = N + 1
		NCHAN(N) = I
	    END IF
	END DO
	WRITE (PRT,100) (NCHAN(I),I=1,N)
  100	FORMAT(32I3)
	CALL XLADD(IOUTUNIT,'HISTORY','BAND(S)',PRT,ISTAT,
     +		   'FORMAT','STRING','ULEN',3*N,' ')
	CALL XVMESSAGE(PRT,' ')
C					put source and calibration type in label
	WRITE (PRT,200) IBUF(52),IBUF(53)
  200	FORMAT(A4,'/',A4)
	CALL XLADD(IOUTUNIT,'HISTORY','SRCE/CAL',PRT,ISTAT,
     +		   'FORMAT','STRING','ULEN',9,' ')
	CALL XVMESSAGE(PRT,' ')
C					   if subsampling done, note it in label
	IF (LINC.NE.1 .OR. ISINC.NE.1) THEN
	    WRITE (PRT,300) LINC,ISINC
  300	    FORMAT(' EVERY',I3,' LINES,',I3,' SAMPLES')
	    CALL XLADD(IOUTUNIT,'HISTORY','SAMPLED',PRT,ISTAT,
     +		   'FORMAT','STRING','ULEN',27,' ')
	    CALL XVMESSAGE(PRT,' ')
	END IF
C
	RETURN
	END
C***********************************************************************
	SUBROUTINE READ_DATA(BUF,HBUF,IBUF,NL,NS,NB,NBPP,ISKIP,IOUTUNIT)
C
	INTEGER IBUF(*)
	INTEGER*2 HBUF(*),HOLD2(3840)
	INTEGER NLAST/0/,NLWROTE/0/
	LOGICAL*1 BUF(*),HOLD(7680)
	EQUIVALENCE (HOLD,HOLD2)
	SAVE
C
	LOC = 0
	IF (NB .EQ. 1) THEN				! BSQ output
	    IF (NBPP .EQ. 1) THEN			!	byte data
		IF (NLAST .NE. 0) THEN
		    CALL MVE(1,ISKIP+NS-NLAST,BUF,HOLD(NLAST+1),1,1)
		    LOC = ISKIP+NS-NLAST
		    IF (NLWROTE.LT.NL) THEN
			CALL XVWRIT(IOUTUNIT,HOLD(ISKIP+1),ISTAT,' ')
			NLWROTE = NLWROTE + 1
		    END IF
		END IF
		DO WHILE (LOC+NS+ISKIP .LE. 7680)
		    LOC = LOC + ISKIP
		    IF (NLWROTE.LT.NL) THEN
			CALL XVWRIT(IOUTUNIT,BUF(LOC+1),ISTAT,' ')
			NLWROTE = NLWROTE +1
		    END IF
		    LOC = LOC + NS
		END DO
		NLAST = 7680 - LOC
		IF (NLAST .NE. 0) CALL MVE(1,NLAST,BUF(LOC+1),HOLD,1,1)
	    ELSE IF (NBPP .EQ. 2) THEN			!	halfword data
		ISKIPH = ISKIP/2
		IF (NLAST .NE. 0) THEN
		    CALL MVE(2,ISKIPH+NS-NLAST,HBUF,HOLD2(NLAST+1),1,1)
		    LOC = ISKIPH+NS-NLAST
		    IF (NLWROTE.LT.NL) THEN
			CALL XVWRIT(IOUTUNIT,HOLD2(ISKIPH+1),ISTAT,' ')
			NLWROTE = NLWROTE + 1
		    END IF
		END IF
		DO WHILE (LOC+NS+ISKIPH .LE. 3840)
		    LOC = LOC + ISKIPH
		    IF (NLWROTE.LT.NL) THEN
			CALL XVWRIT(IOUTUNIT,HBUF(LOC+1),ISTAT,' ')
			NLWROTE = NLWROTE +1
		    END IF
		    LOC = LOC + NS
		END DO
		NLAST = 3840 - LOC
		IF (NLAST .NE. 0) CALL MVE(2,NLAST,HBUF(LOC+1),HOLD2,1,
     +					   1)
	    ELSE					!	integer data
		CALL XVMESSAGE(' 1 BAND, INTEGER INPUT NOT IMPLEMENTED',' ')
		CALL ABEND
	    END IF
	ELSE						! BIP output
	    IF (NBPP .EQ. 1) THEN			!	byte data
		CALL XVMESSAGE(' MULTICHANNEL, BYTE INPUT NOT IMPLEMENTED',' ')
		CALL ABEND
	    ELSE IF (NBPP .EQ. 2) THEN			!	halfword data
		CALL XVMESSAGE(' MULTICHAN, HALFWD INPUT NOT IMPLEMENTED',' ')
		CALL ABEND
	    ELSE					!	integer data
		CALL XVMESSAGE(' MULTICHAN, INTEGER INPUT NOT IMPLEMENTED',' ')
		CALL ABEND
	    END IF
	END IF
	RETURN
	END
C***********************************************************************
	SUBROUTINE DATIME(JDATE,JTIME,DATESTR)
C
	CHARACTER*21 DATESTR
	CHARACTER*3 MON(12)/'JAN','FEB','MAR','APR','MAY','JUN','JUL',
     +			    'AUG','SEP','OCT','NOV','DEC'/
	INTEGER IMON(12)/0,31,60,91,121,152,182,213,244,274,305,335/
C
	IYR = JDATE/1000
	IDAY = JDATE - 1000*IYR
	IF (MOD(IYR,4).NE.0 .AND. IDAY.GT.59) IDAY=IDAY+1   ! handle leap year
	DO I=1,12
	    IF (IMON(I) .GE. IDAY) GO TO 100
	END DO
  100	CONTINUE
	I = I-1
	IDAY = IDAY - IMON(I)
	IHR = JTIME/10000
	MIN = MOD(JTIME/100,100)
	ISEC = MOD(JTIME,100)
C							    build date string
	IF (IYR .GT. 99) THEN
	    WRITE (DATESTR,150) MON(I),IDAY,IYR,IHR,MIN,ISEC
  150	    FORMAT(A3,I3,',',I5,I3,':',I2.2,':',I2.2)
	ELSE IF (IYR .GT. 60) THEN
	    WRITE (DATESTR,200) MON(I),IDAY,IYR,IHR,MIN,ISEC
  200	    FORMAT(A3,I3,', 19',I2,I3,':',I2.2,':',I2.2)
	ELSE
	    WRITE (DATESTR,300) MON(I),IDAY,IYR,IHR,MIN,ISEC
  300	    FORMAT(A3,I3,', 20',I2,I3,':',I2.2,':',I2.2)
	END IF
C
	RETURN
	END


! -----------------------------------------------------------------------------
!         OpenMM(tm) HelloArgon example in Fortran 95 (June 2009)
! -----------------------------------------------------------------------------
! This program demonstrates a simple molecular simulation using the OpenMM
! API for GPU-accelerated molecular dynamics simulation. The primary goal is
! to make sure you can compile, link, and run with OpenMM and view the output.
! The example is available in C++, C, and Fortran 95.
!
! The system modeled here is a small number of argon atoms in a vacuum.
! A multi-frame PDB file is written to stdout which  can be read by VMD or
! other visualization tool to produce an animation of the resulting trajectory.
! -----------------------------------------------------------------------------

INCLUDE 'OpenMMFortranModule.f90'

PROGRAM HelloArgon
    use OpenMM; implicit none
    type(OpenMM_System)           system
    type(OpenMM_VerletIntegrator) verlet
    type(OpenMM_Context)          context
    type(OpenMM_Platform)         platform
    type(OpenMM_NonbondedForce)   nonbond
    type(OpenMM_Vec3Array)        initPosInNm
    type(OpenMM_State)            state
    type(OpenMM_StringArray)      pluginList
    real*8                        timeInPs
    integer*4                     a, ix, frameNum
    character*10                  platformName
    character*100                 dirName

    ! Load any shared libraries containing GPU implementations.
    call OpenMM_Platform_getDefaultPluginsDirectory(dirName)
    call OpenMM_Platform_loadPluginsFromDirectory(dirName, pluginList)
    call OpenMM_StringArray_destroy(pluginList)

    ! Create a system with nonbonded forces. System takes ownership
    ! of Force; don't destroy it yourself. (We're using transfer here
    ! to recast the specific NonbondedForce to a general Force.)
    call OpenMM_System_create(system)
    call OpenMM_NonbondedForce_create(nonbond)
    ix = OpenMM_System_addForce(system, transfer(nonbond, OpenMM_Force(0)))

    ! Create three atoms.
    call OpenMM_Vec3Array_create(initPosInNm, 3)
    do a=1,3
        ! Space the atoms out evenly by atom index.
        call OpenMM_Vec3Array_set(initPosInNm, a, (/ 0.5d0*(a-1), 0d0, 0d0 /))

        ix = OpenMM_System_addParticle(system, 39.95d0) !mass of Ar, grams/mole

        ! charge, L-J sigma (nm), well depth (kJ) (vdWRad(Ar)=.188 nm)
        ix = OpenMM_NonbondedForce_addParticle(nonbond, 0d0, 0.3350d0, 0.996d0)
    end do

    ! Create particular integrator, and recast to generic one.
    call OpenMM_VerletIntegrator_create(verlet, 4d-3) !step size in ps

    ! Let OpenMM Context choose best platform.
    call OpenMM_Context_create(context, system, &
              transfer(verlet, OpenMM_Integrator(0)))
    call OpenMM_Context_getPlatform(context, platform)
    call OpenMM_Platform_getName(platform, platformName)
    print "('REMARK  Using OpenMM platform ', A)", platformName

    ! Set starting positions of the atoms. Leave time and velocity zero.
    call OpenMM_Context_setPositions(context, initPosInNm)

    ! Simulate.
    frameNum = 1
    do
        ! Output current state information.
        call OpenMM_Context_getState(context, OpenMM_State_Positions, OpenMM_False, state)
        timeInPs = OpenMM_State_getTime(state)
        call writePdbFrame(frameNum, state) !output coordinates
        call OpenMM_State_destroy(state)

        if (timeInPs .ge. 10.) then
            exit
        end if

        ! Advance state many steps at a time, for efficient use of OpenMM.
        ! (use a lot more than 10 normally)
        call OpenMM_VerletIntegrator_step(verlet, 10)
        frameNum = frameNum + 1
    end do

    ! Free heap space for all the objects created above.
    call OpenMM_Vec3Array_destroy(initPosInNm)
    call OpenMM_Context_destroy(context)
    call OpenMM_VerletIntegrator_destroy(verlet)
    call OpenMM_System_destroy(system)
END PROGRAM

! Handy homebrew PDB writer for quick-and-dirty trajectory output.
SUBROUTINE writePDBFrame(frameNum, state)
    use OpenMM; implicit none
    integer            frameNum
    type(OpenMM_State) state

    type(OpenMM_Vec3Array) allPosInNm
    real*8                 posInNm(3), posInAng(3)
    integer                n

    ! Reference atomic positions in the OpenMM State.
    call OpenMM_State_getPositions(state, allPosInNm)

    print "('MODEL',5X,I0)", frameNum   ! start of frame
    do n = 1,OpenMM_Vec3Array_getSize(allPosInNm)
        call OpenMM_Vec3Array_get(allPosInNm, n, posInNm)
        call OpenMM_Vec3_scale(posInNm, 10d0, posInAng)
        print "('ATOM  ', I5, '  AR   AR     1    ', 3F8.3, '  1.00  0.00')",    &
            n, posInAng
    end do
    print "('ENDMDL')"
END SUBROUTINE


	SUBROUTINE G2T_EXCEPT ( ktype, nt, nz, iret )
C************************************************************************
C* G2T_EXCEPT								*
C*									*
C* This subroutine stores the EXCEPT part to common.			*
C*									*
C* G2T_EXCEPT ( KTYPE, NT, IRET )					*
C*									*
C* Input parameters:							*
C*	KTYPE		INTEGER		Grid parameter type		*
C*					 1 = wave			*
C*					 2 = wind			*
C*	NT		INTEGER		Nth time step			*
C*	NZ		INTEGER		Nth zone area			*
C*									*
C* Output Parameters:							*
C*	IRET		INTEGER		Return code			*
C*					 0 = normal return		*
C**									*
C* Log:									*
C* T. Lee/SAIC		03/07						*
C* T. Lee/SAIC		11/07	Added lesser values to EXCEPT		*
C************************************************************************
	INCLUDE		'goftxt.cmn'
	LOGICAL		proces
	INCLUDE		'ERMISS.FNC'
C-----------------------------------------------------------------------
	iret = 0
C
C*	Store "Except Portion" information for winds.
C
	proces = .true.
	kk = 2
	mxw_1 = mxval ( ktype, 1, nt )
	mxw_s = mxval_s ( ktype, 1, nt )
C
C*	Store "Except Portion" information.
C
	DO WHILE ( proces )
	    IF ( mxw_1 .lt. mxw_s ) THEN
		IF ( mxval_s ( ktype, kk, nt ) .eq.  mxw_s )  THEN
	    	    CALL G2T_RANGE ( ktype, mxw_s, jrange, ier )
	    	    mnws = mnval_s ( ktype, kk, nt )
		    IF ( ABS ( mxw_s - mnws ) .gt. jrange )
     +			mnval ( ktype, kk, nt ) = mxw_s - jrange
		    nbnd  ( ktype, nt )  = kk
		    fsuba ( ktype, nt ) = .true.
		    subid ( ktype, nt ) = squad ( nz, kk )
		    proces = .false.
		END IF
	      ELSE IF ( mxw_1 .eq. mxw_s .and. mnzflg ( ktype ) )  THEN
		jtemp = mxw_1
		DO ii = 2, nsubzn ( nz )
		    IF ( .not. ERMISS ( FLOAT (mxval (ktype,ii,nt) ) )
     +			 .and.
     +			 mxval ( ktype, ii, nt ) .lt. jtemp )  THEN
			kk = ii
			jtemp = mxval ( ktype, ii, nt )
		    END IF
		END DO
		mtemp = mxval ( ktype, kk, nt )
		ntemp = mnval ( ktype, kk, nt )
		CALL G2T_RANGE ( ktype, mtemp, jrange, ier )
		ktemp = mtemp - jrange
		mnval ( ktype, kk, nt ) = AMAX0 ( ntemp, ktemp )
C
		nbnd  ( ktype, nt ) = kk
		fsuba ( ktype, nt ) = .true.
		subid ( ktype, nt ) = squad ( nz, kk )
		proces = .false.
	    END IF
	    kk = kk + 1
	    IF  ( kk .gt. nsubzn ( nz ) ) proces = .false.
	END DO
C*
	RETURN
	END


module GwfStoModule

  use KindModule,             only: DP, I4B
  use ConstantsModule,        only: DZERO, DEM6, DEM4, DONE, LENBUDTXT,        &
                                    MEMREADWRITE
  use SmoothingModule,        only: sQuadraticSaturation,                      &
                                    sQuadraticSaturationDerivative,            &
                                    sQSaturation, sLinearSaturation
  use BaseDisModule,          only: DisBaseType
  use NumericalPackageModule, only: NumericalPackageType
  use BlockParserModule,      only: BlockParserType

  implicit none
  public :: GwfStoType, sto_cr

  character(len=LENBUDTXT), dimension(2) :: budtxt =                           & !text labels for budget terms
      ['          STO-SS', '          STO-SY']

  type, extends(NumericalPackageType) :: GwfStoType
    integer(I4B), pointer                            :: isfac => null()          !indicates if ss is read as storativity
    integer(I4B), pointer                            :: isseg => null()          !indicates if ss is 0 below the top of a layer
    integer(I4B), pointer                            :: iss => null()            !steady state flag
    integer(I4B), pointer                            :: iusesy => null()         !flag set if any cell is convertible (0, 1)
    integer(I4B), dimension(:), pointer, contiguous  :: iconvert => null()       !confined (0) or convertible (1)
    real(DP),dimension(:), pointer, contiguous       :: sc1 => null()            !primary storage capacity (when cell is fully saturated)
    real(DP),dimension(:), pointer, contiguous       :: sc2 => null()            !secondary storage capacity (when cell is partially saturated)
    integer(I4B), pointer                            :: iresetsc1 => null()      !should be set to 1 whenever sc1 has been updated 'in-flight', this triggers the conversion
    integer(I4B), pointer                            :: iresetsc2 => null()      !should be set to 1 whenever sc2 has been updated 'in-flight', this triggers the conversion
    real(DP), dimension(:), pointer, contiguous      :: strgss => null()         !vector of specific storage rates
    real(DP), dimension(:), pointer, contiguous      :: strgsy => null()         !vector of specific yield rates
    integer(I4B), dimension(:), pointer, contiguous  :: ibound => null()         !pointer to model ibound
    real(DP), pointer                                :: satomega => null()       !newton-raphson saturation omega
  contains
    procedure :: sto_ar
    procedure :: sto_rp
    procedure :: sto_ad
    procedure :: sto_fc
    procedure :: sto_fn
    procedure :: bdcalc   => sto_bdcalc
    procedure :: bdsav    => sto_bdsav
    procedure :: sto_da
    procedure          :: allocate_scalars
    procedure, private :: allocate_arrays
    procedure, private :: read_options
    procedure, private :: read_data
    procedure, private :: convert_sc1, convert_sc2
  endtype

  contains

  subroutine sto_cr(stoobj, name_model, inunit, iout)
! ******************************************************************************
! sto_cr -- Create a new STO object
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    type(GwfStoType), pointer :: stoobj
    character(len=*), intent(in) :: name_model
    integer(I4B), intent(in) :: inunit
    integer(I4B), intent(in) :: iout
! ------------------------------------------------------------------------------
    !
    ! -- Create the object
    allocate(stoobj)
    !
    ! -- create name and origin
    call stoobj%set_names(1, name_model, 'STO', 'STO')
    !
    ! -- Allocate scalars
    call stoobj%allocate_scalars()
    !
    ! -- Set variables
    stoobj%inunit = inunit
    stoobj%iout = iout
    !
    ! -- Initialize block parser
    call stoobj%parser%Initialize(stoobj%inunit, stoobj%iout)
    !
    ! -- Return
    return
  end subroutine sto_cr

  subroutine sto_ar(this, dis, ibound)
! ******************************************************************************
! sto_ar -- Allocate and Read
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    !modules
    use MemoryManagerModule, only: mem_setptr
    ! -- dummy
    class(GwfStoType)                       :: this
    class(DisBaseType), pointer, intent(in) :: dis
    integer(I4B), dimension(:), pointer, contiguous          :: ibound
    ! -- local
    ! -- formats
    character(len=*), parameter :: fmtsto =                                    &
      "(1x,/1x,'STO -- STORAGE PACKAGE, VERSION 1, 5/19/2014',                 &
      &' INPUT READ FROM UNIT ', i0, //)"
! ------------------------------------------------------------------------------
    !
    ! --print a message identifying the storage package.
    write(this%iout, fmtsto) this%inunit
    !
    ! -- store pointers to arguments that were passed in
    this%dis     => dis
    this%ibound  => ibound
    !
    ! -- set pointer to gwf iss
    call mem_setptr(this%iss, 'ISS', trim(this%name_model))
    !
    ! -- Allocate arrays
    call this%allocate_arrays(dis%nodes)
    !
    ! -- Read storage options
    call this%read_options()
    !
    ! -- read the data block
    call this%read_data()
    !
    ! -- Return
    return
  end subroutine sto_ar

  subroutine sto_rp(this)
! ******************************************************************************
! sto_rp -- Read and prepare
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    use ConstantsModule,   only: LINELENGTH
    use TdisModule,        only: kper, nper
    use SimModule,         only: store_error, ustop
    implicit none
    ! -- dummy
    class(GwfStoType) :: this
    ! -- local
    integer(I4B)               :: ierr
    logical                   :: isfound, readss, readsy, endOfBlock
    !character(len=24)         :: aname(4) , stotxt
    character (len=16)        :: css(0:1)
    character(len=LINELENGTH) :: line, errmsg, keyword
    ! -- formats
    character(len=*),parameter :: fmtlsp = &
      "(1X,/1X,'REUSING ',A,' FROM LAST STRESS PERIOD')"
    character(len=*),parameter :: fmtblkerr = &
      "('Error.  Looking for BEGIN PERIOD iper.  Found ', a, ' instead.')"
    !data
    data css(0) /'       TRANSIENT'/
    data css(1) /'    STEADY-STATE'/
    !data aname(1) /'                ICONVERT'/
    !data aname(2) /'        SPECIFIC STORAGE'/
    !data aname(3) /'          SPECIFIC YIELD'/
    !data aname(4) /'     STORAGE COEFFICIENT'/
! ------------------------------------------------------------------------------
    !
    ! -- get stress period data
    if (this%ionper < kper) then
      !
      ! -- get period block
      call this%parser%GetBlock('PERIOD', isfound, ierr, &
                                supportOpenClose=.true.)
      if (isfound) then
        !
        ! -- read ionper and check for increasing period numbers
        call this%read_check_ionper()
      else
        !
        ! -- PERIOD block not found
        if (ierr < 0) then
          ! -- End of file found; data applies for remainder of simulation.
          this%ionper = nper + 1
        else
          ! -- Found invalid block
          call this%parser%GetCurrentLine(line)
          write(errmsg, fmtblkerr) adjustl(trim(line))
          call store_error(errmsg)
          call this%parser%StoreErrorUnit()
          call ustop()
        end if
      endif
    end if
    !
    ! -- read data if ionper == kper
    ! are these here to anticipate reading ss,sy per stress period?
    readss = .false.
    readsy = .false.

    ! when in-memory reset of coefficients, redo calculations
    if (this%iresetsc1 == 1) then
      call this%convert_sc1()
      this%iresetsc1 = 0
    end if
    if (this%iresetsc2 == 1) then
      call this%convert_sc2()
      this%iresetsc2 = 0
    end if

    !stotxt = aname(2)
    if(this%ionper==kper) then
      write(this%iout, '(//,1x,a)') 'PROCESSING STORAGE PERIOD DATA'
      do
        call this%parser%GetNextLine(endOfBlock)
        if (endOfBlock) exit
        call this%parser%GetStringCaps(keyword)
        select case (keyword)
          case ('STEADY-STATE')
            this%iss = 1
          case ('TRANSIENT')
            this%iss = 0
          case default
            write(errmsg,'(4x,a,a)') 'ERROR. UNKNOWN STORAGE DATA TAG: ',      &
                                     trim(keyword)
            call store_error(errmsg)
            call this%parser%StoreErrorUnit()
            call ustop()
        end select
      end do
      write(this%iout,'(1x,a)') 'END PROCESSING STORAGE PERIOD DATA'
    !else
    !  write(this%iout,fmtlsp) 'STORAGE VALUES'
    endif

    write(this%iout,'(//1X,A,I0,A,A,/)') &
      'STRESS PERIOD ', kper, ' IS ', trim(adjustl(css(this%iss)))
    !
    ! -- Return
    return
  end subroutine sto_rp

  subroutine sto_ad(this)
! ******************************************************************************
! sto_ad -- Advance
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    class(GwfStoType) :: this
! ------------------------------------------------------------------------------
    !
    ! -- Subroutine does not do anything at the moment
    !
    ! -- Return
    return
  end subroutine sto_ad

  subroutine sto_fc(this, kiter, hold, hnew, njasln, amat, idxglo, rhs)
! ******************************************************************************
! sto_fc -- Fill the solution amat and rhs with storage contribution newton
!               term
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use SimModule, only: ustop, store_error
    use ConstantsModule, only: LINELENGTH
    use TdisModule, only: delt
    ! -- dummy
    class(GwfStoType) :: this
    integer(I4B),intent(in) :: kiter
    real(DP), intent(in), dimension(:) :: hold
    real(DP), intent(in), dimension(:) :: hnew
    integer(I4B),intent(in) :: njasln
    real(DP), dimension(njasln),intent(inout) :: amat
    integer(I4B), intent(in),dimension(:) :: idxglo
    real(DP),intent(inout),dimension(:) :: rhs
    ! -- local
    integer(I4B) :: n, idiag
    real(DP) :: tled, rho1, rho2
    real(DP) :: tp, bt, tthk
    real(DP) :: snold, snnew
    real(DP) :: ss0, ss1, ssh0, ssh1
    real(DP) :: rhsterm
    character(len=LINELENGTH) :: errmsg
    ! -- formats
    character(len=*), parameter :: fmtsperror =                                &
      &"('DETECTED TIME STEP LENGTH OF ZERO.  GWF STORAGE PACKAGE CANNOT BE ', &
      &'USED UNLESS DELT IS NON-ZERO.')"
! ------------------------------------------------------------------------------
    !
    ! -- test if steady-state stress period
    if (this%iss /= 0) return
    !
    ! -- Ensure time step length is not zero
    if (delt == DZERO) then
      write(errmsg, fmtsperror)
      call store_error(errmsg)
      call ustop()
    endif
    !
    ! -- set variables
    tled = DONE / delt
    !
    ! -- loop through and calculate storage contribution to hcof and rhs
    do n = 1, this%dis%nodes
      idiag = this%dis%con%ia(n)
      if (this%ibound(n) < 1) cycle
      ! -- aquifer elevations and thickness
      tp = this%dis%top(n)
      bt = this%dis%bot(n)
      tthk = tp - bt
      ! -- aquifer saturation
      snold = sQuadraticSaturation(tp, bt, hold(n), this%satomega)
      snnew = sQuadraticSaturation(tp, bt, hnew(n), this%satomega)
      ! -- set saturation used for ss
      ss0 = snold
      ssh0 = hold(n)
      ss1 = snnew
      ssh1 = DZERO
      if (this%isseg /= 0) then
        if (ss0 < DONE) then
          ss0 = DONE
          ssh0 = tp
        end if
        if (ss1 < DONE) then
          ss1 = DZERO
          ssh1 = tp
        end if
      end if
      ! -- storage coefficients
      rho1 = this%sc1(n) * tled
      rho2 = this%sc2(n) * tled
      ! -- calculate storage coefficients for amat and rhs
      ! -- specific storage
      if (this%iconvert(n) /= 0) then
        amat(idxglo(idiag)) = amat(idxglo(idiag)) - rho1 * ss1
        rhs(n) = rhs(n) - rho1 * ss0 * ssh0 + rho1 * ssh1
      else
        amat(idxglo(idiag)) = amat(idxglo(idiag)) - rho1
        rhs(n) = rhs(n) - rho1 * hold(n)
      end if
      ! -- specific yield
      if (this%iconvert(n) /= 0) then
        rhsterm = DZERO
        ! -- add specific yield terms to amat at rhs
        if (snnew < DONE) then
          if (snnew > DZERO) then
            amat(idxglo(idiag)) = amat(idxglo(idiag)) - rho2
            rhsterm = rho2 * tthk * snold
            rhsterm = rhsterm + rho2 * bt
          else
            rhsterm = -rho2 * tthk * (DZERO - snold)
          end if
        ! -- known flow from specific yield
        else
          rhsterm = -rho2 * tthk * (DONE - snold)
        end if
        rhs(n) = rhs(n) - rhsterm
      end if
    end do
    !
    ! -- Return
    return
  end subroutine sto_fc

  subroutine sto_fn(this, kiter, hold, hnew, njasln, amat, idxglo, rhs)
! ******************************************************************************
! sto_fn -- Fill the solution amat and rhs with storage contribution
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    use TdisModule, only: delt
    ! -- dummy
    class(GwfStoType) :: this
    integer(I4B),intent(in) :: kiter
    real(DP), intent(in), dimension(:) :: hold
    real(DP), intent(in), dimension(:) :: hnew
    integer(I4B),intent(in) :: njasln
    real(DP), dimension(njasln),intent(inout) :: amat
    integer(I4B), intent(in),dimension(:) :: idxglo
    real(DP),intent(inout),dimension(:) :: rhs
    ! -- local
    integer(I4B) :: n, idiag
    real(DP) :: tled, rho1, rho2
    real(DP) :: tp, bt, tthk
    real(DP) :: snold, snnew
    real(DP) :: ss0, ss1
    real(DP) :: derv, rterm, drterm
! ------------------------------------------------------------------------------
    !
    ! -- test if steady-state stress period
    if (this%iss /= 0) return
    !
    ! -- set variables
    tled = DONE / delt
    !
    ! -- loop through and calculate storage contribution to hcof and rhs
    do n = 1, this%dis%nodes
      idiag = this%dis%con%ia(n)
      if(this%ibound(n) <= 0) cycle
      ! -- aquifer elevations and thickness
      tp = this%dis%top(n)
      bt = this%dis%bot(n)
      tthk = tp - bt
      ! -- aquifer saturation
      snold = sQuadraticSaturation(tp, bt, hold(n))
      snnew = sQuadraticSaturation(tp, bt, hnew(n))
      ! -- set saturation used for ss
      ss0 = snold
      ss1 = snnew
      if (this%isseg /= 0) then
        if (ss0 < DONE) ss0 = DZERO
        if (ss1 < DONE) ss1 = DZERO
      end if
      ! -- storage coefficients
      rho1 = this%sc1(n) * tled
      rho2 = this%sc2(n) * tled
      ! -- calculate storage coefficients for amat and rhs
      ! -- specific storage
      if (this%iconvert(n) /= 0) then
        rterm = - rho1 * ss1 * hnew(n)
        derv = sQuadraticSaturationDerivative(tp, bt, hnew(n))
        if (this%isseg /= 0) derv = DZERO
        drterm = -(rho1 * derv * hnew(n))
        amat(idxglo(idiag)) = amat(idxglo(idiag)) + drterm
        rhs(n) = rhs(n) + drterm * hnew(n)
      end if
      ! -- specific yield
      if (this%iconvert(n) /= 0) then
        ! -- newton terms for specific yield only apply if
        !    current saturation is less than one
        if (snnew < DONE) then
          ! -- calculate newton terms for specific yield
          if (snnew > DZERO) then
            rterm = - rho2 * tthk * snnew
            derv = sQuadraticSaturationDerivative(tp, bt, hnew(n))
            drterm = -rho2 * tthk * derv
            amat(idxglo(idiag)) = amat(idxglo(idiag)) + drterm + rho2
            rhs(n) = rhs(n) - rterm + drterm * hnew(n) + rho2 * bt
          end if
        end if
      end if
    end do
    !
    ! -- Return
    return
  end subroutine sto_fn

  subroutine sto_bdcalc(this, nodes, hnew, hold, isuppress_output, model_budget)
! ******************************************************************************
! sto_bdcalc -- Calculate budget terms
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use TdisModule,        only: delt
    use BudgetModule, only: BudgetType
    ! -- dummy
    class(GwfStoType) :: this
    integer(I4B), intent(in) :: nodes
    real(DP), intent(in), dimension(nodes) :: hnew
    real(DP), intent(in), dimension(nodes) :: hold
    integer(I4B), intent(in) :: isuppress_output
    type(BudgetType), intent(inout) :: model_budget
    ! -- local
    integer(I4B) :: n
    real(DP) :: rate
    real(DP) :: tled, rho1, rho2
    real(DP) :: tp, bt, tthk
    real(DP) :: snold, snnew
    real(DP) :: ss0, ss1, ssh0, ssh1
    real(DP) :: rssin, rssout, rsyin, rsyout
! ------------------------------------------------------------------------------
    !
    ! -- initialize accumulators
    rssin = DZERO
    rssout = DZERO
    rsyin = DZERO
    rsyout = DZERO
    !
    ! -- Set strt to zero or calculate terms if not steady-state stress period
    if (this%iss == 1) then
      do n = 1, nodes
        this%strgss(n) = DZERO
        this%strgsy(n) = DZERO
      end do
      !
    else
      !
      ! -- set variables
      tled = DONE / delt
      !
      ! -- Calculate storage change
      do n = 1, nodes
        this%strgss(n) = DZERO
        this%strgsy(n) = DZERO
        if(this%ibound(n) <= 0) cycle
        ! -- aquifer elevations and thickness
        tp = this%dis%top(n)
        bt = this%dis%bot(n)
        tthk = tp - bt
        snold = sQuadraticSaturation(tp, bt, hold(n), this%satomega)
        snnew = sQuadraticSaturation(tp, bt, hnew(n), this%satomega)
        ! -- set saturation used for ss
        ss0 = snold
        ssh0 = hold(n)
        ss1 = snnew
        ssh1 = DZERO
        if (this%isseg /= 0) then
          if (ss0 < DONE) then
            ss0 = DONE
            ssh0 = tp
          end if
          if (ss1 < DONE) then
            ss1 = DZERO
            ssh1 = tp
          end if
        end if
        ! -- storage coefficients
        rho1 = this%sc1(n) * tled
        rho2 = this%sc2(n) * tled
        ! -- specific storage
        if (this%iconvert(n) /= 0) then
          rate = rho1 * ss0 * ssh0 - rho1 * ss1 * hnew(n) - rho1 * ssh1
        else
          rate = rho1 * hold(n) - rho1 * hnew(n)
        end if
        this%strgss(n) = rate
        ! -- specific yield
        rate = DZERO
        if (this%iconvert(n) /= 0) then
          rate = rho2 * tthk * snold  - rho2 * tthk * snnew
        end if
        this%strgsy(n) = rate
        !
        ! -- accumulate ss
        if(this%strgss(n) < DZERO) then
          rssout = rssout - this%strgss(n)
        else
          rssin = rssin + this%strgss(n)
        endif
        !
        ! -- accumulate sy
        if(this%strgsy(n) < DZERO) then
          rsyout = rsyout - this%strgsy(n)
        else
          rsyin = rsyin + this%strgsy(n)
        endif
      enddo
    endif
    !
    ! -- Add contributions to model budget
    call model_budget%addentry(rssin, rssout, delt, budtxt(1),                 &
                               isuppress_output, '         STORAGE')
    if (this%iusesy == 1) then
      call model_budget%addentry(rsyin, rsyout, delt, budtxt(2),               &
                                 isuppress_output, '         STORAGE')
    end if
    !
    ! -- Return
    return
  end subroutine sto_bdcalc

  subroutine sto_bdsav(this, icbcfl, icbcun)
! ******************************************************************************
! sto_bdsav -- Save budget terms
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    class(GwfStoType) :: this
    integer(I4B), intent(in) :: icbcfl
    integer(I4B), intent(in) :: icbcun
    ! -- local
    integer(I4B) :: ibinun
    !character(len=16), dimension(2) :: aname
    integer(I4B) :: iprint, nvaluesp, nwidthp
    character(len=1) :: cdatafmp=' ', editdesc=' '
    real(DP) :: dinact
! ------------------------------------------------------------------------------
    !
    ! -- Set unit number for binary output
    if(this%ipakcb < 0) then
      ibinun = icbcun
    elseif(this%ipakcb == 0) then
      ibinun = 0
    else
      ibinun = this%ipakcb
    endif
    if(icbcfl == 0) ibinun = 0
    !
    ! -- Record the storage rates if requested
    if(ibinun /= 0) then
      iprint = 0
      dinact = DZERO
      !
      ! -- storage(ss)
      call this%dis%record_array(this%strgss, this%iout, iprint, -ibinun,    &
                                 budtxt(1), cdatafmp, nvaluesp,              &
                                 nwidthp, editdesc, dinact)
      !
      ! -- storage(sy)
      if (this%iusesy == 1) then
        call this%dis%record_array(this%strgsy, this%iout, iprint, -ibinun,  &
                                   budtxt(2), cdatafmp, nvaluesp,            &
                                   nwidthp, editdesc, dinact)
      end if
    endif
    !
    ! -- Return
    return
  end subroutine sto_bdsav

  subroutine sto_da(this)
! ******************************************************************************
! sto_da -- Deallocate variables
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use MemoryManagerModule, only: mem_deallocate
    ! -- dummy
    class(GwfStoType) :: this
! ------------------------------------------------------------------------------
    !
    ! -- Deallocate arrays if package is active
    if(this%inunit > 0) then
      call mem_deallocate(this%iconvert)
      call mem_deallocate(this%sc1)
      call mem_deallocate(this%sc2)
      call mem_deallocate(this%strgss)
      call mem_deallocate(this%strgsy)
    endif
    !
    ! -- Deallocate scalars
    call mem_deallocate(this%isfac)
    call mem_deallocate(this%isseg)
    call mem_deallocate(this%satomega)
    call mem_deallocate(this%iusesy)
    call mem_deallocate(this%iresetsc1)
    call mem_deallocate(this%iresetsc2)
    !
    ! -- deallocate parent
    call this%NumericalPackageType%da()
    !
    ! -- Return
    return
  end subroutine sto_da

  subroutine allocate_scalars(this)
! ******************************************************************************
! allocate_scalars
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use MemoryManagerModule, only: mem_allocate, mem_setptr
    ! -- dummy
    class(GwfStoType) :: this
    ! -- local
! ------------------------------------------------------------------------------
    !
    ! -- allocate scalars in NumericalPackageType
    call this%NumericalPackageType%allocate_scalars()
    !
    ! -- Allocate
    call mem_allocate(this%iusesy, 'IUSESY', this%origin)
    call mem_allocate(this%isfac, 'ISFAC', this%origin)
    call mem_allocate(this%isseg, 'ISSEG', this%origin)
    call mem_allocate(this%satomega, 'SATOMEGA', this%origin)
    call mem_allocate(this%iresetsc1, 'IRESETSC1', this%origin, MEMREADWRITE)
    call mem_allocate(this%iresetsc2, 'IRESETSC2', this%origin, MEMREADWRITE)
    !
    ! -- Initialize
    this%iusesy = 0
    this%isfac = 0
    this%isseg = 0
    this%satomega = DZERO
    this%iresetsc1 = 0
    this%iresetsc2 = 0
    !
    ! -- Return
    return
  end subroutine allocate_scalars

  subroutine allocate_arrays(this, nodes)
! ******************************************************************************
! allocate_arrays
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    use MemoryManagerModule, only: mem_allocate
    !modules
    use ConstantsModule, only: DZERO
    ! -- dummy
    class(GwfStoType) :: this
    integer(I4B), intent(in) :: nodes
    ! -- local
    integer(I4B) :: n
! ------------------------------------------------------------------------------
    !
    ! -- Allocate
    !call mem_allocate(this%iss, 'ISS', this%name_model)
    call mem_allocate(this%iconvert, nodes, 'ICONVERT', this%origin)
    call mem_allocate(this%sc1, nodes, 'SC1', this%origin, MEMREADWRITE)
    call mem_allocate(this%sc2, nodes, 'SC2', this%origin, MEMREADWRITE)
    call mem_allocate(this%strgss, nodes, 'STRGSS', this%origin)
    call mem_allocate(this%strgsy, nodes, 'STRGSY', this%origin)
    !
    ! -- Initialize
    this%iss = 0
    do n = 1, nodes
      this%iconvert(n) = 1
      this%sc1(n) = DZERO
      this%sc2(n) = DZERO
      this%strgss(n) = DZERO
      this%strgsy(n) = DZERO
    enddo
    !
    ! -- Return
    return
  end subroutine allocate_arrays

  subroutine read_options(this)
! ******************************************************************************
! gwf3sto1ar -- Allocate and Read
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    !modules
    use ConstantsModule,   only: LINELENGTH
    use SimModule,         only: ustop, store_error
    ! -- dummy
    class(GwfStoType) :: this
    ! -- local
    character(len=LINELENGTH) :: errmsg, keyword
    integer(I4B) :: ierr
    logical :: isfound, endOfBlock
    ! -- formats
    character(len=*), parameter :: fmtisvflow =                                &
      "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE " //    &
      "WHENEVER ICBCFL IS NOT ZERO.')"
    character(len=*),parameter :: fmtflow =                                    &
      "(4x, 'FLOWS WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)"
    character(len=*), parameter :: fmtstoc =                                   &
      "(4X,'STORAGECOEFFICIENT OPTION:',/,                                     &
      &1X,'Read storage coefficient rather than specific storage')"
    character(len=*), parameter :: fmtstoseg =                                 &
      "(4X,'OLDSTORAGEFORMULATION OPTION:',/,                                  &
      &1X,'Specific storage changes only occur above cell top')"
! ------------------------------------------------------------------------------
    !
    ! -- get options block
    call this%parser%GetBlock('OPTIONS', isfound, ierr, &
      supportOpenClose=.true., blockRequired=.false.)
    !
    ! -- parse options block if detected
    if (isfound) then
      write(this%iout,'(1x,a)')'PROCESSING STORAGE OPTIONS'
      do
        call this%parser%GetNextLine(endOfBlock)
        if (endOfBlock) exit
        call this%parser%GetStringCaps(keyword)
        select case (keyword)
          case ('SAVE_FLOWS')
            this%ipakcb = -1
            write(this%iout, fmtisvflow)
          case ('STORAGECOEFFICIENT')
            this%isfac = 1
            write(this%iout,fmtstoc)
          !
          ! -- right now these are options that are only available in the
          !    development version and are not included in the documentation.
          !    These options are only available when IDEVELOPMODE in
          !    constants module is set to 1
          case ('DEV_NO_NEWTON')
            call this%parser%DevOpt()
            this%inewton = 0
            write(this%iout, '(4x,a)')                                         &
                             'NEWTON-RAPHSON method disabled for unconfined cell storage'
          case ('DEV_OLDSTORAGEFORMULATION')
            call this%parser%DevOpt()
            this%isseg = 1
            write(this%iout,fmtstoseg)
          case default
            write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN STO OPTION: ',         &
                                     trim(keyword)
            call store_error(errmsg)
            call ustop()
        end select
      end do
      write(this%iout,'(1x,a)')'END OF STORAGE OPTIONS'
    end if
    !
    ! -- set omega value used for saturation calculations
    if (this%inewton > 0) then
      this%satomega = DEM6
    end if
    !
    ! -- Return
    return
  end subroutine read_options

  subroutine read_data(this)
! ******************************************************************************
! read_data -- read the storage data (stodata) block
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    use ConstantsModule,   only: LINELENGTH
    use SimModule,         only: ustop, store_error, count_errors
    ! -- dummy
    class(GwfStotype) :: this
    ! -- local
    character(len=LINELENGTH) :: errmsg, keyword
    character(len=:), allocatable :: line
    character(len=LINELENGTH) :: cellstr
    integer(I4B) :: istart, istop, lloc, ierr
    logical :: isfound, endOfBlock
    logical :: readiconv
    logical :: readss
    logical :: readsy
    logical :: isconv
    character(len=24), dimension(4) :: aname
    integer(I4B) :: n
    ! -- formats
    !data
    data aname(1) /'                ICONVERT'/
    data aname(2) /'        SPECIFIC STORAGE'/
    data aname(3) /'          SPECIFIC YIELD'/
    data aname(4) /'     STORAGE COEFFICIENT'/
! ------------------------------------------------------------------------------
    !
    ! -- initialize
    isfound = .false.
    readiconv = .false.
    readss = .false.
    readsy = .false.
    isconv = .false.
    !
    ! -- get stodata block
    call this%parser%GetBlock('GRIDDATA', isfound, ierr)
    if(isfound) then
      write(this%iout,'(1x,a)')'PROCESSING GRIDDATA'
      do
        call this%parser%GetNextLine(endOfBlock)
        if (endOfBlock) exit
        call this%parser%GetStringCaps(keyword)
        call this%parser%GetRemainingLine(line)
        lloc = 1
        select case (keyword)
          case ('ICONVERT')
            call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, &
                                         this%parser%iuactive, this%iconvert, &
                                         aname(1))
            readiconv = .true.
          case ('SS')
            call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, &
                                         this%parser%iuactive, this%sc1, &
                                         aname(2))
            readss = .true.
          case ('SY')
            call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, &
                                         this%parser%iuactive, this%sc2, &
                                         aname(3))
            readsy = .true.
          case default
            write(errmsg,'(4x,a,a)')'ERROR. UNKNOWN GRIDDATA TAG: ',            &
                                     trim(keyword)
            call store_error(errmsg)
            call this%parser%StoreErrorUnit()
            call ustop()
        end select
      end do
      write(this%iout,'(1x,a)')'END PROCESSING GRIDDATA'
    else
      write(errmsg,'(1x,a)')'ERROR.  REQUIRED GRIDDATA BLOCK NOT FOUND.'
      call store_error(errmsg)
      call this%parser%StoreErrorUnit()
      call ustop()
    end if
    !
    ! -- Check for ICONVERT
    if(.not. readiconv) then
      write(errmsg, '(a, a, a)') 'Error in GRIDDATA block: ',                   &
                                 trim(adjustl(aname(1))), ' not found.'
      call store_error(errmsg)
    else
      isconv = .false.
      do n = 1, this%dis%nodes
        if (this%iconvert(n) /= 0) then
          isconv = .true.
          this%iusesy = 1
          exit
        end if
      end do
    end if
    !
    ! -- Check for SS
    if(.not. readss) then
      write(errmsg, '(a, a, a)') 'Error in GRIDDATA block: ',                   &
                                 trim(adjustl(aname(2))), ' not found.'
      call store_error(errmsg)
    endif
    !
    ! -- Check for SY
    if(.not. readsy .and. isconv) then
      write(errmsg, '(a, a, a)') 'Error in GRIDDATA block: ',                   &
                                 trim(adjustl(aname(3))), ' not found.'
      call store_error(errmsg)
    endif
    !
    if(count_errors() > 0) then
      call this%parser%StoreErrorUnit()
      call ustop()
    endif
    !
    ! -- Check SS and SY for negative values
    do n = 1, this%dis%nodes
      if (this%sc1(n) < DZERO) then
        call this%dis%noder_to_string(n, cellstr)
        write(errmsg, '(a,2(1x,a),1x,g0,1x,a)')                                 &
          'Error in SS DATA: SS value in cell', trim(adjustl(cellstr)),         &
          'is less than zero (', this%sc1(n), ').'
        call store_error(errmsg)
      end if
      if (readsy) then
        if (this%sc2(n) < DZERO) then
          call this%dis%noder_to_string(n, cellstr)
          write(errmsg, '(a,2(1x,a),1x,g0,1x,a)')                               &
            'Error in SY DATA: SY value in cell', trim(adjustl(cellstr)),       &
            'is less than zero (', this%sc2(n), ').'
          call store_error(errmsg)
        end if
      end if
    end do

    !
    ! -- calculate sc1
    if (readss) then
      call this%convert_sc1()
    endif
    !
    ! -- calculate sc2
    if(readsy) then
      call this%convert_sc2()
    endif
    !
    ! -- Return
    return
  end subroutine read_data

  ! -- converts the primary storage into sc1*area
  subroutine convert_sc1(this)
    class(GwfStotype) :: this
    ! -- local
    integer(I4B) :: n
    real(DP) :: thick

    if(this%isfac == 0) then
        do n = 1, this%dis%nodes
          thick = this%dis%top(n) - this%dis%bot(n)
          this%sc1(n) = this%sc1(n) * thick * this%dis%area(n)
        end do
      else
        do n = 1, this%dis%nodes
          this%sc1(n) = this%sc1(n) * this%dis%area(n)
        enddo
      endif
  end subroutine convert_sc1

  ! -- converts the secondary storage into sc2*area
  subroutine convert_sc2(this)
    class(GwfStotype) :: this
    ! -- local
    integer(I4B) :: n

    do n=1, this%dis%nodes
      this%sc2(n) = this%sc2(n) * this%dis%area(n)
    enddo

  end subroutine convert_sc2

end module GwfStoModule