MODULE icedyn_rdgrft
  USE dom_oce
  USE phycst
  USE sbc_oce, ONLY: sss_m, sst_m
  USE ice1D
  USE ice
  USE icetab
  USE icevar
  USE icectl
  USE in_out_manager
  USE iom
  USE lib_mpp
  USE lib_fortran
  USE lbclnk
  USE timing
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: ice_dyn_rdgrft
  PUBLIC :: ice_dyn_rdgrft_init
  PUBLIC :: ice_strength
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:) :: closing_net
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:) :: opning
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:) :: closing_gross
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :) :: apartf
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :) :: hrmin
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :) :: hrmax
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :) :: hraft
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :) :: hi_hrdg
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :) :: aridge
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :) :: araft
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: ze_i_2d
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: ze_s_2d
  REAL(KIND = wp), PARAMETER :: hrdg_hi_min = 1.1_wp
  REAL(KIND = wp), PARAMETER :: hi_hrft = 0.5_wp
  LOGICAL :: ln_str_H79
  REAL(KIND = wp) :: rn_pstar
  REAL(KIND = wp) :: rn_crhg
  REAL(KIND = wp) :: rn_csrdg
  LOGICAL :: ln_partf_lin
  REAL(KIND = wp) :: rn_gstar
  LOGICAL :: ln_partf_exp
  REAL(KIND = wp) :: rn_astar
  LOGICAL :: ln_ridging
  REAL(KIND = wp) :: rn_hstar
  REAL(KIND = wp) :: rn_porordg
  REAL(KIND = wp) :: rn_fsnwrdg
  REAL(KIND = wp) :: rn_fpndrdg
  LOGICAL :: ln_rafting
  REAL(KIND = wp) :: rn_hraft
  REAL(KIND = wp) :: rn_craft
  REAL(KIND = wp) :: rn_fsnwrft
  REAL(KIND = wp) :: rn_fpndrft
  CONTAINS
  INTEGER FUNCTION ice_dyn_rdgrft_alloc()
    ALLOCATE(closing_net(jpij), opning(jpij), closing_gross(jpij), apartf(jpij, 0 : jpl), hrmin(jpij, jpl), hraft(jpij, jpl), aridge(jpij, jpl), hrmax(jpij, jpl), hi_hrdg(jpij, jpl), araft(jpij, jpl), ze_i_2d(jpij, nlay_i, jpl), ze_s_2d(jpij, nlay_s, jpl), STAT = ice_dyn_rdgrft_alloc)
    IF (lk_mpp) CALL mpp_sum(ice_dyn_rdgrft_alloc)
    IF (ice_dyn_rdgrft_alloc /= 0) CALL ctl_warn('ice_dyn_rdgrft_alloc: failed to allocate arrays')
  END FUNCTION ice_dyn_rdgrft_alloc
  SUBROUTINE ice_dyn_rdgrft(kt)
    INTEGER, INTENT(IN) :: kt
    INTEGER :: ji, jj, jk, jl
    INTEGER :: iter, iterate_ridging
    INTEGER :: ipti
    REAL(KIND = wp) :: zfac
    INTEGER, DIMENSION(jpij) :: iptidx
    REAL(KIND = wp), DIMENSION(jpij) :: zdivu_adv
    REAL(KIND = wp), DIMENSION(jpij) :: zdivu, zdelt
    INTEGER, PARAMETER :: jp_itermax = 20
    IF (ln_timing) CALL timing_start('icedyn_rdgrft')
    IF (ln_icediachk) CALL ice_cons_hsm(0, 'icedyn_rdgrft', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft)
    IF (kt == nit000) THEN
      IF (lwp) WRITE(numout, FMT = *)
      IF (lwp) WRITE(numout, FMT = *) 'ice_dyn_rdgrft: ice ridging and rafting'
      IF (lwp) WRITE(numout, FMT = *) '~~~~~~~~~~~~~~'
    END IF
    CALL ice_var_zapsmall
    npti = 0
    nptidx(:) = 0
    ipti = 0
    iptidx(:) = 0
    !$ACC KERNELS
    DO jj = 1, jpj
      DO ji = 1, jpi
        IF (at_i(ji, jj) > 0._wp) THEN
          npti = npti + 1
          nptidx(npti) = (jj - 1) * jpi + ji
        END IF
      END DO
    END DO
    !$ACC END KERNELS
    IF (npti > 0) THEN
      CALL tab_2d_1d(npti, nptidx(1 : npti), zdivu(1 : npti), divu_i(:, :))
      CALL tab_2d_1d(npti, nptidx(1 : npti), zdelt(1 : npti), delta_i(:, :))
      CALL tab_3d_2d(npti, nptidx(1 : npti), a_i_2d(1 : npti, 1 : jpl), a_i(:, :, :))
      CALL tab_3d_2d(npti, nptidx(1 : npti), v_i_2d(1 : npti, 1 : jpl), v_i(:, :, :))
      CALL tab_2d_1d(npti, nptidx(1 : npti), ato_i_1d(1 : npti), ato_i(:, :))
      DO ji = 1, npti
        closing_net(ji) = rn_csrdg * 0.5_wp * (zdelt(ji) - ABS(zdivu(ji))) - MIN(zdivu(ji), 0._wp)
        zdivu_adv(ji) = (1._wp - ato_i_1d(ji) - SUM(a_i_2d(ji, :))) * r1_rdtice
        IF (zdivu_adv(ji) < 0._wp) closing_net(ji) = MAX(closing_net(ji), - zdivu_adv(ji))
        opning(ji) = closing_net(ji) + zdivu_adv(ji)
      END DO
      CALL rdgrft_prep(a_i_2d, v_i_2d, ato_i_1d, closing_net)
      DO ji = 1, npti
        IF (SUM(apartf(ji, 1 : jpl)) > 0._wp .AND. closing_gross(ji) > 0._wp) THEN
          !$ACC KERNELS
          ipti = ipti + 1
          iptidx(ipti) = nptidx(ji)
          a_i_2d(ipti, :) = a_i_2d(ji, :)
          v_i_2d(ipti, :) = v_i_2d(ji, :)
          ato_i_1d(ipti) = ato_i_1d(ji)
          closing_net(ipti) = closing_net(ji)
          zdivu_adv(ipti) = zdivu_adv(ji)
          opning(ipti) = opning(ji)
          !$ACC END KERNELS
        END IF
      END DO
    END IF
    nptidx(:) = iptidx(:)
    npti = ipti
    IF (npti > 0) THEN
      CALL ice_dyn_1d2d(1)
      iter = 1
      iterate_ridging = 1
      DO WHILE (iterate_ridging > 0 .AND. iter < jp_itermax)
        CALL rdgrft_prep(a_i_2d, v_i_2d, ato_i_1d, closing_net)
        CALL rdgrft_shift
        iterate_ridging = 0
        DO ji = 1, npti
          zfac = 1._wp - (ato_i_1d(ji) + SUM(a_i_2d(ji, :)))
          IF (ABS(zfac) < epsi10) THEN
            closing_net(ji) = 0._wp
            opning(ji) = 0._wp
            ato_i_1d(ji) = MAX(0._wp, 1._wp - SUM(a_i_2d(ji, :)))
          ELSE
            iterate_ridging = 1
            zdivu_adv(ji) = zfac * r1_rdtice
            closing_net(ji) = MAX(0._wp, - zdivu_adv(ji))
            opning(ji) = MAX(0._wp, zdivu_adv(ji))
          END IF
        END DO
        iter = iter + 1
        IF (iter > jp_itermax) CALL ctl_warn('icedyn_rdgrft: non-converging ridging scheme')
      END DO
      CALL ice_dyn_1d2d(2)
    END IF
    CALL ice_var_agg(1)
    IF (ln_icediachk) CALL ice_cons_hsm(1, 'icedyn_rdgrft', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft)
    IF (ln_ctl) CALL ice_prt3D('icedyn_rdgrft')
    IF (ln_timing) CALL timing_stop('icedyn_rdgrft')
  END SUBROUTINE ice_dyn_rdgrft
  SUBROUTINE rdgrft_prep(pa_i, pv_i, pato_i, pclosing_net)
    REAL(KIND = wp), DIMENSION(:), INTENT(IN) :: pato_i, pclosing_net
    REAL(KIND = wp), DIMENSION(:, :), INTENT(IN) :: pa_i, pv_i
    INTEGER :: ji, jl
    REAL(KIND = wp) :: z1_gstar, z1_astar, zhmean, zfac
    REAL(KIND = wp), DIMENSION(jpij) :: zasum, z1_asum, zaksum
    REAL(KIND = wp), DIMENSION(jpij, jpl) :: zhi
    REAL(KIND = wp), DIMENSION(jpij, - 1 : jpl) :: zGsum
    z1_gstar = 1._wp / rn_gstar
    z1_astar = 1._wp / rn_astar
    WHERE (pa_i(1 : npti, :) > 0._wp)
      zhi(1 : npti, :) = pv_i(1 : npti, :) / pa_i(1 : npti, :)
    ELSEWHERE
      zhi(1 : npti, :) = 0._wp
    END WHERE
    zasum(1 : npti) = pato_i(1 : npti) + SUM(pa_i(1 : npti, :), dim = 2)
    WHERE (zasum(1 : npti) > 0._wp)
      z1_asum(1 : npti) = 1._wp / zasum(1 : npti)
    ELSEWHERE
      z1_asum(1 : npti) = 0._wp
    END WHERE
    !$ACC KERNELS
    zGsum(1 : npti, - 1) = 0._wp
    zGsum(1 : npti, 0) = pato_i(1 : npti) * z1_asum(1 : npti)
    !$ACC END KERNELS
    DO jl = 1, jpl
      zGsum(1 : npti, jl) = (pato_i(1 : npti) + SUM(pa_i(1 : npti, 1 : jl), dim = 2)) * z1_asum(1 : npti)
    END DO
    IF (ln_partf_lin) THEN
      !$ACC KERNELS
      DO jl = 0, jpl
        DO ji = 1, npti
          IF (zGsum(ji, jl) < rn_gstar) THEN
            apartf(ji, jl) = z1_gstar * (zGsum(ji, jl) - zGsum(ji, jl - 1)) * (2._wp - (zGsum(ji, jl - 1) + zGsum(ji, jl)) * z1_gstar)
          ELSE IF (zGsum(ji, jl - 1) < rn_gstar) THEN
            apartf(ji, jl) = z1_gstar * (rn_gstar - zGsum(ji, jl - 1)) * (2._wp - (zGsum(ji, jl - 1) + rn_gstar) * z1_gstar)
          ELSE
            apartf(ji, jl) = 0._wp
          END IF
        END DO
      END DO
      !$ACC END KERNELS
    ELSE IF (ln_partf_exp) THEN
      !$ACC KERNELS
      zfac = 1._wp / (1._wp - EXP(- z1_astar))
      DO jl = - 1, jpl
        DO ji = 1, npti
          zGsum(ji, jl) = EXP(- zGsum(ji, jl) * z1_astar) * zfac
        END DO
      END DO
      DO jl = 0, jpl
        DO ji = 1, npti
          apartf(ji, jl) = zGsum(ji, jl - 1) - zGsum(ji, jl)
        END DO
      END DO
      !$ACC END KERNELS
    END IF
    IF (ln_rafting .AND. ln_ridging) THEN
      DO jl = 1, jpl
        DO ji = 1, npti
          aridge(ji, jl) = (1._wp + TANH(rn_craft * (zhi(ji, jl) - rn_hraft))) * 0.5_wp * apartf(ji, jl)
          araft(ji, jl) = apartf(ji, jl) - aridge(ji, jl)
        END DO
      END DO
    ELSE IF (ln_ridging .AND. .NOT. ln_rafting) THEN
      !$ACC KERNELS
      DO jl = 1, jpl
        DO ji = 1, npti
          aridge(ji, jl) = apartf(ji, jl)
          araft(ji, jl) = 0._wp
        END DO
      END DO
      !$ACC END KERNELS
    ELSE IF (ln_rafting .AND. .NOT. ln_ridging) THEN
      !$ACC KERNELS
      DO jl = 1, jpl
        DO ji = 1, npti
          aridge(ji, jl) = 0._wp
          araft(ji, jl) = apartf(ji, jl)
        END DO
      END DO
      !$ACC END KERNELS
    ELSE
      !$ACC KERNELS
      DO jl = 1, jpl
        DO ji = 1, npti
          aridge(ji, jl) = 0._wp
          araft(ji, jl) = 0._wp
        END DO
      END DO
      !$ACC END KERNELS
    END IF
    zfac = 1._wp / hi_hrft
    zaksum(1 : npti) = apartf(1 : npti, 0)
    !$ACC KERNELS
    DO jl = 1, jpl
      DO ji = 1, npti
        IF (apartf(ji, jl) > 0._wp) THEN
          zhmean = MAX(SQRT(rn_hstar * zhi(ji, jl)), zhi(ji, jl) * hrdg_hi_min)
          hrmin(ji, jl) = MIN(2._wp * zhi(ji, jl), 0.5_wp * (zhmean + zhi(ji, jl)))
          hrmax(ji, jl) = 2._wp * zhmean - hrmin(ji, jl)
          hraft(ji, jl) = zhi(ji, jl) * zfac
          hi_hrdg(ji, jl) = zhi(ji, jl) / MAX(zhmean, epsi20)
          zaksum(ji) = zaksum(ji) + aridge(ji, jl) * (1._wp - hi_hrdg(ji, jl)) + araft(ji, jl) * (1._wp - hi_hrft)
        ELSE
          hrmin(ji, jl) = 0._wp
          hrmax(ji, jl) = 0._wp
          hraft(ji, jl) = 0._wp
          hi_hrdg(ji, jl) = 1._wp
        END IF
      END DO
    END DO
    !$ACC END KERNELS
    WHERE (zaksum(1 : npti) > 0._wp)
      closing_gross(1 : npti) = pclosing_net(1 : npti) / zaksum(1 : npti)
    ELSEWHERE
      closing_gross(1 : npti) = 0._wp
    END WHERE
    !$ACC KERNELS
    DO jl = 1, jpl
      DO ji = 1, npti
        zfac = apartf(ji, jl) * closing_gross(ji) * rdt_ice
        IF (zfac > pa_i(ji, jl)) THEN
          closing_gross(ji) = pa_i(ji, jl) / apartf(ji, jl) * r1_rdtice
        END IF
      END DO
    END DO
    DO ji = 1, npti
      zfac = pato_i(ji) + (opning(ji) - apartf(ji, 0) * closing_gross(ji)) * rdt_ice
      IF (zfac < 0._wp) THEN
        opning(ji) = apartf(ji, 0) * closing_gross(ji) - pato_i(ji) * r1_rdtice
      ELSE IF (zfac > zasum(ji)) THEN
        opning(ji) = apartf(ji, 0) * closing_gross(ji) + (zasum(ji) - pato_i(ji)) * r1_rdtice
      END IF
    END DO
    !$ACC END KERNELS
  END SUBROUTINE rdgrft_prep
  SUBROUTINE rdgrft_shift
    INTEGER :: ji, jj, jl, jl1, jl2, jk
    REAL(KIND = wp) :: hL, hR, farea
    REAL(KIND = wp) :: vsw
    REAL(KIND = wp) :: afrdg, afrft
    REAL(KIND = wp) :: airdg1, oirdg1, aprdg1, virdg1, sirdg1
    REAL(KIND = wp) :: airft1, oirft1, aprft1
    REAL(KIND = wp), DIMENSION(jpij) :: airdg2, oirdg2, aprdg2, virdg2, sirdg2, vsrdg, vprdg
    REAL(KIND = wp), DIMENSION(jpij) :: airft2, oirft2, aprft2, virft, sirft, vsrft, vprft
    REAL(KIND = wp), DIMENSION(jpij) :: ersw
    REAL(KIND = wp), DIMENSION(jpij) :: zswitch, fvol
    REAL(KIND = wp), DIMENSION(jpij) :: z1_ai
    REAL(KIND = wp), DIMENSION(jpij, nlay_s) :: esrft
    REAL(KIND = wp), DIMENSION(jpij, nlay_i) :: eirft
    REAL(KIND = wp), DIMENSION(jpij, nlay_s) :: esrdg
    REAL(KIND = wp), DIMENSION(jpij, nlay_i) :: eirdg
    INTEGER, DIMENSION(jpij) :: itest_rdg, itest_rft
    !$ACC KERNELS
    DO ji = 1, npti
      ato_i_1d(ji) = MAX(0._wp, ato_i_1d(ji) + (opning(ji) - apartf(ji, 0) * closing_gross(ji)) * rdt_ice)
    END DO
    !$ACC END KERNELS
    DO jl1 = 1, jpl
      CALL tab_2d_1d(npti, nptidx(1 : npti), s_i_1d(1 : npti), s_i(:, :, jl1))
      !$ACC KERNELS
      DO ji = 1, npti
        IF (apartf(ji, jl1) > 0._wp .AND. closing_gross(ji) > 0._wp) THEN
          z1_ai(ji) = 1._wp / a_i_2d(ji, jl1)
          airdg1 = aridge(ji, jl1) * closing_gross(ji) * rdt_ice
          airft1 = araft(ji, jl1) * closing_gross(ji) * rdt_ice
          airdg2(ji) = airdg1 * hi_hrdg(ji, jl1)
          airft2(ji) = airft1 * hi_hrft
          afrdg = airdg1 * z1_ai(ji)
          afrft = airft1 * z1_ai(ji)
          vsw = v_i_2d(ji, jl1) * afrdg * rn_porordg
          ersw(ji) = - rhoi * vsw * rcp * sst_1d(ji)
          virdg1 = v_i_2d(ji, jl1) * afrdg
          virdg2(ji) = v_i_2d(ji, jl1) * afrdg * (1. + rn_porordg)
          vsrdg(ji) = v_s_2d(ji, jl1) * afrdg
          sirdg1 = sv_i_2d(ji, jl1) * afrdg
          sirdg2(ji) = sv_i_2d(ji, jl1) * afrdg + vsw * sss_1d(ji)
          oirdg1 = oa_i_2d(ji, jl1) * afrdg
          oirdg2(ji) = oa_i_2d(ji, jl1) * afrdg * hi_hrdg(ji, jl1)
          virft(ji) = v_i_2d(ji, jl1) * afrft
          vsrft(ji) = v_s_2d(ji, jl1) * afrft
          sirft(ji) = sv_i_2d(ji, jl1) * afrft
          oirft1 = oa_i_2d(ji, jl1) * afrft
          oirft2(ji) = oa_i_2d(ji, jl1) * afrft * hi_hrft
          IF (ln_pnd_H12) THEN
            aprdg1 = a_ip_2d(ji, jl1) * afrdg
            aprdg2(ji) = a_ip_2d(ji, jl1) * afrdg * hi_hrdg(ji, jl1)
            vprdg(ji) = v_ip_2d(ji, jl1) * afrdg
            aprft1 = a_ip_2d(ji, jl1) * afrft
            aprft2(ji) = a_ip_2d(ji, jl1) * afrft * hi_hrft
            vprft(ji) = v_ip_2d(ji, jl1) * afrft
          END IF
          wfx_dyn_1d(ji) = wfx_dyn_1d(ji) - vsw * rhoi * r1_rdtice
          sfx_dyn_1d(ji) = sfx_dyn_1d(ji) - vsw * sss_1d(ji) * rhoi * r1_rdtice
          hfx_dyn_1d(ji) = hfx_dyn_1d(ji) + ersw(ji) * r1_rdtice
          wfx_snw_dyn_1d(ji) = wfx_snw_dyn_1d(ji) + (rhos * vsrdg(ji) * (1._wp - rn_fsnwrdg) + rhos * vsrft(ji) * (1._wp - rn_fsnwrft)) * r1_rdtice
          IF (nn_icesal /= 2) THEN
            sirdg2(ji) = sirdg2(ji) - vsw * (sss_1d(ji) - s_i_1d(ji))
            sfx_bri_1d(ji) = sfx_bri_1d(ji) + sss_1d(ji) * vsw * rhoi * r1_rdtice - s_i_1d(ji) * vsw * rhoi * r1_rdtice
          END IF
          a_i_2d(ji, jl1) = a_i_2d(ji, jl1) - airdg1 - airft1
          v_i_2d(ji, jl1) = v_i_2d(ji, jl1) - virdg1 - virft(ji)
          v_s_2d(ji, jl1) = v_s_2d(ji, jl1) - vsrdg(ji) - vsrft(ji)
          sv_i_2d(ji, jl1) = sv_i_2d(ji, jl1) - sirdg1 - sirft(ji)
          oa_i_2d(ji, jl1) = oa_i_2d(ji, jl1) - oirdg1 - oirft1
          IF (ln_pnd_H12) THEN
            a_ip_2d(ji, jl1) = a_ip_2d(ji, jl1) - aprdg1 - aprft1
            v_ip_2d(ji, jl1) = v_ip_2d(ji, jl1) - vprdg(ji) - vprft(ji)
          END IF
        END IF
      END DO
      DO jk = 1, nlay_s
        DO ji = 1, npti
          IF (apartf(ji, jl1) > 0._wp .AND. closing_gross(ji) > 0._wp) THEN
            afrdg = aridge(ji, jl1) * closing_gross(ji) * rdt_ice * z1_ai(ji)
            afrft = araft(ji, jl1) * closing_gross(ji) * rdt_ice * z1_ai(ji)
            esrdg(ji, jk) = ze_s_2d(ji, jk, jl1) * afrdg
            esrft(ji, jk) = ze_s_2d(ji, jk, jl1) * afrft
            hfx_dyn_1d(ji) = hfx_dyn_1d(ji) + (- esrdg(ji, jk) * (1._wp - rn_fsnwrdg) - esrft(ji, jk) * (1._wp - rn_fsnwrft)) * r1_rdtice
            ze_s_2d(ji, jk, jl1) = ze_s_2d(ji, jk, jl1) * (1._wp - afrdg - afrft)
          END IF
        END DO
      END DO
      DO jk = 1, nlay_i
        DO ji = 1, npti
          IF (apartf(ji, jl1) > 0._wp .AND. closing_gross(ji) > 0._wp) THEN
            afrdg = aridge(ji, jl1) * closing_gross(ji) * rdt_ice * z1_ai(ji)
            afrft = araft(ji, jl1) * closing_gross(ji) * rdt_ice * z1_ai(ji)
            eirdg(ji, jk) = ze_i_2d(ji, jk, jl1) * afrdg + ersw(ji) * r1_nlay_i
            eirft(ji, jk) = ze_i_2d(ji, jk, jl1) * afrft
            ze_i_2d(ji, jk, jl1) = ze_i_2d(ji, jk, jl1) * (1._wp - afrdg - afrft)
          END IF
        END DO
      END DO
      !$ACC END KERNELS
      itest_rdg(1 : npti) = 0
      itest_rft(1 : npti) = 0
      !$ACC KERNELS
      DO jl2 = 1, jpl
        DO ji = 1, npti
          IF (apartf(ji, jl1) > 0._wp .AND. closing_gross(ji) > 0._wp) THEN
            IF (hrmin(ji, jl1) <= hi_max(jl2) .AND. hrmax(ji, jl1) > hi_max(jl2 - 1)) THEN
              hL = MAX(hrmin(ji, jl1), hi_max(jl2 - 1))
              hR = MIN(hrmax(ji, jl1), hi_max(jl2))
              farea = (hR - hL) / (hrmax(ji, jl1) - hrmin(ji, jl1))
              fvol(ji) = (hR * hR - hL * hL) / (hrmax(ji, jl1) * hrmax(ji, jl1) - hrmin(ji, jl1) * hrmin(ji, jl1))
              itest_rdg(ji) = 1
            ELSE
              farea = 0._wp
              fvol(ji) = 0._wp
            END IF
            IF (hraft(ji, jl1) <= hi_max(jl2) .AND. hraft(ji, jl1) > hi_max(jl2 - 1)) THEN
              zswitch(ji) = 1._wp
              itest_rft(ji) = 1
            ELSE
              zswitch(ji) = 0._wp
            END IF
            IF (itest_rdg(ji) == 0 .AND. jl2 == jpl) THEN
              farea = 1._wp
              fvol(ji) = 1._wp
            END IF
            IF (itest_rft(ji) == 0 .AND. jl2 == jpl) zswitch(ji) = 1._wp
            a_i_2d(ji, jl2) = a_i_2d(ji, jl2) + (airdg2(ji) * farea + airft2(ji) * zswitch(ji))
            oa_i_2d(ji, jl2) = oa_i_2d(ji, jl2) + (oirdg2(ji) * farea + oirft2(ji) * zswitch(ji))
            v_i_2d(ji, jl2) = v_i_2d(ji, jl2) + (virdg2(ji) * fvol(ji) + virft(ji) * zswitch(ji))
            sv_i_2d(ji, jl2) = sv_i_2d(ji, jl2) + (sirdg2(ji) * fvol(ji) + sirft(ji) * zswitch(ji))
            v_s_2d(ji, jl2) = v_s_2d(ji, jl2) + (vsrdg(ji) * rn_fsnwrdg * fvol(ji) + vsrft(ji) * rn_fsnwrft * zswitch(ji))
            IF (ln_pnd_H12) THEN
              v_ip_2d(ji, jl2) = v_ip_2d(ji, jl2) + (vprdg(ji) * rn_fpndrdg * fvol(ji) + vprft(ji) * rn_fpndrft * zswitch(ji))
              a_ip_2d(ji, jl2) = a_ip_2d(ji, jl2) + (aprdg2(ji) * rn_fpndrdg * farea + aprft2(ji) * rn_fpndrft * zswitch(ji))
            END IF
          END IF
        END DO
        DO jk = 1, nlay_s
          DO ji = 1, npti
            IF (apartf(ji, jl1) > 0._wp .AND. closing_gross(ji) > 0._wp) ze_s_2d(ji, jk, jl2) = ze_s_2d(ji, jk, jl2) + (esrdg(ji, jk) * rn_fsnwrdg * fvol(ji) + esrft(ji, jk) * rn_fsnwrft * zswitch(ji))
          END DO
        END DO
        DO jk = 1, nlay_i
          DO ji = 1, npti
            IF (apartf(ji, jl1) > 0._wp .AND. closing_gross(ji) > 0._wp) ze_i_2d(ji, jk, jl2) = ze_i_2d(ji, jk, jl2) + eirdg(ji, jk) * fvol(ji) + eirft(ji, jk) * zswitch(ji)
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    END DO
    WHERE (a_i_2d(1 : npti, :) < 0._wp) a_i_2d(1 : npti, :) = 0._wp
    WHERE (v_i_2d(1 : npti, :) < 0._wp) v_i_2d(1 : npti, :) = 0._wp
  END SUBROUTINE rdgrft_shift
  SUBROUTINE ice_strength
    INTEGER :: ji, jj, jl
    INTEGER :: ismooth
    INTEGER :: itframe
    REAL(KIND = wp) :: zp, z1_3
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zworka
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zstrp1, zstrp2
    IF (ln_str_H79) THEN
      strength(:, :) = rn_pstar * SUM(v_i(:, :, :), dim = 3) * EXP(- rn_crhg * (1._wp - SUM(a_i(:, :, :), dim = 3)))
      ismooth = 1
    ELSE
      !$ACC KERNELS
      strength(:, :) = 0._wp
      ismooth = 0
      !$ACC END KERNELS
    END IF
    SELECT CASE (ismooth)
    CASE (1)
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          IF (SUM(a_i(ji, jj, :)) > 0._wp) THEN
            zworka(ji, jj) = (4.0 * strength(ji, jj) + strength(ji - 1, jj) * tmask(ji - 1, jj, 1) + strength(ji + 1, jj) * tmask(ji + 1, jj, 1) + strength(ji, jj - 1) * tmask(ji, jj - 1, 1) + strength(ji, jj + 1) * tmask(ji, jj + 1, 1)) / (4.0 + tmask(ji - 1, jj, 1) + tmask(ji + 1, jj, 1) + tmask(ji, jj - 1, 1) + tmask(ji, jj + 1, 1))
          ELSE
            zworka(ji, jj) = 0._wp
          END IF
        END DO
      END DO
      !$ACC KERNELS
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          strength(ji, jj) = zworka(ji, jj)
        END DO
      END DO
      !$ACC END KERNELS
      CALL lbc_lnk(strength, 'T', 1.)
    CASE (2)
      IF (kt_ice == nit000) THEN
        !$ACC KERNELS
        zstrp1(:, :) = 0._wp
        zstrp2(:, :) = 0._wp
        !$ACC END KERNELS
      END IF
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          IF (SUM(a_i(ji, jj, :)) > 0._wp) THEN
            itframe = 1
            IF (zstrp1(ji, jj) > 0._wp) itframe = itframe + 1
            IF (zstrp2(ji, jj) > 0._wp) itframe = itframe + 1
            zp = (strength(ji, jj) + zstrp1(ji, jj) + zstrp2(ji, jj)) / itframe
            zstrp2(ji, jj) = zstrp1(ji, jj)
            zstrp1(ji, jj) = strength(ji, jj)
            strength(ji, jj) = zp
          END IF
        END DO
      END DO
      CALL lbc_lnk(strength, 'T', 1.)
    END SELECT
  END SUBROUTINE ice_strength
  SUBROUTINE ice_dyn_1d2d(kn)
    INTEGER, INTENT(IN) :: kn
    INTEGER :: jl, jk
    SELECT CASE (kn)
    CASE (1)
      CALL tab_2d_1d(npti, nptidx(1 : npti), sss_1d(1 : npti), sss_m(:, :))
      CALL tab_2d_1d(npti, nptidx(1 : npti), sst_1d(1 : npti), sst_m(:, :))
      CALL tab_3d_2d(npti, nptidx(1 : npti), v_s_2d(1 : npti, 1 : jpl), v_s(:, :, :))
      CALL tab_3d_2d(npti, nptidx(1 : npti), sv_i_2d(1 : npti, 1 : jpl), sv_i(:, :, :))
      CALL tab_3d_2d(npti, nptidx(1 : npti), oa_i_2d(1 : npti, 1 : jpl), oa_i(:, :, :))
      CALL tab_3d_2d(npti, nptidx(1 : npti), a_ip_2d(1 : npti, 1 : jpl), a_ip(:, :, :))
      CALL tab_3d_2d(npti, nptidx(1 : npti), v_ip_2d(1 : npti, 1 : jpl), v_ip(:, :, :))
      DO jl = 1, jpl
        DO jk = 1, nlay_s
          CALL tab_2d_1d(npti, nptidx(1 : npti), ze_s_2d(1 : npti, jk, jl), e_s(:, :, jk, jl))
        END DO
        DO jk = 1, nlay_i
          CALL tab_2d_1d(npti, nptidx(1 : npti), ze_i_2d(1 : npti, jk, jl), e_i(:, :, jk, jl))
        END DO
      END DO
      CALL tab_2d_1d(npti, nptidx(1 : npti), sfx_dyn_1d(1 : npti), sfx_dyn(:, :))
      CALL tab_2d_1d(npti, nptidx(1 : npti), sfx_bri_1d(1 : npti), sfx_bri(:, :))
      CALL tab_2d_1d(npti, nptidx(1 : npti), wfx_dyn_1d(1 : npti), wfx_dyn(:, :))
      CALL tab_2d_1d(npti, nptidx(1 : npti), hfx_dyn_1d(1 : npti), hfx_dyn(:, :))
      CALL tab_2d_1d(npti, nptidx(1 : npti), wfx_snw_dyn_1d(1 : npti), wfx_snw_dyn(:, :))
      CALL tab_2d_1d(npti, nptidx(1 : npti), wfx_pnd_1d(1 : npti), wfx_pnd(:, :))
    CASE (2)
      CALL tab_1d_2d(npti, nptidx(1 : npti), ato_i_1d(1 : npti), ato_i(:, :))
      CALL tab_2d_3d(npti, nptidx(1 : npti), a_i_2d(1 : npti, 1 : jpl), a_i(:, :, :))
      CALL tab_2d_3d(npti, nptidx(1 : npti), v_i_2d(1 : npti, 1 : jpl), v_i(:, :, :))
      CALL tab_2d_3d(npti, nptidx(1 : npti), v_s_2d(1 : npti, 1 : jpl), v_s(:, :, :))
      CALL tab_2d_3d(npti, nptidx(1 : npti), sv_i_2d(1 : npti, 1 : jpl), sv_i(:, :, :))
      CALL tab_2d_3d(npti, nptidx(1 : npti), oa_i_2d(1 : npti, 1 : jpl), oa_i(:, :, :))
      CALL tab_2d_3d(npti, nptidx(1 : npti), a_ip_2d(1 : npti, 1 : jpl), a_ip(:, :, :))
      CALL tab_2d_3d(npti, nptidx(1 : npti), v_ip_2d(1 : npti, 1 : jpl), v_ip(:, :, :))
      DO jl = 1, jpl
        DO jk = 1, nlay_s
          CALL tab_1d_2d(npti, nptidx(1 : npti), ze_s_2d(1 : npti, jk, jl), e_s(:, :, jk, jl))
        END DO
        DO jk = 1, nlay_i
          CALL tab_1d_2d(npti, nptidx(1 : npti), ze_i_2d(1 : npti, jk, jl), e_i(:, :, jk, jl))
        END DO
      END DO
      CALL tab_1d_2d(npti, nptidx(1 : npti), sfx_dyn_1d(1 : npti), sfx_dyn(:, :))
      CALL tab_1d_2d(npti, nptidx(1 : npti), sfx_bri_1d(1 : npti), sfx_bri(:, :))
      CALL tab_1d_2d(npti, nptidx(1 : npti), wfx_dyn_1d(1 : npti), wfx_dyn(:, :))
      CALL tab_1d_2d(npti, nptidx(1 : npti), hfx_dyn_1d(1 : npti), hfx_dyn(:, :))
      CALL tab_1d_2d(npti, nptidx(1 : npti), wfx_snw_dyn_1d(1 : npti), wfx_snw_dyn(:, :))
      CALL tab_1d_2d(npti, nptidx(1 : npti), wfx_pnd_1d(1 : npti), wfx_pnd(:, :))
    END SELECT
  END SUBROUTINE ice_dyn_1d2d
  SUBROUTINE ice_dyn_rdgrft_init
    INTEGER :: ios
    NAMELIST /namdyn_rdgrft/ ln_str_H79, rn_pstar, rn_crhg, rn_csrdg, ln_partf_lin, rn_gstar, ln_partf_exp, rn_astar, ln_ridging, rn_hstar, rn_porordg, rn_fsnwrdg, rn_fpndrdg, ln_rafting, rn_hraft, rn_craft, rn_fsnwrft, rn_fpndrft
    REWIND(UNIT = numnam_ice_ref)
    READ(numnam_ice_ref, namdyn_rdgrft, IOSTAT = ios, ERR = 901)
901 IF (ios /= 0) CALL ctl_nam(ios, 'namdyn_rdgrft in reference namelist', lwp)
    REWIND(UNIT = numnam_ice_cfg)
    READ(numnam_ice_cfg, namdyn_rdgrft, IOSTAT = ios, ERR = 902)
902 IF (ios > 0) CALL ctl_nam(ios, 'namdyn_rdgrft in configuration namelist', lwp)
    IF (lwm) WRITE(numoni, namdyn_rdgrft)
    IF (lwp) THEN
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) 'ice_dyn_rdgrft_init: ice parameters for ridging/rafting '
      WRITE(numout, FMT = *) '~~~~~~~~~~~~~~~~~~'
      WRITE(numout, FMT = *) '   Namelist namdyn_rdgrft:'
      WRITE(numout, FMT = *) '      ice strength parameterization Hibler (1979)              ln_str_H79   = ', ln_str_H79
      WRITE(numout, FMT = *) '            1st bulk-rheology parameter                        rn_pstar     = ', rn_pstar
      WRITE(numout, FMT = *) '            2nd bulk-rhelogy parameter                         rn_crhg      = ', rn_crhg
      WRITE(numout, FMT = *) '      Fraction of shear energy contributing to ridging         rn_csrdg     = ', rn_csrdg
      WRITE(numout, FMT = *) '      linear ridging participation function                    ln_partf_lin = ', ln_partf_lin
      WRITE(numout, FMT = *) '            Fraction of ice coverage contributing to ridging   rn_gstar     = ', rn_gstar
      WRITE(numout, FMT = *) '      Exponential ridging participation function               ln_partf_exp = ', ln_partf_exp
      WRITE(numout, FMT = *) '            Equivalent to G* for an exponential function       rn_astar     = ', rn_astar
      WRITE(numout, FMT = *) '      Ridging of ice sheets or not                             ln_ridging   = ', ln_ridging
      WRITE(numout, FMT = *) '            max ridged ice thickness                           rn_hstar     = ', rn_hstar
      WRITE(numout, FMT = *) '            Initial porosity of ridges                         rn_porordg   = ', rn_porordg
      WRITE(numout, FMT = *) '            Fraction of snow volume conserved during ridging   rn_fsnwrdg   = ', rn_fsnwrdg
      WRITE(numout, FMT = *) '            Fraction of pond volume conserved during ridging   rn_fpndrdg   = ', rn_fpndrdg
      WRITE(numout, FMT = *) '      Rafting of ice sheets or not                             ln_rafting   = ', ln_rafting
      WRITE(numout, FMT = *) '            Parmeter thickness (threshold between ridge-raft)  rn_hraft     = ', rn_hraft
      WRITE(numout, FMT = *) '            Rafting hyperbolic tangent coefficient             rn_craft     = ', rn_craft
      WRITE(numout, FMT = *) '            Fraction of snow volume conserved during rafting   rn_fsnwrft   = ', rn_fsnwrft
      WRITE(numout, FMT = *) '            Fraction of pond volume conserved during rafting   rn_fpndrft   = ', rn_fpndrft
    END IF
    IF ((ln_partf_lin .AND. ln_partf_exp) .OR. (.NOT. ln_partf_lin .AND. .NOT. ln_partf_exp)) THEN
      CALL ctl_stop('ice_dyn_rdgrft_init: choose one and only one participation function (ln_partf_lin or ln_partf_exp)')
    END IF
    IF (ice_dyn_rdgrft_alloc() /= 0) CALL ctl_stop('STOP', 'ice_dyn_rdgrft_init: unable to allocate arrays')
  END SUBROUTINE ice_dyn_rdgrft_init
END MODULE icedyn_rdgrft


!-------------------------------------------------------------------------------
! Copyright (c) 2016 The University of Tokyo
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
! If new header is supported, change according to following method.    !
!  1) Increase FSTR_CTRL_HEADER_NUMBER                                 !
!  2) Add new header name to fstr_ctrl_header_names                    !
!  3) Describe new function to get parameters from control file        !
!     in fstr_ctrl.f90                                                 !
!  4) Describe new subroutine to set values of the parameter           !
!     in fstr_setup.f90                                                !
!  5) If initial values are necessary, set the value                   !
!     in subroutine fstr_setup_init in fstr_setup.f90                  !
!> This module defined coomon data and basic structures for analysis
module m_fstr
  use hecmw
  use m_common_struct
  use m_step
  use m_out
  use m_timepoint
  use mMechGauss
  use mContactDef

  implicit none

  public

  !> CONSTANTS
  !> general
  integer(kind=kint), parameter :: kYES = 1
  integer(kind=kint), parameter :: kNO  = 0
  integer(kind=kint), parameter :: kON  = 1
  integer(kind=kint), parameter :: kOFF = 0

  !> solution type (st)
  integer(kind=kint), parameter :: kstPRECHECK = 0
  integer(kind=kint), parameter :: kstSTATIC   = 1
  integer(kind=kint), parameter :: kstEIGEN    = 2
  integer(kind=kint), parameter :: kstHEAT     = 3
  integer(kind=kint), parameter :: kstDYNAMIC  = 4
  !integer(kind=kint), parameter :: kstNLSTATIC  =   5
  integer(kind=kint), parameter :: kstSTATICEIGEN = 6
  integer(kind=kint), parameter :: kstNZPROF      = 7

  !> solver method (sm)    !CAUTION : (<=100):indirect, (>100):direct
  integer(kind=kint), parameter :: ksmCG       = 1
  integer(kind=kint), parameter :: ksmBiCGSTAB = 2
  integer(kind=kint), parameter :: ksmGMRES    = 3
  integer(kind=kint), parameter :: ksmGPBiCG   = 4
  integer(kind=kint), parameter :: ksmDIRECT   = 101

  !> contact analysis algorithm
  integer(kind=kint), parameter :: kcaSLagrange = 1
  integer(kind=kint), parameter :: kcaALagrange = 2

  !> boundary condition file type (bcf)
  integer(kind=kint), parameter :: kbcfFSTR     =   0  ! BC described in fstr control file (default)
  integer(kind=kint), parameter :: kbcfNASTRAN  =   1  ! nastran file

  integer(kind=kint), parameter :: kbcInitial   =  1
  integer(kind=kint), parameter :: kbcTransit   =  2

  !> restart type
  integer(kind=kint), parameter :: restart_outLast = 1
  integer(kind=kint), parameter :: restart_outAll  = 2

  !> section control
  integer(kind=kint), parameter :: kel361FI     =  1
  integer(kind=kint), parameter :: kel361BBAR   =  2
  integer(kind=kint), parameter :: kel361IC     =  3
  integer(kind=kint), parameter :: kel361FBAR   =  4

  integer(kind=kint), parameter :: kFLOADTYPE_NODE = 1
  integer(kind=kint), parameter :: kFLOADTYPE_SURF = 2

  integer(kind=kint), parameter :: kFLOADCASE_RE = 1
  integer(kind=kint), parameter :: kFLOADCASE_IM = 2

  !> PARALLEL EXECUTION
  integer(kind = kint) :: myrank
  integer(kind = kint) :: nprocs

  !> PARALLEL CONTACT FLAG
  logical :: paraContactFlag = .false.

  !> FILE NAME
  character(len=HECMW_FILENAME_LEN) :: cntfilNAME
  character(len=HECMW_FILENAME_LEN) :: restartfilNAME

  !> FILE HANDLER
  integer(kind=kint), parameter :: ILOG = 16 ! log
  integer(kind=kint), parameter :: ISTA = 17 ! status
  integer(kind=kint), parameter :: IUTB = 18 ! utable
  integer(kind=kint), parameter :: IMSG = 51 ! message (myrank == 0 only)
  integer(kind=kint), parameter :: IDBG = 52 ! debug
  integer(kind=kint), parameter :: IFVS = 53 ! visual.ini file
  integer(kind=kint), parameter :: INEU = 54 ! neutral file (heat)
  integer(kind=kint), parameter :: IRESOUT = 100 ! ~110, keeping for result output file

  !> SOLVER CONTROL
  integer(kind=kint) :: svIarray(100)
  real(kind=kreal)   :: svRarray(100)

  !> FLAG for ECHO/RESULT/POST
  integer(kind=kint), pointer :: IECHO
  integer(kind=kint), pointer :: IRESULT
  integer(kind=kint), pointer :: IVISUAL
  integer(kind=kint), pointer :: INEUTRAL  ! flag for femap neutral file
  integer(kind=kint), pointer :: IRRES     ! flag for restart, read
  integer(kind=kint), pointer :: IWRES     ! flag for restart, write
  integer(kind=kint), pointer :: NRRES     ! position of restart read
  integer(kind=kint), pointer :: NPRINT    ! interval of write

  integer(kind=kint), parameter :: kOPSS_SOLUTION = 1
  integer(kind=kint), parameter :: kOPSS_MATERIAL = 2
  integer(kind=kint)            :: OPSSTYPE = kOPSS_SOLUTION ! output stress/strain type

  !> REFTEMP
  real(kind=kreal), pointer :: REF_TEMP

  !> ANALYSIS CONTROL for NLGEOM and HEAT
  real(kind=kreal)   :: DT    ! /=fstr_param%dtime
  real(kind=kreal)   :: ETIME ! /=fstr_param%etime
  integer(kind=kint) :: ITMAX
  real(kind=kreal)   :: EPS   ! /=fstr_param%eps
  real(kind=kreal)   :: TEMTOL

  !>  FSTR INNER CONTROL PARAMETERS  (fstrPARAM)
  type fstr_param
    integer(kind=kint) :: solution_type !< solution type number
    integer(kind=kint) :: solver_method !< solver method number
    logical            :: nlgeom        !< is geometrical nonlinearity considered

    !> STATIC !HEAT
    integer(kind=kint) :: analysis_n      !< Number of analysis
    real(kind=kreal), pointer  :: dtime(:) !< (=DT)    STEP_DLTIME
    real(kind=kreal), pointer  :: etime(:) !< (/=ETIME) STEP_EETIME
    real(kind=kreal), pointer  :: dtmin(:) !< (=DTMIN) STEP_DELMIN
    real(kind=kreal), pointer  :: delmax(:)!< (=DTMAX) STEP_DELMAX
    integer(kind=kint), pointer:: itmax(:) !< (/=ITMAX)
    real(kind=kreal), pointer  :: eps(:)   !< (/=ESP)
    real(kind=kreal)           :: ref_temp !< (=REF_TEMP)

    !> output control
    integer(kind=kint) :: fg_echo       !< output echo   (kYES/kNO) (=IECHO)
    integer(kind=kint) :: fg_result     !< output result (kYES/kNO) (=IRESULT)
    integer(kind=kint) :: fg_visual     !< visualization (kYES/kNO) (=IVISUAL)

    !> for heat ...
    integer(kind=kint) :: fg_neutral    !< write by neutral (=INEUTRAL)
    integer(kind=kint) :: fg_irres      !< restart read     (=IRRES)
    integer(kind=kint) :: fg_iwres      !< restart write    (=IWRES)
    integer(kind=kint) :: nrres         !< NRRES
    integer(kind=kint) :: nprint        !< NPRINT

    !> index table for global node ID sorting
    integer(kind=kint) :: n_node        !< hecMESH%n_node
    integer(kind=kint) :: nn_internal   !< hecMESH%nn_internal
    integer(kind=kint), pointer :: global_local_ID(:,:)  !> (2:nn_internal) (1,:):global, (2,:):local

    !> for couple analysis
    integer( kind=kint ) :: fg_couple          !< (default:0)
    integer( kind=kint ) :: fg_couple_type     !< (default:0)
    integer( kind=kint ) :: fg_couple_first    !< (default:0)
    integer( kind=kint ) :: fg_couple_window   !< (default:0)

    !> for restart control
    integer( kind=kint ) :: restart_out_type   !< output type of restart file
    integer( kind=kint ) :: restart_version    !< version of restart file

    !> for contact analysis
    integer( kind=kint ) :: contact_algo       !< contact analysis algorithm number(SLagrange or Alagrange)

    !> for auto increment and cutback
    type(tParamAutoInc), pointer :: ainc(:)        !< auto increment control
    type(time_points), pointer :: timepoints(:)  !< time points data
  end type fstr_param

  !> GLOBAL VARIABLE INITIALIZED IN FSTR_SETUP
  type( fstr_param ),target :: fstrPR

  !> Data for STATIC ANSLYSIS  (fstrSOLID)
  type fstr_solid_physic_val
    real(kind=kreal), pointer :: STRESS(:)    !< nodal stress
    real(kind=kreal), pointer :: STRAIN(:)    !< nodal strain
    real(kind=kreal), pointer :: MISES(:)    !< nodal MISES

    real(kind=kreal), pointer :: PSTRESS(:)   !< nodal principal stress
    real(kind=kreal), pointer :: PSTRAIN(:)   !< nodal principal strain
    real(kind=kreal), pointer :: PSTRESS_VECT(:,:)   !< nodal principal stress vector
    real(kind=kreal), pointer :: PSTRAIN_VECT(:,:)   !< nodal principal strain vector

    real(kind=kreal), pointer :: ESTRESS(:)   !< elemental stress
    real(kind=kreal), pointer :: ESTRAIN(:)   !< elemental strain
    real(kind=kreal), pointer :: EMISES(:)    !< elemental MISES

    real(kind=kreal), pointer :: EPSTRESS(:)   !< elemental principal stress
    real(kind=kreal), pointer :: EPSTRAIN(:)   !< elemental principal strain
    real(kind=kreal), pointer :: EPSTRESS_VECT(:,:)   !< elemental principal stress vector
    real(kind=kreal), pointer :: EPSTRAIN_VECT(:,:)   !< elemental principal strain vector
    real(kind=kreal), pointer :: ENQM(:)      !< elemental NQM

    type(fstr_solid_physic_val), pointer :: LAYER(:)    !< Laminated Shell's layer (1,2,3,4,5,...)
    type(fstr_solid_physic_val), pointer :: PLUS    !< for SHELL PLUS
    type(fstr_solid_physic_val), pointer :: MINUS    !< for SHELL MINUS
  end type fstr_solid_physic_val

  type fstr_solid
    integer(kind=kint) :: file_type  ! kbcfFSTR or kbcfNASTRAN
    integer(kind=kint) :: StaticType ! 1:Total, 2:Updated, 3:Infinite
    integer(kind=kint) :: nstep_tot

    type(step_info), pointer       :: step_ctrl(:)  =>null()   !< step information
    type(t_output_ctrl),  pointer  :: output_ctrl(:)=>null()   !< output  information

    !> BOUNDARY
    integer(kind=kint) :: BOUNDARY_ngrp_tot                    !< Following boundary conditions
    integer(kind=kint), pointer :: BOUNDARY_ngrp_GRPID  (:)  =>null()
    integer(kind=kint), pointer :: BOUNDARY_ngrp_ID     (:)  =>null()
    integer(kind=kint), pointer :: BOUNDARY_ngrp_type   (:)  =>null()
    integer(kind=kint), pointer :: BOUNDARY_ngrp_amp    (:)  =>null()
    real(kind=kreal), pointer   :: BOUNDARY_ngrp_val    (:)  =>null()
    integer(kind=kint) :: BOUNDARY_ngrp_rot                   !< number of rotational boundary conditions
    integer(kind=kint), pointer :: BOUNDARY_ngrp_rotID     (:) =>null()
    integer(kind=kint), pointer :: BOUNDARY_ngrp_centerID  (:) =>null()

    !> VELOCITY
    integer(kind=kint) :: VELOCITY_type
    integer(kind=kint) :: VELOCITY_ngrp_tot                    !< Following velocity boundary condition
    integer(kind=kint), pointer :: VELOCITY_ngrp_GRPID  (:)  =>null()
    integer(kind=kint), pointer :: VELOCITY_ngrp_ID     (:)  =>null()
    integer(kind=kint), pointer :: VELOCITY_ngrp_type   (:)  =>null()
    integer(kind=kint), pointer :: VELOCITY_ngrp_amp    (:)  =>null()
    real(kind=kreal), pointer   :: VELOCITY_ngrp_val    (:)  =>null()

    !> ACCELERATION
    integer(kind=kint) :: ACCELERATION_type
    integer(kind=kint) :: ACCELERATION_ngrp_tot                !< Following accelerate boundary condition
    integer(kind=kint), pointer :: ACCELERATION_ngrp_GRPID  (:)  =>null()
    integer(kind=kint), pointer :: ACCELERATION_ngrp_ID     (:)  =>null()
    integer(kind=kint), pointer :: ACCELERATION_ngrp_type   (:)  =>null()
    integer(kind=kint), pointer :: ACCELERATION_ngrp_amp    (:)  =>null()
    real(kind=kreal), pointer   :: ACCELERATION_ngrp_val    (:)  =>null()

    !> CLOAD
    integer(kind=kint) :: CLOAD_ngrp_tot                       !< Following concetrated external load
    integer(kind=kint), pointer :: CLOAD_ngrp_GRPID     (:) =>null()
    integer(kind=kint), pointer :: CLOAD_ngrp_ID        (:)
    integer(kind=kint), pointer :: CLOAD_ngrp_DOF       (:)
    integer(kind=kint), pointer :: CLOAD_ngrp_amp       (:)
    real(kind=kreal), pointer   :: CLOAD_ngrp_val       (:)
    integer(kind=kint) :: CLOAD_ngrp_rot                   !< number of torque load conditions
    integer(kind=kint), pointer :: CLOAD_ngrp_rotID     (:) =>null()
    integer(kind=kint), pointer :: CLOAD_ngrp_centerID  (:) =>null()

    !> DLOAD
    integer(kind=kint) :: DLOAD_ngrp_tot                       !< Following distrubuted external load
    integer(kind=kint) :: DLOAD_follow
    integer(kind=kint), pointer :: DLOAD_ngrp_GRPID     (:) =>null()
    integer(kind=kint), pointer :: DLOAD_ngrp_ID        (:)
    integer(kind=kint), pointer :: DLOAD_ngrp_LID       (:)
    integer(kind=kint), pointer :: DLOAD_ngrp_amp       (:)
    real(kind=kreal), pointer   :: DLOAD_ngrp_params    (:,:)

    !> TEMPERATURE
    integer(kind=kint) :: TEMP_ngrp_tot                        !< Following tempearture conditions
    integer(kind=kint) :: TEMP_irres
    integer(kind=kint) :: TEMP_tstep
    integer(kind=kint) :: TEMP_interval
    real(kind=kreal)   :: TEMP_FACTOR
    integer(kind=kint), pointer :: TEMP_ngrp_GRPID     (:) =>null()
    integer(kind=kint), pointer :: TEMP_ngrp_ID        (:)
    real(kind=kreal), pointer   :: TEMP_ngrp_val       (:)

    !> SPRING
    integer(kind=kint) :: SPRING_ngrp_tot                      !< Following spring boundary conditions
    integer(kind=kint), pointer :: SPRING_ngrp_GRPID    (:) =>null()
    integer(kind=kint), pointer :: SPRING_ngrp_ID       (:)
    integer(kind=kint), pointer :: SPRING_ngrp_DOF      (:)
    integer(kind=kint), pointer :: SPRING_ngrp_amp      (:)
    real(kind=kreal), pointer   :: SPRING_ngrp_val      (:)

    !> for couple analysis
    integer( kind=kint ) :: COUPLE_ngrp_tot                   !< Following for coupling analysis
    integer( kind=kint ),pointer :: COUPLE_ngrp_ID(:)

    !> VALUE
    integer(kind=kint) :: maxn_gauss

    real(kind=kreal), pointer :: STRESS(:)    !< nodal stress
    real(kind=kreal), pointer :: STRAIN(:)    !< nodal strain
    real(kind=kreal), pointer :: MISES(:)     !< nodal MISES

    real(kind=kreal), pointer :: PSTRESS(:)   !< nodal principal stress
    real(kind=kreal), pointer :: PSTRAIN(:)   !< nodal principal strain
    real(kind=kreal), pointer :: PSTRESS_VECT(:,:)   !< nodal principal stress vector
    real(kind=kreal), pointer :: PSTRAIN_VECT(:,:)   !< nodal principal strain vector

    real(kind=kreal), pointer :: ESTRESS(:)   !< elemental stress
    real(kind=kreal), pointer :: ESTRAIN(:)   !< elemental strain
    real(kind=kreal), pointer :: EMISES(:)    !< elemental MISES

    real(kind=kreal), pointer :: EPSTRESS(:)   !< elemental principal stress
    real(kind=kreal), pointer :: EPSTRAIN(:)   !< elemental principal strain
    real(kind=kreal), pointer :: EPSTRESS_VECT(:,:)   !< elemental principal stress vector
    real(kind=kreal), pointer :: EPSTRAIN_VECT(:,:)   !< elemental principal strain vector

    real(kind=kreal), pointer :: TNSTRAIN(:)   !< thermal nodal strain
    real(kind=kreal), pointer :: TESTRAIN(:)   !< thermal elemental strain

    real(kind=kreal), pointer :: YIELD_RATIO(:)    !< yield ratio

    real(kind=kreal), pointer :: ENQM(:)      !< elemental NQM
    real(kind=kreal), pointer :: REACTION(:)    !< reaction_force

    real(kind=kreal), pointer :: CONT_NFORCE(:)  !< contact normal force for output
    real(kind=kreal), pointer :: CONT_FRIC(:)    !< contact friction force for output
    real(kind=kreal), pointer :: CONT_RELVEL(:)  !< contact ralative velocity for output
    real(kind=kreal), pointer :: CONT_STATE(:)   !< contact state for output

    type(fstr_solid_physic_val), pointer :: SOLID=>null()     !< for solid physical value stracture
    type(fstr_solid_physic_val), pointer :: SHELL=>null()     !< for shell physical value stracture
    type(fstr_solid_physic_val), pointer :: BEAM =>null()     !< for beam physical value stracture

    !> ANALYSIS CONTROL for NLGEOM
    integer(kind=kint) :: restart_nout   !< output interval of restart file
    !< (if  .gt.0) restart file write
    !< (if  .lt.0) restart file read and write
    integer(kind=kint) :: restart_nin    !< input number of restart
    type(step_info)    :: step_ctrl_restart  !< step information for restart

    integer(kind=kint) :: max_lyr        !< maximun num of layer
    integer(kind=kint) :: is_33shell
    integer(kind=kint) :: is_33beam
    integer(kind=kint) :: is_heat
    integer(kind=kint), pointer :: is_rot(:)
    integer(kind=kint) :: elemopt361
    real(kind=kreal)   :: FACTOR     (2)      !< factor of incrementation
    !< 1:time t  2: time t+dt
    !> for increment control
    integer(kind=kint) :: NRstat_i(10)     !< statistics of newton iteration (integer)
    real(kind=kreal)   :: NRstat_r(10)     !< statistics of newton iteration (real)
    integer(kind=kint) :: AutoINC_stat     !< status of auto-increment control
    integer(kind=kint) :: CutBack_stat     !< status of cutback control

    real(kind=kreal), pointer :: GL          (:)           !< exnternal force
    real(kind=kreal), pointer :: EFORCE      (:)           !< exnternal force
    real(kind=kreal), pointer :: QFORCE      (:)           !< equivalent nodal force
    real(kind=kreal), pointer :: unode(:)      => null()   !< disp at the beginning of curr step
    real(kind=kreal), pointer :: dunode(:)     => null()   !< curr total disp
    real(kind=kreal), pointer :: ddunode(:)    => null()   !< =hecMESH%X, disp icrement
    real(kind=kreal), pointer :: temperature(:)=> null()   !< =temperature
    real(kind=kreal), pointer :: temp_bak(:)   => null()
    real(kind=kreal), pointer :: last_temp(:)  => null()

    type( tElement ), pointer :: elements(:)   =>null()  !< elements information
    type( tMaterial ),pointer :: materials(:)  =>null()  !< material properties
    type( tContact ), pointer :: contacts(:)   =>null()  !< contact information
    integer                   :: n_fix_mpc               !< number mpc conditions user defined
    real(kind=kreal), pointer :: mpc_const(:)  =>null()  !< bakeup of hecmwST_mpc%mpc_const
    type(tSection), pointer   :: sections(:)   =>null()  !< definition of setion referred by elements(i)%sectionID

    ! for cutback
    ! ####################### Notice #######################
    ! # If you add new variables to store analysis status, #
    ! # - backup variables with postfix "_bkup" here       #
    ! # - backup process to module m_fstr_Cutback          #
    ! # must be added if necessary.                        #
    ! ######################################################
    real(kind=kreal), pointer :: unode_bkup(:)     => null() !< disp at the beginning of curr step (backup)
    real(kind=kreal), pointer :: QFORCE_bkup(:)    => null() !< equivalent nodal force (backup)
    real(kind=kreal), pointer :: last_temp_bkup(:) => null()
    type( tElement ), pointer :: elements_bkup(:)  =>null()  !< elements information (backup)
    type( tContact ), pointer :: contacts_bkup(:)  =>null()  !< contact information (backup)
  end type fstr_solid

  !> Data for HEAT ANSLYSIS  (fstrHEAT)
  type fstr_heat
    !> TIME CONTROL
    real(kind=kreal) :: TEMTOL
    integer :: STEPtot
    integer(kind=kint) :: restart_nout
    real(kind=kreal), pointer :: STEP_DLTIME(:),STEP_EETIME(:)
    real(kind=kreal), pointer :: STEP_DELMIN(:),STEP_DELMAX(:)

    !> MATERIAL
    integer :: MATERIALtot
    real(kind=kreal), pointer :: RHO(:,:), RHOtemp (:,:)
    real(kind=kreal), pointer :: CP(:,:),  CPtemp (:,:)
    real(kind=kreal), pointer :: COND(:,:),CONDtemp (:,:)

    integer, pointer :: RHOtab(:), CPtab(:), CONDtab(:)

    real(kind=kreal), pointer :: RHOfuncA(:,:),  RHOfuncB(:,:)
    real(kind=kreal), pointer :: CPfuncA (:,:),  CPfuncB(:,:)
    real(kind=kreal), pointer :: CONDfuncA (:,:),CONDfuncB(:,:)

    !> AMPLITUDE
    integer :: AMPLITUDEtot
    real(kind=kreal), pointer :: AMPL(:,:), AMPLtime (:,:)
    integer, pointer :: AMPLtab(:)
    real(kind=kreal), pointer :: AMPLfuncA(:,:),  AMPLfuncB(:,:)

    !> VALUE
    real(kind=kreal), pointer :: TEMP0(:)
    real(kind=kreal), pointer :: TEMPC(:)
    real(kind=kreal), pointer :: TEMP (:)

    !> FIXTEMP
    integer :: T_FIX_tot
    integer, pointer          :: T_FIX_node(:)
    integer, pointer          :: T_FIX_ampl(:)
    real(kind=kreal), pointer :: T_FIX_val(:)

    !> CFLUX
    integer :: Q_NOD_tot
    integer, pointer          :: Q_NOD_node(:)
    integer, pointer          :: Q_NOD_ampl(:)
    real(kind=kreal), pointer :: Q_NOD_val(:)

    !> DFLUX (not used)
    integer :: Q_VOL_tot
    integer, pointer          :: Q_VOL_elem(:)
    integer, pointer          :: Q_VOL_ampl(:)
    real(kind=kreal), pointer :: Q_VOL_val(:)

    !> DFLUX, !SFLUX
    integer :: Q_SUF_tot
    integer, pointer          :: Q_SUF_elem(:)
    integer, pointer          :: Q_SUF_ampl(:)
    integer, pointer          :: Q_SUF_surf(:)
    real(kind=kreal), pointer :: Q_SUF_val(:)

    !> RADIATE, !SRADIATE
    integer :: R_SUF_tot
    integer, pointer          :: R_SUF_elem(:)
    integer, pointer          :: R_SUF_ampl(:,:)
    integer, pointer          :: R_SUF_surf(:)
    real(kind=kreal), pointer :: R_SUF_val(:,:)

    !> FILM, SFILM
    integer :: H_SUF_tot
    integer, pointer          :: H_SUF_elem(:)
    integer, pointer          :: H_SUF_ampl(:,:)
    integer, pointer          :: H_SUF_surf(:)
    real(kind=kreal), pointer :: H_SUF_val(:,:)

    integer  :: WL_tot
    type(tWeldLine), pointer :: weldline(:) => null()
  end type fstr_heat

  !> Data for DYNAMIC ANSLYSIS  (fstrDYNAMIC)
  type fstr_dynamic
    !> ANALYSIS TYPE CONTROL
    integer(kind=kint) :: idx_eqa       ! implicit or explicit
    integer(kind=kint) :: idx_resp      ! time history or steady-state harmonic response analysis

    !> TIME CONTROL
    integer(kind=kint) :: n_step        ! total step number of analysis
    real(kind=kreal)   :: t_start       ! start time of analysis
    real(kind=kreal)   :: t_curr        ! current time of analysis
    real(kind=kreal)   :: t_end         ! end time of analysis
    real(kind=kreal)   :: t_delta       ! time increment
    integer(kind=kint) :: restart_nout  ! output interval of restart file
    ! (if  .gt.0) restart file write
    ! (if  .lt.0) restart file read and write
    integer(kind=kint) :: restart_nin  !input number of restart file

    !> Newmark-beta parameter
    real(kind=kreal)   :: ganma         ! Newmark-beta parameter ganma
    real(kind=kreal)   :: beta          ! Newmark-beta parameter beta

    !> mass matrix control
    integer(kind=kint) :: idx_mas       ! mass matrix type

    !> damping control
    integer(kind=kint) :: idx_dmp      ! damping type
    real(kind=kreal)   :: ray_m         ! Rayleigh damping parameter Rm
    real(kind=kreal)   :: ray_k         ! Rayleigh damping parameter Rk

    !> initialization control
    logical           :: VarInitialize  ! initialization flag

    !> OUTPUT CONTROL
    integer(kind=kint) :: nout           ! output interval of result
    integer(kind=kint) :: ngrp_monit     ! node of monitoring result
    integer(kind=kint) :: nout_monit     ! output interval of result monitoring
    integer(kind=kint) :: i_step         ! step number
    integer(kind=kint) :: iout_list(6)   ! 0:not output  1:output
    ! iout_list(1): displacement
    ! iout_list(2): velocity
    ! iout_list(3): acceleration
    ! iout_list(4): reaction force
    ! iout_list(5): strain
    ! iout_list(6): stress

    !> VALUE
    real(kind=kreal), pointer :: DISP  (:,:)     !> Displacement, U(t+dt), U(t), U(t-dt)
    real(kind=kreal), pointer :: VEL   (:,:)     !> Velocity
    real(kind=kreal), pointer :: ACC   (:,:)     !> Acceleration

    real(kind=kreal) :: kineticEnergy
    real(kind=kreal) :: strainEnergy
    real(kind=kreal) :: totalEnergy

    !> temporary quantity
    real(kind=kreal), pointer :: VEC1  (:)
    real(kind=kreal), pointer :: VEC2  (:)
    real(kind=kreal), pointer :: VEC3  (:)

    integer(kind=kint) :: dynamic_IW4        =   204
    integer(kind=kint) :: dynamic_IW5        =   205
    integer(kind=kint) :: dynamic_IW6        =   206
    integer(kind=kint) :: dynamic_IW7        =   207
    integer(kind=kint) :: dynamic_IW8        =   208
    integer(kind=kint) :: dynamic_IW9        =   209
  end type fstr_dynamic

  type fstr_freqanalysis
    integer(kind=kint)                :: FLOAD_ngrp_tot
    integer(kind=kint), pointer       :: FLOAD_ngrp_GRPID(:) => null()
    integer(kind=kint), pointer       :: FLOAD_ngrp_ID(:)    => null()
    integer(kind=kint), pointer       :: FLOAD_ngrp_TYPE(:)  => null()
    integer(kind=kint), pointer       :: FLOAD_ngrp_DOF(:)   => null()
    real(kind=kreal), pointer         :: FLOAD_ngrp_valre(:) => null()
    real(kind=kreal), pointer         :: FLOAD_ngrp_valim(:) => null()
    character(len=HECMW_FILENAME_LEN) :: eigenlog_filename
    integer(kind=kint)                :: start_mode
    integer(kind=kint)                :: end_mode
  end type fstr_freqanalysis

  type fstr_freqanalysis_data
    integer(kind=kint)        :: numMode
    integer(kind=kint)        :: numNodeDOF
    real(kind=kreal), pointer :: eigOmega(:)    => null()
    real(kind=kreal), pointer :: eigVector(:,:) => null()
    real(kind=kreal)           :: rayAlpha, rayBeta
  end type fstr_freqanalysis_data

  !> Package of data used by Lanczos eigenvalue solver
  type fstr_eigen
    !> Allocatable array, used or Lanczos eigenvalue analysis
    integer(kind=kint)  :: nget      ! Solved eigen value number (default:5)
    integer(kind=kint)  :: maxiter   ! Max. Lcz iterations (default:60)
    integer(kind=kint)  :: iter      ! Max. Lcz iterations (default:60)
    real   (kind=kreal) :: sigma     ! 0.0
    real   (kind=kreal) :: tolerance ! Lcz tolerance (default:1.0e-8)
    real   (kind=kreal) :: totalmass
    real   (kind=kreal), pointer :: eigval(:)
    real   (kind=kreal), pointer :: eigvec(:,:)
    real   (kind=kreal), pointer :: filter(:)
    real   (kind=kreal), pointer :: mass(:)
    real   (kind=kreal), pointer :: effmass(:)
    real   (kind=kreal), pointer :: partfactor(:)
    logical :: is_free = .false.
  end type fstr_eigen

  !> Data for coupling analysis
  type fstr_couple
    !> for revocap
    integer( kind=kint )   :: dof              ! == 3
    integer( kind=kint )   :: ndof             ! total dof (coupled_node_n*dof)
    integer( kind=kint )   :: coupled_node_n
    !> note) following types depend on revocap
    integer, pointer       :: coupled_node(:)  ! local node id sent from revocap
    real( kind=8 ),pointer :: trac(:)          ! input  (x,y,z,x,y,z ... )
    real( kind=8 ),pointer :: disp(:)          ! output (x,y,z,x,y,z ... )
    real( kind=8 ),pointer :: velo(:)          ! output (x,y,z,x,y,z ... )
    real( kind=8 ),pointer :: accel(:)         ! output (x,y,z,x,y,z ... )
    !> for inner use
    integer( kind=kint ),pointer :: index(:)   ! size:total node num.
    !>  -1:not relation, >1:index of coupled_node
  end type fstr_couple

  !> Data for weld line
  type tWeldLine
    integer(kind=kint) :: egrpid
    real( kind=kreal ) :: I
    real( kind=kreal ) :: U
    real( kind=kreal ) :: coe
    real( kind=kreal ) :: v
    integer(kind=kint) :: xyz
    real(kind=kreal)   :: n1, n2
    real(kind=kreal)   :: distol
    real(kind=kreal)   :: tstart
  end type tWeldLine

  !> Data for section control
  type tSection
    !integer              :: mat_ID
    !integer              :: iset
    !integer              :: orien_ID
    !real(kind=kreal)     :: thickness
    !integer              :: elemopt341
    !integer              :: elemopt342
    !integer              :: elemopt351
    !integer              :: elemopt352
    integer              :: elemopt361
    !integer              :: elemopt362
  end type tSection

contains

  !> NULL POINTER SETTING TO AVOID RUNTIME ERROR
  subroutine fstr_nullify_fstr_param( P )
    implicit none
    type( fstr_param ) :: P

    nullify( P%dtime )
    nullify( P%etime )
    nullify( P%dtmin )
    nullify( P%delmax )
    nullify( P%itmax )
    nullify( P%eps )
    nullify( P%global_local_ID)
    nullify( P%timepoints )
  end subroutine fstr_nullify_fstr_param

  subroutine fstr_nullify_fstr_solid( S )
    implicit none
    type( fstr_solid ) :: S

    nullify( S%BOUNDARY_ngrp_ID )
    nullify( S%BOUNDARY_ngrp_type )
    nullify( S%BOUNDARY_ngrp_amp )
    nullify( S%BOUNDARY_ngrp_val)
    nullify( S%BOUNDARY_ngrp_rotID )
    nullify( S%BOUNDARY_ngrp_centerID )
    nullify( S%CLOAD_ngrp_ID )
    nullify( S%CLOAD_ngrp_DOF )
    nullify( S%CLOAD_ngrp_amp )
    nullify( S%CLOAD_ngrp_rotID )
    nullify( S%CLOAD_ngrp_centerID )
    nullify( S%CLOAD_ngrp_val )
    nullify( S%DLOAD_ngrp_ID )
    nullify( S%DLOAD_ngrp_LID )
    nullify( S%DLOAD_ngrp_amp )
    nullify( S%DLOAD_ngrp_params )
    nullify( S%TEMP_ngrp_ID )
    nullify( S%TEMP_ngrp_val )
    nullify( S%SPRING_ngrp_ID )
    nullify( S%SPRING_ngrp_DOF )
    nullify( S%SPRING_ngrp_amp )
    nullify( S%SPRING_ngrp_val )
    nullify( S%STRESS )
    nullify( S%STRAIN )
    nullify( S%MISES )
    nullify( S%REACTION )
    nullify( S%ESTRESS )
    nullify( S%ESTRAIN )
    nullify( S%EMISES )
    nullify( S%ENQM )
    nullify( S%GL          )
    nullify( S%QFORCE      )
    nullify( S%VELOCITY_ngrp_ID )
    nullify( S%VELOCITY_ngrp_type )
    nullify( S%VELOCITY_ngrp_amp )
    nullify( S%VELOCITY_ngrp_val )
    nullify( S%ACCELERATION_ngrp_ID )
    nullify( S%ACCELERATION_ngrp_type )
    nullify( S%ACCELERATION_ngrp_amp )
    nullify( S%ACCELERATION_ngrp_val )
    nullify( S%COUPLE_ngrp_ID )
  end subroutine fstr_nullify_fstr_solid

  subroutine fstr_nullify_fstr_heat( H )
    implicit none
    type( fstr_heat ) :: H

    nullify( H%STEP_DLTIME )
    nullify( H%STEP_EETIME )
    nullify( H%STEP_DELMIN )
    nullify( H%STEP_DELMAX )
    nullify( H%RHO )
    nullify( H%RHOtemp  )
    nullify( H%CP )
    nullify( H%CPtemp  )
    nullify( H%COND )
    nullify( H%CONDtemp  )
    nullify( H%RHOtab )
    nullify( H%CPtab )
    nullify( H%CONDtab )
    nullify( H%RHOfuncA )
    nullify( H%RHOfuncB )
    nullify( H%CPfuncA  )
    nullify( H%CPfuncB )
    nullify( H%CONDfuncA  )
    nullify( H%CONDfuncB )
    nullify( H%AMPL )
    nullify( H%AMPLtime  )
    nullify( H%AMPLtab )
    nullify( H%AMPLfuncA )
    nullify( H%AMPLfuncB )
    nullify( H%TEMP0 )
    nullify( H%TEMPC )
    nullify( H%TEMP  )
    nullify( H%T_FIX_node )
    nullify( H%T_FIX_ampl )
    nullify( H%T_FIX_val )
    nullify( H%Q_NOD_node )
    nullify( H%Q_NOD_ampl )
    nullify( H%Q_NOD_val )
    nullify( H%Q_VOL_elem )
    nullify( H%Q_VOL_ampl )
    nullify( H%Q_VOL_val )
    nullify( H%Q_SUF_elem )
    nullify( H%Q_SUF_ampl )
    nullify( H%Q_SUF_surf )
    nullify( H%Q_SUF_val )
    nullify( H%R_SUF_elem )
    nullify( H%R_SUF_ampl )
    nullify( H%R_SUF_surf )
    nullify( H%R_SUF_val )
    nullify( H%H_SUF_elem )
    nullify( H%H_SUF_ampl )
    nullify( H%H_SUF_surf )
    nullify( H%H_SUF_val )
  end subroutine fstr_nullify_fstr_heat

  subroutine fstr_nullify_fstr_dynamic( DY )
    implicit none
    type( fstr_dynamic ) :: DY

    nullify( DY%DISP )
    nullify( DY%VEL  )
    nullify( DY%ACC  )
    nullify( DY%VEC1 )
    nullify( DY%VEC2 )
    nullify( DY%VEC3 )
  end subroutine fstr_nullify_fstr_dynamic

  subroutine fstr_nullify_fstr_freqanalysis( f )
    implicit none
    type( fstr_freqanalysis ), intent(inout) :: f

    f%FLOAD_ngrp_tot = 0
    nullify( f%FLOAD_ngrp_GRPID )
    nullify( f%FLOAD_ngrp_ID )
    nullify( f%FLOAD_ngrp_TYPE )
    nullify( f%FLOAD_ngrp_DOF )
    nullify( f%FLOAD_ngrp_valre )
    nullify( f%FLOAD_ngrp_valim )
  end subroutine fstr_nullify_fstr_freqanalysis

  subroutine fstr_nullify_fstr_eigen( E )
    implicit none
    type( fstr_eigen ) :: E

    nullify( E%mass )
  end subroutine fstr_nullify_fstr_eigen

  subroutine fstr_nullify_fstr_couple( C )
    implicit none
    type( fstr_couple ) :: C

    nullify( C%coupled_node )
    nullify( C%trac )
    nullify( C%velo )
    nullify( C%index )
  end subroutine fstr_nullify_fstr_couple

  !> Initializer of structure hecmwST_matrix
  subroutine fstr_mat_init( hecMAT )
    implicit none
    type(hecmwST_matrix) :: hecMAT

    hecMAT%Iarray(1) =  100    ! = nier
    hecMAT%Iarray(2) =    1    ! = method
    hecMAT%Iarray(3) =    1    ! = precond
    hecMAT%Iarray(4) =    0    ! = nset
    hecMAT%Iarray(5) =    1    ! = iterpremax
    hecMAT%Iarray(6) =   10    ! = nrest
    hecMAT%Iarray(7) =    0    ! = scaling
    hecMAT%Iarray(21)=  kNO    ! = iterlog
    hecMAT%Iarray(22)=  kNO    ! = timelog
    hecMAT%Iarray(31)=    0    ! = dumptype
    hecMAT%Iarray(32)=    0    ! = dumpexit
    hecMAT%Iarray(33)=    0    ! = usejad
    hecMAT%Iarray(34)=   10    ! = ncolor_in
    hecMAT%Iarray(13)=    0    ! = mpc_method
    hecMAT%Iarray(14)=    0    ! = estcond
    hecMAT%Iarray(35)=    3    ! = maxrecycle_precond

    hecMAT%Rarray(1) =  1.0e-8 ! = resid
    hecMAT%Rarray(2) =  1.0    ! = sigma_diag
    hecMAT%Rarray(3) =  0.0    ! = sigma
    hecMAT%Rarray(4) =  0.1    ! = thresh
    hecMAT%Rarray(5) =  0.1    ! = filter
    hecMAT%Rarray(11)=  1.0e+4 ! = penalty

    hecMAT%Iarray(96) =   0    ! nrecycle_precond
    hecMAT%Iarray(97) = kYES   ! flag_numfact
    hecMAT%Iarray(98) = kYES   ! flag_symbfact
    hecMAT%Iarray(99) = kYES   ! indirect method
  end subroutine fstr_mat_init

  subroutine hecMAT_init( hecMAT )
    implicit none
    type( hecmwST_matrix ) :: hecMAT
    integer ::  ndof, nn, ierror
    ndof = hecMAT%NDOF
    nn = ndof*ndof
    allocate (hecMAT%AL(nn*hecMAT%NPL)        ,stat=ierror )
    if( ierror /= 0 ) then
      write(*,*) "##ERROR : not enough memory"
      write(idbg,*) 'stop due to allocation error'
      call flush(idbg)
      call hecmw_abort( hecmw_comm_get_comm() )
    end if
    allocate (hecMAT%AU(nn*hecMAT%NPU)        ,stat=ierror )
    if( ierror /= 0 ) then
      write(*,*) "##ERROR : not enough memory"
      write(idbg,*) 'stop due to allocation error'
      call flush(idbg)
      call hecmw_abort( hecmw_comm_get_comm() )
    end if
    allocate (hecMAT%B(ndof*hecMAT%NP)          ,stat=ierror )
    if( ierror /= 0 ) then
      write(*,*) "##ERROR : not enough memory"
      write(idbg,*) 'stop due to allocation error'
      call flush(idbg)
      call hecmw_abort( hecmw_comm_get_comm() )
    end if
    hecMAT%B(:)=0.d0
    allocate (hecMAT%D(nn*hecMAT%NP)          ,stat=ierror )
    if( ierror /= 0 ) then
      write(*,*) "##ERROR : not enough memory"
      write(idbg,*) 'stop due to allocation error'
      call flush(idbg)
      call hecmw_abort( hecmw_comm_get_comm() )
    end if
    allocate (hecMAT%X(ndof*hecMAT%NP)          ,stat=ierror )
    if( ierror /= 0 ) then
      write(*,*) "##ERROR : not enough memory"
      write(idbg,*) 'stop due to allocation error'
      call flush(idbg)
      call hecmw_abort( hecmw_comm_get_comm() )
    end if
    allocate (hecMAT%ALU(nn*hecMAT%N)         ,stat=ierror )
    if( ierror /= 0 ) then
      write(*,*) "##ERROR : not enough memory"
      write(idbg,*) 'stop due to allocation error'
      call flush(idbg)
      call hecmw_abort( hecmw_comm_get_comm() )
    endif
    call hecmw_cmat_init( hecMAT%cmat )
  end subroutine hecMAT_init

  subroutine hecMAT_finalize( hecMAT )
    implicit none
    type( hecmwST_matrix ) :: hecMAT
    integer ::  ndof, nn, ierror
    ndof = hecMAT%NDOF
    nn = ndof*ndof
    if( associated(hecMAT%AL) ) then
      deallocate(hecMAT%AL                  ,stat=ierror)
      if( ierror /= 0 ) then
        write(idbg,*) 'stop due to deallocation error'
        call flush(idbg)
        call hecmw_abort( hecmw_comm_get_comm())
      end if
    endif
    if( associated(hecMAT%AU) ) then
      deallocate(hecMAT%AU                  ,stat=ierror)
      if( ierror /= 0 ) then
        write(idbg,*) 'stop due to deallocation error'
        call flush(idbg)
        call hecmw_abort( hecmw_comm_get_comm())
      end if
    endif
    if( associated(hecMAT%B) ) then
      deallocate(hecMAT%B                   ,stat=ierror)
      if( ierror /= 0 ) then
        write(idbg,*) 'stop due to deallocation error'
        call flush(idbg)
        call hecmw_abort( hecmw_comm_get_comm())
      end if
    endif
    if( associated(hecMAT%D) ) then
      deallocate(hecMAT%D                   ,stat=ierror)
      if( ierror /= 0 ) then
        write(idbg,*) 'stop due to deallocation error'
        call flush(idbg)
        call hecmw_abort( hecmw_comm_get_comm())
      end if
    endif
    if( associated(HECMAT%X) ) then
      deallocate(hecMAT%X                   ,stat=ierror)
      if( ierror /= 0 ) then
        write(idbg,*) 'stop due to deallocation error'
        call flush(idbg)
        call hecmw_abort( hecmw_comm_get_comm())
      end if
    endif
    if( associated(hecMAT%ALU) ) then
      deallocate(hecMAT%ALU                 ,stat=ierror)
      if( ierror /= 0 ) then
        write(idbg,*) 'stop due to deallocation error'
        call flush(idbg)
        call hecmw_abort( hecmw_comm_get_comm())
      end if
    endif
    call hecmw_cmat_finalize(hecmAT%cmat)
  end subroutine hecMAT_finalize

  !> Initializer of structure fstr_param
  subroutine fstr_param_init( fstrPARAM, hecMESH )
    implicit none
    type(fstr_param) :: fstrPARAM
    type(hecmwST_local_mesh) :: hecMESH
    integer(kind=kint) :: i
    external fstr_sort_index

    fstrPARAM%solution_type = kstSTATIC
    fstrPARAM%nlgeom        = .false.
    fstrPARAM%solver_method = ksmCG

    !!STATIC !HEAT
    fstrPARAM%analysis_n = 0
    fstrPARAM%ref_temp   = 0

    ! output control
    fstrPARAM%fg_echo       = kOFF
    fstrPARAM%fg_result     = kOFF
    fstrPARAM%fg_visual     = kOFF

    ! for heat ...
    fstrPARAM%fg_neutral    = kOFF
    fstrPARAM%fg_irres      = kNO
    fstrPARAM%fg_iwres      = kNO
    fstrPARAM%nrres         = 1
    fstrPARAM%nprint        = 1

    ! for couple
    fstrPARAM%fg_couple      = 0
    fstrPARAM%fg_couple_type = 0
    fstrPARAM%fg_couple_first= 0
    fstrPARAM%fg_couple_window= 0

    ! for restart control
    fstrPARAM%restart_version = 5

    ! index table for global node ID sorting

    fstrPARAM%n_node = hecMESH%n_node;
    fstrPARAM%nn_internal = hecMESH%nn_internal;
    allocate( fstrPARAM%global_local_ID(2,hecMESH%nn_internal))
    do i = 1, hecMESH%nn_internal
      fstrPARAM%global_local_ID(1,i) = hecMESH%global_node_ID(i)
      fstrPARAM%global_local_ID(2,i) = i
    end do
    call fstr_sort_index( fstrPARAM%global_local_ID, hecMESH%nn_internal )
  end subroutine fstr_param_init

  logical function fstr_isBoundaryActive( fstrSOLID, nbc, cstep )
    type(fstr_solid)    :: fstrSOLID
    integer, intent(in) :: nbc    !< group id of boundary condition
    integer, intent(in) :: cstep  !< current step number
    fstr_isBoundaryActive = .true.
    if( .not. associated(fstrSOLID%step_ctrl) ) return
    if( cstep>fstrSOLID%nstep_tot ) return
    fstr_isBoundaryActive = isBoundaryActive( nbc, fstrSOLID%step_ctrl(cstep) )
  end function

  logical function fstr_isLoadActive( fstrSOLID, nbc, cstep )
    type(fstr_solid)    :: fstrSOLID
    integer, intent(in) :: nbc    !< group id of boundary condition
    integer, intent(in) :: cstep  !< current step number
    fstr_isLoadActive = .true.
    if( cstep > 0 ) then
      if( .not. associated(fstrSOLID%step_ctrl) ) return
      if( cstep>fstrSOLID%nstep_tot ) return
      fstr_isLoadActive = isLoadActive( nbc, fstrSOLID%step_ctrl(cstep) )
    else
      fstr_isLoadActive = isLoadActive( nbc, fstrSOLID%step_ctrl_restart )
    endif
  end function

  logical function fstr_isContactActive( fstrSOLID, nbc, cstep )
    type(fstr_solid)     :: fstrSOLID !< type fstr_solid
    integer, intent(in) :: nbc       !< group id of boundary condition
    integer, intent(in) :: cstep     !< current step number
    fstr_isContactActive = .true.
    if( .not. associated(fstrSOLID%step_ctrl) ) return
    if( cstep>fstrSOLID%nstep_tot ) return
    fstr_isContactActive = isContactActive( nbc, fstrSOLID%step_ctrl(cstep) )
  end function

  !> This subroutine fetch coords defined by local coordinate system
  subroutine get_coordsys( cdsys_ID, hecMESH, fstrSOLID, coords )
    integer, intent(in)             :: cdsys_ID      !< id of local coordinate
    type(hecmwST_local_mesh)       :: hecMESH       !< mesh information
    type(fstr_solid), intent(inout) :: fstrSOLID     !< fstr_solid
    real(kind=kreal), intent(out)   :: coords(3,3)
    integer :: ik

    coords = 0.d0
    if( cdsys_ID>0 ) then
      if( isCoordNeeds(g_LocalCoordSys(cdsys_ID)) ) then
        coords=g_LocalCoordSys(cdsys_ID)%CoordSys
      else
        ik=g_LocalCoordSys(cdsys_ID)%node_ID(1)
        coords(1,:)= hecMESH%node(3*ik-2:3*ik)+fstrSOLID%unode(3*ik-2:3*ik)  &
          + fstrSOLID%dunode(3*ik-2:3*ik)
        ik=g_LocalCoordSys(cdsys_ID)%node_ID(2)
        coords(2,:)= hecMESH%node(3*ik-2:3*ik)+fstrSOLID%unode(3*ik-2:3*ik)  &
          + fstrSOLID%dunode(3*ik-2:3*ik)
        ik=g_LocalCoordSys(cdsys_ID)%node_ID(3)
        if(ik>0) coords(3,:)= hecMESH%node(3*ik-2:3*ik)+fstrSOLID%unode(3*ik-2:3*ik)  &
          + fstrSOLID%dunode(3*ik-2:3*ik)
      endif
    endif
  end subroutine get_coordsys

  subroutine fstr_set_current_config_to_mesh(hecMESH,fstrSOLID,coord)
    implicit none
    type(hecmwST_local_mesh), intent(inout) :: hecMESH
    type (fstr_solid), intent(in) :: fstrSOLID
    real(kind=kreal), pointer :: coord(:)
    integer(kind=kint) :: i
    if(hecMESH%n_dof == 4) return
    do i = 1, hecMESH%n_node*min(hecMESH%n_dof,3)
      coord(i) = hecMESH%node(i)
      hecMESH%node(i) = coord(i)+fstrSOLID%unode(i)+fstrSOLID%dunode(i)
    enddo
  end subroutine fstr_set_current_config_to_mesh

  subroutine fstr_recover_initial_config_to_mesh(hecMESH,fstrSOLID,coord)
    implicit none
    type(hecmwST_local_mesh), intent(inout) :: hecMESH
    type (fstr_solid), intent(in) :: fstrSOLID
    real(kind=kreal), pointer :: coord(:)
    integer(kind=kint) :: i
    if(hecMESH%n_dof == 4) return
    do i = 1, hecMESH%n_node*min(hecMESH%n_dof,3)
      hecMESH%node(i) = coord(i)
    enddo
  end subroutine fstr_recover_initial_config_to_mesh

  subroutine fstr_solid_phys_zero(phys)
    implicit none
    type(fstr_solid_physic_val), pointer :: phys
    phys%STRAIN  = 0.0d0
    phys%STRESS  = 0.0d0
    phys%MISES   = 0.0d0
    phys%ESTRAIN = 0.0d0
    phys%ESTRESS = 0.0d0
    phys%EMISES  = 0.0d0
    phys%ENQM    = 0.0d0
  end subroutine fstr_solid_phys_zero

  subroutine fstr_solid_phys_clear(fstrSOLID)
    implicit none
    type (fstr_solid)         :: fstrSOLID
    type(fstr_solid_physic_val), pointer :: phys
    integer(kind=kint) :: i

    if (associated(fstrSOLID%SOLID)) then
      call fstr_solid_phys_zero(fstrSOLID%SOLID)
    end if
    if (associated(fstrSOLID%SHELL)) then
      call fstr_solid_phys_zero(fstrSOLID%SHELL)
      do i=1,fstrSOLID%max_lyr
        call fstr_solid_phys_zero(fstrSOLID%SHELL%LAYER(i)%PLUS)
        call fstr_solid_phys_zero(fstrSOLID%SHELL%LAYER(i)%MINUS)
      end do
    end if
    if (associated(fstrSOLID%BEAM)) then
      call fstr_solid_phys_zero(fstrSOLID%BEAM)
    end if
  end subroutine fstr_solid_phys_clear

end module m_fstr


!> \file GFS_phys_time_vary.f90
!!  Contains code related to GFS physics suite setup (physics part of time_vary_step)

    module GFS_phys_time_vary_1

      contains

      subroutine GFS_phys_time_vary_1_init ()
      end subroutine GFS_phys_time_vary_1_init

      subroutine GFS_phys_time_vary_1_finalize()
      end subroutine GFS_phys_time_vary_1_finalize

!> \section arg_table_GFS_phys_time_vary_1_run Argument Table
!! | local_name     | standard_name                                          | long_name                                                               | units    | rank |  type                 |   kind    | intent | optional |
!! |----------------|--------------------------------------------------------|-------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------|
!! | Model          | FV3-GFS_Control_type                                   | Fortran DDT containing FV3-GFS model control parameters                 | DDT      |    0 | GFS_control_type      |           | inout  | F        |
!! | errmsg         | error_message                                          | error message for error handling in CCPP                                | none     |    0 | character             | len=*     | out    | F        |
!! | errflg         | error_flag                                             | error flag for error handling in CCPP                                   | flag     |    0 | integer               |           | out    | F        |
!!
      subroutine GFS_phys_time_vary_1_run (Model, errmsg, errflg)

        use machine,               only: kind_phys
        use GFS_typedefs,          only: GFS_control_type

        implicit none

        type(GFS_control_type),           intent(inout) :: Model
        character(len=*),                 intent(out)   :: errmsg
        integer,                          intent(out)   :: errflg

        real(kind=kind_phys), parameter :: con_24  =   24.0_kind_phys
        real(kind=kind_phys), parameter :: con_hr  = 3600.0_kind_phys
        real(kind=kind_phys) :: rinc(5)

        ! Initialize CCPP error handling variables
        errmsg = ''
        errflg = 0

        !--- Model%jdat is being updated directly inside of FV3GFS_cap.F90
        !--- update calendars and triggers
        rinc(1:5)   = 0
        call w3difdat(Model%jdat,Model%idat,4,rinc)
        Model%sec = rinc(4)

        Model%phour = Model%sec/con_hr
        !--- set current bucket hour
        Model%zhour = Model%phour
        Model%fhour = (Model%sec + Model%dtp)/con_hr
        Model%kdt   = nint((Model%sec + Model%dtp)/Model%dtp)

        Model%ipt    = 1
        Model%lprnt  = .false.
        Model%lssav  = .true.

        !--- radiation triggers
        Model%lsswr  = (mod(Model%kdt, Model%nsswr) == 1)
        Model%lslwr  = (mod(Model%kdt, Model%nslwr) == 1)

        !--- set the solar hour based on a combination of phour and time initial hour
        Model%solhr  = mod(Model%phour+Model%idate(1),con_24)

        if ((Model%debug) .and. (Model%me == Model%master)) then
          print *,'   sec ', Model%sec
          print *,'   kdt ', Model%kdt
          print *,' nsswr ', Model%nsswr
          print *,' nslwr ', Model%nslwr
          print *,' nscyc ', Model%nscyc
          print *,' lsswr ', Model%lsswr
          print *,' lslwr ', Model%lslwr
          print *,' fhour ', Model%fhour
          print *,' phour ', Model%phour
          print *,' solhr ', Model%solhr
        endif

      end subroutine GFS_phys_time_vary_1_run

    end module GFS_phys_time_vary_1

    module GFS_phys_time_vary_2

      contains

      subroutine GFS_phys_time_vary_2_init ()
      end subroutine GFS_phys_time_vary_2_init

      subroutine GFS_phys_time_vary_2_finalize()
      end subroutine GFS_phys_time_vary_2_finalize

!> \section arg_table_GFS_phys_time_vary_2_run Argument Table
!! | local_name     | standard_name                                          | long_name                                                               | units    | rank |  type                 |   kind    | intent | optional |
!! |----------------|--------------------------------------------------------|-------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------|
!! | Grid           | FV3-GFS_Grid_type_all_blocks                           | Fortran DDT containing FV3-GFS grid and interpolation related data      | DDT      |    1 | GFS_grid_type         |           | in     | F        |
!! | Model          | FV3-GFS_Control_type                                   | Fortran DDT containing FV3-GFS model control parameters                 | DDT      |    0 | GFS_control_type      |           | inout  | F        |
!! | Tbd            | FV3-GFS_Tbd_type_all_blocks                            | Fortran DDT containing FV3-GFS miscellaneous data                       | DDT      |    1 | GFS_tbd_type          |           | inout  | F        |
!! | Sfcprop        | FV3-GFS_Sfcprop_type_all_blocks                        | Fortran DDT containing FV3-GFS surface fields                           | DDT      |    1 | GFS_sfcprop_type      |           | inout  | F        |
!! | Cldprop        | FV3-GFS_Cldprop_type_all_blocks                        | Fortran DDT containing FV3-GFS cloud fields                             | DDT      |    1 | GFS_cldprop_type      |           | inout  | F        |
!! | Diag           | FV3-GFS_Diag_type_all_blocks                           | Fortran DDT containing FV3-GFS fields targeted for diagnostic output    | DDT      |    1 | GFS_diag_type         |           | inout  | F        |
!! | errmsg         | error_message                                          | error message for error handling in CCPP                                | none     |    0 | character             | len=*     | out    | F        |
!! | errflg         | error_flag                                             | error flag for error handling in CCPP                                   | flag     |    0 | integer               |           | out    | F        |
!!
      subroutine GFS_phys_time_vary_2_run (Grid, Model, Tbd, Sfcprop, Cldprop, Diag, errmsg, errflg)

        use mersenne_twister, only: random_setseed, random_number
        use machine,               only: kind_phys
        use physcons,              only: dxmin, dxinv
        use GFS_typedefs,          only: GFS_control_type, GFS_grid_type, &
                                         GFS_tbd_type, GFS_sfcprop_type,  &
                                         GFS_cldprop_type, GFS_diag_type

        implicit none

        type(GFS_grid_type),              intent(in)    :: Grid(:)
        type(GFS_control_type),           intent(inout) :: Model
        type(GFS_tbd_type),               intent(inout) :: Tbd(:)
        type(GFS_sfcprop_type),           intent(inout) :: Sfcprop(:)
        type(GFS_cldprop_type),           intent(inout) :: Cldprop(:)
        type(GFS_diag_type),              intent(inout) :: Diag(:)
        character(len=*),                 intent(out)   :: errmsg
        integer,                          intent(out)   :: errflg

        real(kind=kind_phys), parameter :: con_hr  = 3600.0_kind_phys
        real(kind=kind_phys), parameter :: con_99  =   99.0_kind_phys
        real(kind=kind_phys), parameter :: con_100 =  100.0_kind_phys

        integer :: i, j, k, iseed, iskip, ix, nb, nblks
        real(kind=kind_phys) :: wrk(1)
        real(kind=kind_phys) :: rannie(Model%cny)
        real(kind=kind_phys) :: rndval(Model%cnx*Model%cny*Model%nrcm)

        ! Initialize CCPP error handling variables
        errmsg = ''
        errflg = 0

        nblks = size(Model%blksz)

        !--- switch for saving convective clouds - cnvc90.f
        !--- aka Ken Campana/Yu-Tai Hou legacy
        if ((mod(Model%kdt,Model%nsswr) == 0) .and. (Model%lsswr)) then
          !--- initialize,accumulate,convert
          Model%clstp = 1100 + min(Model%fhswr/con_hr,Model%fhour,con_99)
        elseif (mod(Model%kdt,Model%nsswr) == 0) then
          !--- accumulate,convert
          Model%clstp = 0100 + min(Model%fhswr/con_hr,Model%fhour,con_99)
        elseif (Model%lsswr) then
          !--- initialize,accumulate
          Model%clstp = 1100
        else
          !--- accumulate
          Model%clstp = 0100
        endif

        !--- random number needed for RAS and old SAS and when cal_pre=.true.
        if ( ((Model%imfdeepcnv <= 0) .or. (Model%cal_pre)) .and. (Model%random_clds) ) then
          iseed = mod(con_100*sqrt(Model%fhour*con_hr),1.0d9) + Model%seed0
          call random_setseed(iseed)
          call random_number(wrk)
          do i = 1,Model%cnx*Model%nrcm
            iseed = iseed + nint(wrk(1)) * i
            call random_setseed(iseed)
            call random_number(rannie)
            rndval(1+(i-1)*Model%cny:i*Model%cny) = rannie(1:Model%cny)
          enddo

          ! DH* TODO - this could be sped up by saving jsc, jec, isc, iec in Tbd (for example)
          ! and looping just over them; ix would then run from 1 to blksz(nb); one could also
          ! use OpenMP to speed up this loop or the inside loops *DH
          do k = 1,Model%nrcm
            iskip = (k-1)*Model%cnx*Model%cny
            ix = 0
            nb = 1
            do j = 1,Model%ny
              do i = 1,Model%nx
                ix = ix + 1
                if (ix .gt. Model%blksz(nb)) then
                  ix = 1
                  nb = nb + 1
                endif
                Tbd(nb)%rann(ix,k) = rndval(i+Model%isc-1 + (j+Model%jsc-2)*Model%cnx + iskip)
              enddo
            enddo
          enddo
        endif  ! imfdeepcnv, cal_re, random_clds

        !--- o3 interpolation
        if (Model%ntoz > 0) then
! DH* OpenMP?
          do nb = 1, nblks
            call ozinterpol (Model%me, Model%blksz(nb), Model%idate, Model%fhour, &
                             Grid(nb)%jindx1_o3, Grid(nb)%jindx2_o3,              &
                             Tbd(nb)%ozpl, Grid(nb)%ddy_o3)
          enddo
        endif

        !--- h2o interpolation
        if (Model%h2o_phys) then
! DH* OpenMP?
          do nb = 1, nblks
            call h2ointerpol (Model%me, Model%blksz(nb), Model%idate, Model%fhour, &
                              Grid(nb)%jindx1_h, Grid(nb)%jindx2_h,                &
                              Tbd(nb)%h2opl, Grid(nb)%ddy_h)
          enddo
        endif

        !--- repopulate specific time-varying sfc properties for AMIP/forecast runs
        if (Model%nscyc >  0) then
          if (mod(Model%kdt,Model%nscyc) == 1) THEN
            call gcycle (nblks, Model, Grid(:), Sfcprop(:), Cldprop(:))
          endif
        endif

        !--- determine if diagnostics buckets need to be cleared
        if (mod(Model%kdt,Model%nszero) == 1) then
! DH* OpenMP?
          do nb = 1,nblks
            call Diag(nb)%rad_zero  (Model)
            call Diag(nb)%phys_zero (Model)
        !!!!  THIS IS THE POINT AT WHICH DIAG%ZHOUR NEEDS TO BE UPDATED
          enddo
        endif

      end subroutine GFS_phys_time_vary_2_run

    end module GFS_phys_time_vary_2