MODULE sbcisf
  USE oce
  USE dom_oce
  USE phycst
  USE eosbn2
  USE sbc_oce
  USE zdfdrg
  USE in_out_manager
  USE iom
  USE fldread
  USE lbclnk
  USE lib_fortran
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: sbc_isf, sbc_isf_init, sbc_isf_div, sbc_isf_alloc
  REAL(KIND = wp), PUBLIC :: rn_hisf_tbl
  INTEGER, PUBLIC :: nn_isf
  INTEGER, PUBLIC :: nn_isfblk
  INTEGER, PUBLIC :: nn_gammablk
  REAL(KIND = wp), PUBLIC :: rn_gammat0
  REAL(KIND = wp), PUBLIC :: rn_gammas0
  INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: misfkt, misfkb
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: rzisf_tbl
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: rhisf_tbl, rhisf_tbl_0
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: r1_hisf_tbl
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: ralpha
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: risfLeff
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: ttbl, stbl, utbl, vtbl
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: qisf
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: risf_tsc_b, risf_tsc
  LOGICAL, PUBLIC :: l_isfcpl = .FALSE.
  REAL(KIND = wp), PUBLIC, SAVE :: rcpisf = 2000.0_wp
  REAL(KIND = wp), PUBLIC, SAVE :: rkappa = 1.54E-6_wp
  REAL(KIND = wp), PUBLIC, SAVE :: rhoisf = 920.0_wp
  REAL(KIND = wp), PUBLIC, SAVE :: tsurf = - 20.0_wp
  REAL(KIND = wp), PUBLIC, SAVE :: rLfusisf = 0.334E6_wp
  CHARACTER(LEN = 100), PUBLIC :: cn_dirisf = './'
  TYPE(FLD_N), PUBLIC :: sn_fwfisf
  TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_fwfisf
  TYPE(FLD_N), PUBLIC :: sn_rnfisf
  TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_rnfisf
  TYPE(FLD_N), PUBLIC :: sn_depmax_isf
  TYPE(FLD_N), PUBLIC :: sn_depmin_isf
  TYPE(FLD_N), PUBLIC :: sn_Leff_isf
  CONTAINS
  SUBROUTINE sbc_isf(kt)
    INTEGER, INTENT(IN) :: kt
    INTEGER :: ji, jj, jk
    INTEGER :: ikt, ikb
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zt_frz, zdep
    REAL(KIND = wp), DIMENSION(:, :), ALLOCATABLE :: zqhcisf2d
    REAL(KIND = wp), DIMENSION(:, :, :), ALLOCATABLE :: zfwfisf3d, zqhcisf3d, zqlatisf3d
    IF (MOD(kt - 1, nn_fsbc) == 0) THEN
      SELECT CASE (nn_isf)
      CASE (1)
        CALL sbc_isf_tbl(tsn(:, :, :, jp_tem), ttbl(:, :), 'T')
        CALL sbc_isf_tbl(tsn(:, :, :, jp_sal), stbl(:, :), 'T')
        CALL sbc_isf_tbl(un(:, :, :), utbl(:, :), 'U')
        CALL sbc_isf_tbl(vn(:, :, :), vtbl(:, :), 'V')
        CALL iom_put('ttbl', ttbl(:, :))
        CALL iom_put('stbl', stbl(:, :))
        CALL iom_put('utbl', utbl(:, :) * (1._wp - tmask(:, :, 1)) * ssmask(:, :))
        CALL iom_put('vtbl', vtbl(:, :) * (1._wp - tmask(:, :, 1)) * ssmask(:, :))
        IF (.NOT. l_isfcpl) THEN
          CALL sbc_isf_cav(kt)
        ELSE
          !$ACC KERNELS
          qisf(:, :) = fwfisf(:, :) * rlfusisf
          !$ACC END KERNELS
        END IF
      CASE (2)
        !$ACC KERNELS
        stbl(:, :) = soce
        !$ACC END KERNELS
        CALL sbc_isf_bg03(kt)
      CASE (3)
        IF (.NOT. l_isfcpl) THEN
          CALL fld_read(kt, nn_fsbc, sf_rnfisf)
          fwfisf(:, :) = - sf_rnfisf(1) % fnow(:, :, 1)
        END IF
        !$ACC KERNELS
        qisf(:, :) = fwfisf(:, :) * rLfusisf
        stbl(:, :) = soce
        !$ACC END KERNELS
      CASE (4)
        IF (.NOT. l_isfcpl) THEN
          CALL fld_read(kt, nn_fsbc, sf_fwfisf)
          fwfisf(:, :) = - sf_fwfisf(1) % fnow(:, :, 1)
        END IF
        !$ACC KERNELS
        qisf(:, :) = fwfisf(:, :) * rLfusisf
        stbl(:, :) = soce
        !$ACC END KERNELS
      END SELECT
      !$ACC KERNELS
      DO jj = 1, jpj
        DO ji = 1, jpi
          zdep(ji, jj) = gdepw_n(ji, jj, misfkt(ji, jj))
        END DO
      END DO
      !$ACC END KERNELS
      CALL eos_fzp(stbl(:, :), zt_frz(:, :), zdep(:, :))
      !$ACC KERNELS
      risf_tsc(:, :, jp_tem) = qisf(:, :) * r1_rau0_rcp - fwfisf(:, :) * zt_frz(:, :) * r1_rau0
      risf_tsc(:, :, jp_sal) = 0.0_wp
      !$ACC END KERNELS
      CALL lbc_lnk_multi(risf_tsc(:, :, jp_tem), 'T', 1., risf_tsc(:, :, jp_sal), 'T', 1., fwfisf, 'T', 1., qisf, 'T', 1.)
      IF (iom_use('iceshelf_cea')) CALL iom_put('iceshelf_cea', - fwfisf(:, :))
      IF (iom_use('hflx_isf_cea')) CALL iom_put('hflx_isf_cea', risf_tsc(:, :, jp_tem) * rau0 * rcp)
      IF (iom_use('qlatisf')) CALL iom_put('qlatisf', qisf(:, :))
      IF (iom_use('fwfisf')) CALL iom_put('fwfisf', fwfisf(:, :))
      IF (iom_use('fwfisf3d') .OR. iom_use('qlatisf3d') .OR. iom_use('qhcisf3d') .OR. iom_use('qhcisf')) THEN
        ALLOCATE(zfwfisf3d(jpi, jpj, jpk), zqhcisf3d(jpi, jpj, jpk), zqlatisf3d(jpi, jpj, jpk))
        ALLOCATE(zqhcisf2d(jpi, jpj))
        !$ACC KERNELS
        zfwfisf3d(:, :, :) = 0._wp
        zqhcisf3d(:, :, :) = 0._wp
        zqlatisf3d(:, :, :) = 0._wp
        zqhcisf2d(:, :) = fwfisf(:, :) * zt_frz * rcp
        DO jj = 1, jpj
          DO ji = 1, jpi
            ikt = misfkt(ji, jj)
            ikb = misfkb(ji, jj)
            DO jk = ikt, ikb - 1
              zfwfisf3d(ji, jj, jk) = zfwfisf3d(ji, jj, jk) + fwfisf(ji, jj) * r1_hisf_tbl(ji, jj) * e3t_n(ji, jj, jk)
              zqhcisf3d(ji, jj, jk) = zqhcisf3d(ji, jj, jk) + zqhcisf2d(ji, jj) * r1_hisf_tbl(ji, jj) * e3t_n(ji, jj, jk)
              zqlatisf3d(ji, jj, jk) = zqlatisf3d(ji, jj, jk) + qisf(ji, jj) * r1_hisf_tbl(ji, jj) * e3t_n(ji, jj, jk)
            END DO
            zfwfisf3d(ji, jj, jk) = zfwfisf3d(ji, jj, jk) + fwfisf(ji, jj) * r1_hisf_tbl(ji, jj) * ralpha(ji, jj) * e3t_n(ji, jj, jk)
            zqhcisf3d(ji, jj, jk) = zqhcisf3d(ji, jj, jk) + zqhcisf2d(ji, jj) * r1_hisf_tbl(ji, jj) * ralpha(ji, jj) * e3t_n(ji, jj, jk)
            zqlatisf3d(ji, jj, jk) = zqlatisf3d(ji, jj, jk) + qisf(ji, jj) * r1_hisf_tbl(ji, jj) * ralpha(ji, jj) * e3t_n(ji, jj, jk)
          END DO
        END DO
        !$ACC END KERNELS
        CALL iom_put('fwfisf3d', zfwfisf3d(:, :, :))
        CALL iom_put('qlatisf3d', zqlatisf3d(:, :, :))
        CALL iom_put('qhcisf3d', zqhcisf3d(:, :, :))
        CALL iom_put('qhcisf', zqhcisf2d(:, :))
        DEALLOCATE(zfwfisf3d, zqhcisf3d, zqlatisf3d)
        DEALLOCATE(zqhcisf2d)
      END IF
    END IF
    IF (kt == nit000) THEN
      IF (ln_rstart .AND. iom_varid(numror, 'fwf_isf_b', ldstop = .FALSE.) > 0) THEN
        IF (lwp) WRITE(numout, FMT = *) '          nit000-1 isf tracer content forcing fields read in the restart file'
        CALL iom_get(numror, jpdom_autoglo, 'fwf_isf_b', fwfisf_b(:, :), ldxios = lrxios)
        CALL iom_get(numror, jpdom_autoglo, 'isf_sc_b', risf_tsc_b(:, :, jp_sal), ldxios = lrxios)
        CALL iom_get(numror, jpdom_autoglo, 'isf_hc_b', risf_tsc_b(:, :, jp_tem), ldxios = lrxios)
      ELSE
        !$ACC KERNELS
        fwfisf_b(:, :) = fwfisf(:, :)
        risf_tsc_b(:, :, :) = risf_tsc(:, :, :)
        !$ACC END KERNELS
      END IF
    END IF
    IF (lrst_oce) THEN
      IF (lwp) WRITE(numout, FMT = *)
      IF (lwp) WRITE(numout, FMT = *) 'sbc : isf surface tracer content forcing fields written in ocean restart file ', 'at it= ', kt, ' date= ', ndastp
      IF (lwp) WRITE(numout, FMT = *) '~~~~'
      IF (lwxios) CALL iom_swap(cwxios_context)
      CALL iom_rstput(kt, nitrst, numrow, 'fwf_isf_b', fwfisf(:, :), ldxios = lwxios)
      CALL iom_rstput(kt, nitrst, numrow, 'isf_hc_b', risf_tsc(:, :, jp_tem), ldxios = lwxios)
      CALL iom_rstput(kt, nitrst, numrow, 'isf_sc_b', risf_tsc(:, :, jp_sal), ldxios = lwxios)
      IF (lwxios) CALL iom_swap(cxios_context)
    END IF
  END SUBROUTINE sbc_isf
  INTEGER FUNCTION sbc_isf_alloc()
    sbc_isf_alloc = 0
    IF (.NOT. ALLOCATED(qisf)) THEN
      ALLOCATE(risf_tsc(jpi, jpj, jpts), risf_tsc_b(jpi, jpj, jpts), qisf(jpi, jpj), rhisf_tbl(jpi, jpj), r1_hisf_tbl(jpi, jpj), rzisf_tbl(jpi, jpj), ttbl(jpi, jpj), stbl(jpi, jpj), utbl(jpi, jpj), vtbl(jpi, jpj), risfLeff(jpi, jpj), rhisf_tbl_0(jpi, jpj), ralpha(jpi, jpj), misfkt(jpi, jpj), misfkb(jpi, jpj), STAT = sbc_isf_alloc)
      IF (lk_mpp) CALL mpp_sum(sbc_isf_alloc)
      IF (sbc_isf_alloc /= 0) CALL ctl_warn('sbc_isf_alloc: failed to allocate arrays.')
    END IF
  END FUNCTION
  SUBROUTINE sbc_isf_init
    INTEGER :: ji, jj, jk
    INTEGER :: ik
    INTEGER :: ikt, ikb
    INTEGER :: inum, ierror
    INTEGER :: ios
    REAL(KIND = wp) :: zhk
    CHARACTER(LEN = 256) :: cvarzisf, cvarhisf
    CHARACTER(LEN = 32) :: cvarLeff
    NAMELIST /namsbc_isf/ nn_isfblk, rn_hisf_tbl, rn_gammat0, rn_gammas0, nn_gammablk, nn_isf, sn_fwfisf, sn_rnfisf, sn_depmax_isf, sn_depmin_isf, sn_Leff_isf
    REWIND(UNIT = numnam_ref)
    READ(numnam_ref, namsbc_isf, IOSTAT = ios, ERR = 901)
901 IF (ios /= 0) CALL ctl_nam(ios, 'namsbc_isf in reference namelist', lwp)
    REWIND(UNIT = numnam_cfg)
    READ(numnam_cfg, namsbc_isf, IOSTAT = ios, ERR = 902)
902 IF (ios > 0) CALL ctl_nam(ios, 'namsbc_isf in configuration namelist', lwp)
    IF (lwm) WRITE(numond, namsbc_isf)
    IF (lwp) WRITE(numout, FMT = *)
    IF (lwp) WRITE(numout, FMT = *) 'sbc_isf_init : heat flux of the ice shelf'
    IF (lwp) WRITE(numout, FMT = *) '~~~~~~~~~~~~'
    IF (lwp) WRITE(numout, FMT = *) '   Namelist namsbc_isf :'
    IF (lwp) WRITE(numout, FMT = *) '      type ice shelf melting/freezing         nn_isf      = ', nn_isf
    IF (lwp) WRITE(numout, FMT = *) '      bulk formulation (nn_isf=1 only)        nn_isfblk   = ', nn_isfblk
    IF (lwp) WRITE(numout, FMT = *) '      thickness of the top boundary layer     rn_hisf_tbl = ', rn_hisf_tbl
    IF (lwp) WRITE(numout, FMT = *) '      gamma formulation                       nn_gammablk = ', nn_gammablk
    IF (lwp) WRITE(numout, FMT = *) '      gammat coefficient                      rn_gammat0  = ', rn_gammat0
    IF (lwp) WRITE(numout, FMT = *) '      gammas coefficient                      rn_gammas0  = ', rn_gammas0
    IF (lwp) WRITE(numout, FMT = *) '      top drag coef. used (from namdrg_top)   rn_Cd0      = ', r_Cdmin_top
    IF (sbc_isf_alloc() /= 0) CALL ctl_stop('STOP', 'sbc_isf : unable to allocate arrays')
    !$ACC KERNELS
    qisf(:, :) = 0._wp
    fwfisf(:, :) = 0._wp
    risf_tsc(:, :, :) = 0._wp
    fwfisf_b(:, :) = 0._wp
    !$ACC END KERNELS
    SELECT CASE (nn_isf)
    CASE (1)
      IF (lwp) WRITE(numout, FMT = *)
      IF (lwp) WRITE(numout, FMT = *) '      ==>>>   presence of under iceshelf seas (nn_isf = 1)'
      !$ACC KERNELS
      rhisf_tbl(:, :) = rn_hisf_tbl
      misfkt(:, :) = mikt(:, :)
      !$ACC END KERNELS
    CASE (2, 3)
      IF (.NOT. l_isfcpl) THEN
        ALLOCATE(sf_rnfisf(1), STAT = ierror)
        ALLOCATE(sf_rnfisf(1) % fnow(jpi, jpj, 1), sf_rnfisf(1) % fdta(jpi, jpj, 1, 2))
        CALL fld_fill(sf_rnfisf, (/sn_rnfisf/), cn_dirisf, 'sbc_isf_init', 'read fresh water flux isf data', 'namsbc_isf')
      END IF
      IF (nn_isf == 2) THEN
        IF (lwp) WRITE(numout, FMT = *)
        IF (lwp) WRITE(numout, FMT = *) '      ==>>>   bg03 parametrisation (nn_isf = 2)'
        CALL iom_open(sn_Leff_isf % clname, inum)
        cvarLeff = TRIM(sn_Leff_isf % clvar)
        CALL iom_get(inum, jpdom_data, cvarLeff, risfLeff, 1)
        CALL iom_close(inum)
        risfLeff = risfLeff * 1000.0_wp
      ELSE
        IF (lwp) WRITE(numout, FMT = *)
        IF (lwp) WRITE(numout, FMT = *) '      ==>>>   rnf file for isf (nn_isf = 3)'
      END IF
      CALL iom_open(sn_depmax_isf % clname, inum)
      cvarhisf = TRIM(sn_depmax_isf % clvar)
      CALL iom_get(inum, jpdom_data, cvarhisf, rhisf_tbl, 1)
      CALL iom_close(inum)
      CALL iom_open(sn_depmin_isf % clname, inum)
      cvarzisf = TRIM(sn_depmin_isf % clvar)
      CALL iom_get(inum, jpdom_data, cvarzisf, rzisf_tbl, 1)
      CALL iom_close(inum)
      !$ACC KERNELS
      rhisf_tbl(:, :) = rhisf_tbl(:, :) - rzisf_tbl(:, :)
      !$ACC END KERNELS
      DO ji = 1, jpi
        DO jj = 1, jpj
          ik = 2
          DO WHILE (ik <= mbkt(ji, jj) .AND. gdepw_n(ji, jj, ik) < rzisf_tbl(ji, jj))
            ik = ik + 1
          END DO
          misfkt(ji, jj) = ik - 1
        END DO
      END DO
    CASE (4)
      IF (lwp) WRITE(numout, FMT = *)
      IF (lwp) WRITE(numout, FMT = *) '      ==>>>   specified fresh water flux in ISF (nn_isf = 4)'
      !$ACC KERNELS
      rhisf_tbl(:, :) = rn_hisf_tbl
      misfkt(:, :) = mikt(:, :)
      !$ACC END KERNELS
      IF (.NOT. l_isfcpl) THEN
        ALLOCATE(sf_fwfisf(1), STAT = ierror)
        ALLOCATE(sf_fwfisf(1) % fnow(jpi, jpj, 1), sf_fwfisf(1) % fdta(jpi, jpj, 1, 2))
        CALL fld_fill(sf_fwfisf, (/sn_fwfisf/), cn_dirisf, 'sbc_isf_init', 'read fresh water flux isf data', 'namsbc_isf')
      END IF
    CASE DEFAULT
      CALL ctl_stop('sbc_isf_init: wrong value of nn_isf')
    END SELECT
    !$ACC KERNELS
    rhisf_tbl_0(:, :) = rhisf_tbl(:, :)
    !$ACC END KERNELS
    DO jj = 1, jpj
      DO ji = 1, jpi
        ikt = misfkt(ji, jj)
        ikb = misfkt(ji, jj)
        rhisf_tbl(ji, jj) = MAX(rhisf_tbl_0(ji, jj), e3t_n(ji, jj, ikt))
        DO jk = ikt + 1, mbkt(ji, jj)
          IF ((SUM(e3t_n(ji, jj, ikt : jk - 1)) < rhisf_tbl(ji, jj)) .AND. (tmask(ji, jj, jk) == 1)) ikb = jk
        END DO
        rhisf_tbl(ji, jj) = MIN(rhisf_tbl(ji, jj), SUM(e3t_n(ji, jj, ikt : ikb)))
        misfkb(ji, jj) = ikb
        r1_hisf_tbl(ji, jj) = 1._wp / rhisf_tbl(ji, jj)
        zhk = SUM(e3t_n(ji, jj, ikt : ikb - 1)) * r1_hisf_tbl(ji, jj)
        ralpha(ji, jj) = rhisf_tbl(ji, jj) * (1._wp - zhk) / e3t_n(ji, jj, ikb)
      END DO
    END DO
    IF (lwxios) THEN
      CALL iom_set_rstw_var_active('fwf_isf_b')
      CALL iom_set_rstw_var_active('isf_hc_b')
      CALL iom_set_rstw_var_active('isf_sc_b')
    END IF
  END SUBROUTINE sbc_isf_init
  SUBROUTINE sbc_isf_bg03(kt)
    INTEGER, INTENT ( IN ) :: kt
    INTEGER :: ji, jj, jk
    INTEGER :: ik
    REAL(KIND = wp) :: zt_sum
    REAL(KIND = wp) :: zt_ave
    REAL(KIND = wp) :: zt_frz
    REAL(KIND = wp) :: zpress
    DO ji = 1, jpi
      DO jj = 1, jpj
        ik = misfkt(ji, jj)
        zt_sum = 0.E0_wp
        IF (ik > 1) THEN
          DO jk = misfkt(ji, jj), misfkb(ji, jj)
            zpress = grav * rau0 * gdept_n(ji, jj, ik) * 1.E-04
            CALL eos_fzp(stbl(ji, jj), zt_frz, zpress)
            zt_sum = zt_sum + (tsn(ji, jj, jk, jp_tem) - zt_frz) * e3t_n(ji, jj, jk) * tmask(ji, jj, jk)
          END DO
          zt_ave = zt_sum / rhisf_tbl(ji, jj)
          qisf(ji, jj) = - rau0 * rcp * rn_gammat0 * risfLeff(ji, jj) * e1t(ji, jj) * zt_ave * r1_e1e2t(ji, jj) * tmask(ji, jj, jk)
          fwfisf(ji, jj) = qisf(ji, jj) / rLfusisf
          fwfisf(ji, jj) = fwfisf(ji, jj) * (soce / stbl(ji, jj))
        ELSE
          qisf(ji, jj) = 0._wp
          fwfisf(ji, jj) = 0._wp
        END IF
      END DO
    END DO
  END SUBROUTINE sbc_isf_bg03
  SUBROUTINE sbc_isf_cav(kt)
    INTEGER, INTENT(IN) :: kt
    INTEGER :: ji, jj
    INTEGER :: nit
    LOGICAL :: lit
    REAL(KIND = wp) :: zlamb1, zlamb2, zlamb3
    REAL(KIND = wp) :: zeps1, zeps2, zeps3, zeps4, zeps6, zeps7
    REAL(KIND = wp) :: zaqe, zbqe, zcqe, zaqer, zdis, zsfrz, zcfac
    REAL(KIND = wp) :: zeps = 1.E-20_wp
    REAL(KIND = wp) :: zerr
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zfrz
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zgammat, zgammas
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zfwflx, zhtflx, zhtflx_b
    IF (l_useCT) THEN
      zlamb1 = - 0.0564_wp
      zlamb2 = 0.0773_wp
      zlamb3 = - 7.8633E-8 * grav * rau0
    ELSE
      zlamb1 = - 0.0573_wp
      zlamb2 = 0.0832_wp
      zlamb3 = - 7.53E-8 * grav * rau0
    END IF
    !$ACC KERNELS
    zgammat(:, :) = rn_gammat0
    zgammas(:, :) = rn_gammas0
    zhtflx(:, :) = 0.0_wp
    zhtflx_b(:, :) = 0.0_wp
    zfwflx(:, :) = 0.0_wp
    nit = 1
    lit = .TRUE.
    !$ACC END KERNELS
    DO WHILE (lit)
      SELECT CASE (nn_isfblk)
      CASE (1)
        CALL eos_fzp(stbl(:, :), zfrz(:, :), risfdep(:, :))
        CALL sbc_isf_gammats(zgammat, zgammas, zhtflx, zfwflx)
        DO jj = 1, jpj
          DO ji = 1, jpi
            zhtflx(ji, jj) = zgammat(ji, jj) * rcp * rau0 * (ttbl(ji, jj) - zfrz(ji, jj))
            zfwflx(ji, jj) = - zhtflx(ji, jj) / rLfusisf
          END DO
        END DO
        qisf(:, :) = - zhtflx(:, :) * (1._wp - tmask(:, :, 1)) * ssmask(:, :)
        fwfisf(:, :) = zfwflx(:, :) * (1._wp - tmask(:, :, 1)) * ssmask(:, :)
      CASE (2)
        CALL sbc_isf_gammats(zgammat, zgammas, zhtflx, zfwflx)
        DO jj = 1, jpj
          DO ji = 1, jpi
            zeps1 = rcp * rau0 * zgammat(ji, jj)
            zeps2 = rLfusisf * rau0 * zgammas(ji, jj)
            zeps3 = rhoisf * rcpisf * rkappa / MAX(risfdep(ji, jj), zeps)
            zeps4 = zlamb2 + zlamb3 * risfdep(ji, jj)
            zeps6 = zeps4 - ttbl(ji, jj)
            zeps7 = zeps4 - tsurf
            zaqe = zlamb1 * (zeps1 + zeps3)
            zaqer = 0.5_wp / MIN(zaqe, - zeps)
            zbqe = zeps1 * zeps6 + zeps3 * zeps7 - zeps2
            zcqe = zeps2 * stbl(ji, jj)
            zdis = zbqe * zbqe - 4.0_wp * zaqe * zcqe
            zsfrz = (- zbqe - SQRT(zdis)) * zaqer
            IF (zsfrz < 0.0_wp) zsfrz = (- zbqe + SQRT(zdis)) * zaqer
            zfrz(ji, jj) = zeps4 + zlamb1 * zsfrz
            zfwflx(ji, jj) = rau0 * zgammas(ji, jj) * (zsfrz - stbl(ji, jj)) / MAX(zsfrz, zeps)
            zhtflx(ji, jj) = zgammat(ji, jj) * rau0 * rcp * (ttbl(ji, jj) - zfrz(ji, jj))
          END DO
        END DO
        qisf(:, :) = - zhtflx(:, :) * (1._wp - tmask(:, :, 1)) * ssmask(:, :)
        fwfisf(:, :) = zfwflx(:, :) * (1._wp - tmask(:, :, 1)) * ssmask(:, :)
      END SELECT
      IF (nn_gammablk < 2) THEN
        lit = .FALSE.
      ELSE
        IF (nit >= 100) THEN
          CALL ctl_stop('STOP', 'sbc_isf_hol99 : too many iteration ...')
        ELSE
          nit = nit + 1
        END IF
        zerr = MAXVAL(ABS(zhtflx - zhtflx_b))
        IF (zerr <= 0.01_wp) THEN
          lit = .FALSE.
        ELSE
          zhtflx_b(:, :) = zhtflx(:, :)
        END IF
      END IF
    END DO
    CALL iom_put('isfgammat', zgammat)
    CALL iom_put('isfgammas', zgammas)
  END SUBROUTINE sbc_isf_cav
  SUBROUTINE sbc_isf_gammats(pgt, pgs, pqhisf, pqwisf)
    REAL(KIND = wp), DIMENSION(:, :), INTENT(  OUT) :: pgt, pgs
    REAL(KIND = wp), DIMENSION(:, :), INTENT(IN   ) :: pqhisf, pqwisf
    INTEGER :: ji, jj
    INTEGER :: ikt
    REAL(KIND = wp) :: zdku, zdkv
    REAL(KIND = wp) :: zPr, zSc, zRc
    REAL(KIND = wp) :: zmob, zmols
    REAL(KIND = wp) :: zbuofdep, zhnu
    REAL(KIND = wp) :: zhmax
    REAL(KIND = wp) :: zetastar
    REAL(KIND = wp) :: zgmolet, zgmoles, zgturb
    REAL(KIND = wp) :: zcoef
    REAL(KIND = wp) :: zdep
    REAL(KIND = wp) :: zeps = 1.0E-20_wp
    REAL(KIND = wp), PARAMETER :: zxsiN = 0.052_wp
    REAL(KIND = wp), PARAMETER :: znu = 1.95E-6_wp
    REAL(KIND = wp), DIMENSION(2) :: zts, zab
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zustar
    SELECT CASE (nn_gammablk)
    CASE (0)
      !$ACC KERNELS
      pgt(:, :) = rn_gammat0
      pgs(:, :) = rn_gammas0
      !$ACC END KERNELS
    CASE (1)
      !$ACC KERNELS
      zustar(:, :) = SQRT(r_Cdmin_top * (utbl(:, :) * utbl(:, :) + vtbl(:, :) * vtbl(:, :) + r_ke0_top))
      pgt(:, :) = zustar(:, :) * rn_gammat0
      pgs(:, :) = zustar(:, :) * rn_gammas0
      !$ACC END KERNELS
    CASE (2)
      !$ACC KERNELS
      zustar(:, :) = SQRT(r_Cdmin_top * (utbl(:, :) * utbl(:, :) + vtbl(:, :) * vtbl(:, :) + r_ke0_top))
      zPr = 13.8_wp
      zSc = 2432.0_wp
      zgmolet = 12.5_wp * zPr ** (2.0 / 3.0) - 6.0_wp
      zgmoles = 12.5_wp * zSc ** (2.0 / 3.0) - 6.0_wp
      !$ACC END KERNELS
      DO ji = 2, jpi
        DO jj = 2, jpj
          ikt = mikt(ji, jj)
          IF (zustar(ji, jj) == 0._wp) THEN
            pgt = rn_gammat0
            pgs = rn_gammas0
          ELSE
            zcoef = 0.5_wp / e3w_n(ji, jj, ikt)
            zdku = zcoef * (un(ji - 1, jj, ikt) + un(ji, jj, ikt) - un(ji - 1, jj, ikt + 1) - un(ji, jj, ikt + 1))
            zdkv = zcoef * (vn(ji, jj - 1, ikt) + vn(ji, jj, ikt) - vn(ji, jj - 1, ikt + 1) - vn(ji, jj, ikt + 1))
            zRc = rn2(ji, jj, ikt + 1) / MAX(zdku * zdku + zdkv * zdkv, zeps)
            zts(jp_tem) = ttbl(ji, jj)
            zts(jp_sal) = stbl(ji, jj)
            zdep = gdepw_n(ji, jj, ikt)
            CALL eos_rab(zts, zdep, zab)
            zbuofdep = grav * (zab(jp_tem) * pqhisf(ji, jj) - zab(jp_sal) * pqwisf(ji, jj))
            zhmax = gdept_n(ji, jj, mbkt(ji, jj)) - gdepw_n(ji, jj, mikt(ji, jj)) - 0.001_wp
            zmob = zustar(ji, jj) ** 3 / (vkarmn * (zbuofdep + zeps))
            zmols = SIGN(1._wp, zmob) * MIN(ABS(zmob), zhmax) * tmask(ji, jj, ikt)
            zetastar = 1._wp / (SQRT(1._wp + MAX(zxsiN * zustar(ji, jj) / (ABS(ff_f(ji, jj)) * zmols * zRc), 0._wp)))
            zhnu = 5 * znu / zustar(ji, jj)
            zgturb = 1._wp / vkarmn * LOG(zustar(ji, jj) * zxsiN * zetastar * zetastar / (ABS(ff_f(ji, jj)) * zhnu)) + 1._wp / (2 * zxsiN * zetastar) - 1._wp / vkarmn
            pgt(ji, jj) = zustar(ji, jj) / (zgturb + zgmolet)
            pgs(ji, jj) = zustar(ji, jj) / (zgturb + zgmoles)
          END IF
        END DO
      END DO
      CALL lbc_lnk_multi(pgt, 'T', 1., pgs, 'T', 1.)
    END SELECT
  END SUBROUTINE sbc_isf_gammats
  SUBROUTINE sbc_isf_tbl(pvarin, pvarout, cd_ptin)
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(IN   ) :: pvarin
    REAL(KIND = wp), DIMENSION(:, :), INTENT(  OUT) :: pvarout
    CHARACTER(LEN = 1), INTENT(IN   ) :: cd_ptin
    INTEGER :: ji, jj, jk
    INTEGER :: ikt, ikb
    REAL(KIND = wp) :: ze3, zhk
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zhisf_tbl
    !$ACC KERNELS
    pvarout(:, :) = 0._wp
    !$ACC END KERNELS
    SELECT CASE (cd_ptin)
    CASE ('U')
      DO jj = 1, jpj
        DO ji = 1, jpi
          ikt = miku(ji, jj)
          ikb = miku(ji, jj)
          zhisf_tbl(ji, jj) = MAX(rhisf_tbl_0(ji, jj), e3u_n(ji, jj, ikt))
          DO jk = ikt + 1, mbku(ji, jj)
            IF ((SUM(e3u_n(ji, jj, ikt : jk - 1)) < zhisf_tbl(ji, jj)) .AND. (umask(ji, jj, jk) == 1)) ikb = jk
          END DO
          zhisf_tbl(ji, jj) = MIN(zhisf_tbl(ji, jj), SUM(e3u_n(ji, jj, ikt : ikb)))
          !$ACC KERNELS
          DO jk = ikt, ikb - 1
            ze3 = e3u_n(ji, jj, jk)
            pvarout(ji, jj) = pvarout(ji, jj) + pvarin(ji, jj, jk) / zhisf_tbl(ji, jj) * ze3
          END DO
          !$ACC END KERNELS
          zhk = SUM(e3u_n(ji, jj, ikt : ikb - 1)) / zhisf_tbl(ji, jj)
          pvarout(ji, jj) = pvarout(ji, jj) + pvarin(ji, jj, ikb) * (1._wp - zhk)
        END DO
      END DO
      !$ACC KERNELS
      DO jj = 2, jpj
        DO ji = 2, jpi
          pvarout(ji, jj) = 0.5_wp * (pvarout(ji, jj) + pvarout(ji - 1, jj))
        END DO
      END DO
      !$ACC END KERNELS
      CALL lbc_lnk(pvarout, 'T', - 1.)
    CASE ('V')
      DO jj = 1, jpj
        DO ji = 1, jpi
          ikt = mikv(ji, jj)
          ikb = mikv(ji, jj)
          zhisf_tbl(ji, jj) = MAX(rhisf_tbl_0(ji, jj), e3v_n(ji, jj, ikt))
          DO jk = ikt + 1, mbkv(ji, jj)
            IF ((SUM(e3v_n(ji, jj, ikt : jk - 1)) < zhisf_tbl(ji, jj)) .AND. (vmask(ji, jj, jk) == 1)) ikb = jk
          END DO
          zhisf_tbl(ji, jj) = MIN(zhisf_tbl(ji, jj), SUM(e3v_n(ji, jj, ikt : ikb)))
          !$ACC KERNELS
          DO jk = ikt, ikb - 1
            ze3 = e3v_n(ji, jj, jk)
            pvarout(ji, jj) = pvarout(ji, jj) + pvarin(ji, jj, jk) / zhisf_tbl(ji, jj) * ze3
          END DO
          !$ACC END KERNELS
          zhk = SUM(e3v_n(ji, jj, ikt : ikb - 1)) / zhisf_tbl(ji, jj)
          pvarout(ji, jj) = pvarout(ji, jj) + pvarin(ji, jj, ikb) * (1._wp - zhk)
        END DO
      END DO
      !$ACC KERNELS
      DO jj = 2, jpj
        DO ji = 2, jpi
          pvarout(ji, jj) = 0.5_wp * (pvarout(ji, jj) + pvarout(ji, jj - 1))
        END DO
      END DO
      !$ACC END KERNELS
      CALL lbc_lnk(pvarout, 'T', - 1.)
    CASE ('T')
      DO jj = 1, jpj
        DO ji = 1, jpi
          !$ACC KERNELS
          ikt = misfkt(ji, jj)
          ikb = misfkb(ji, jj)
          DO jk = ikt, ikb - 1
            ze3 = e3t_n(ji, jj, jk)
            pvarout(ji, jj) = pvarout(ji, jj) + pvarin(ji, jj, jk) * r1_hisf_tbl(ji, jj) * ze3
          END DO
          !$ACC END KERNELS
          zhk = SUM(e3t_n(ji, jj, ikt : ikb - 1)) * r1_hisf_tbl(ji, jj)
          pvarout(ji, jj) = pvarout(ji, jj) + pvarin(ji, jj, ikb) * (1._wp - zhk)
        END DO
      END DO
    END SELECT
    !$ACC KERNELS
    pvarout(:, :) = pvarout(:, :) * ssmask(:, :)
    !$ACC END KERNELS
  END SUBROUTINE sbc_isf_tbl
  SUBROUTINE sbc_isf_div(phdivn)
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT( INOUT ) :: phdivn
    INTEGER :: ji, jj, jk
    INTEGER :: ikt, ikb
    REAL(KIND = wp) :: zhk
    REAL(KIND = wp) :: zfact
    zfact = 0.5_wp
    IF (.NOT. ln_linssh) THEN
      DO jj = 1, jpj
        DO ji = 1, jpi
          ikt = misfkt(ji, jj)
          ikb = misfkt(ji, jj)
          rhisf_tbl(ji, jj) = MAX(rhisf_tbl_0(ji, jj), e3t_n(ji, jj, ikt))
          DO jk = ikt, mbkt(ji, jj)
            IF ((SUM(e3t_n(ji, jj, ikt : jk - 1)) .LT. rhisf_tbl(ji, jj)) .AND. (tmask(ji, jj, jk) == 1)) ikb = jk
          END DO
          rhisf_tbl(ji, jj) = MIN(rhisf_tbl(ji, jj), SUM(e3t_n(ji, jj, ikt : ikb)))
          misfkb(ji, jj) = ikb
          r1_hisf_tbl(ji, jj) = 1._wp / rhisf_tbl(ji, jj)
          zhk = SUM(e3t_n(ji, jj, ikt : ikb - 1)) * r1_hisf_tbl(ji, jj)
          ralpha(ji, jj) = rhisf_tbl(ji, jj) * (1._wp - zhk) / e3t_n(ji, jj, ikb)
        END DO
      END DO
    END IF
    !$ACC KERNELS
    DO jj = 1, jpj
      DO ji = 1, jpi
        ikt = misfkt(ji, jj)
        ikb = misfkb(ji, jj)
        DO jk = ikt, ikb - 1
          phdivn(ji, jj, jk) = phdivn(ji, jj, jk) + (fwfisf(ji, jj) + fwfisf_b(ji, jj)) * r1_hisf_tbl(ji, jj) * r1_rau0 * zfact
        END DO
        phdivn(ji, jj, ikb) = phdivn(ji, jj, ikb) + (fwfisf(ji, jj) + fwfisf_b(ji, jj)) * r1_hisf_tbl(ji, jj) * r1_rau0 * zfact * ralpha(ji, jj)
      END DO
    END DO
    !$ACC END KERNELS
  END SUBROUTINE sbc_isf_div
END MODULE sbcisf


!===============================================================================
module stack
!===============================================================================
!
! Routines for stacking seismograms stored in SAC format.
!
! Andy Nowacki
! a.nowacki@leeds.ac.uk
!

   use, intrinsic :: iso_c_binding, only: C_FLOAT, C_DOUBLE
   use f90sac
   ! Use the OpenMP module if needed
!$ use omp_lib

   implicit none

   private

   ! Precision selectors--based on C types because we deal with SAC data
   integer, parameter :: r4 = C_FLOAT, r8 = C_DOUBLE
   integer, parameter :: rs = r4

   ! I/O
   integer, parameter :: lu_stdin = 5, lu_stdout = 6, lu_stderr = 0, &
                         lu_in = 10, lu_out = 11

   ! Useful constants
   real(rs), parameter :: pi = real(4.d0*atan2(1.d0, 1.d0), rs)
   real(rs), parameter :: todeg = 180._rs/pi, torad = pi/180._rs, deg2km = 111.19_rs
   real(rs), parameter :: R_EARTH_KM = 6371._rs
   real(rs), parameter :: s_deg2s_km = 180._rs/(pi*R_EARTH_KM)

   ! Length parameters
   integer, parameter :: STACK_CHAR_LEN = 30

   interface stack_allocate
      module procedure :: stack_allocate_r4_1d, stack_allocate_r4_2d
   end interface stack_allocate

   public :: &
      stack_array_geography, stack_fk, stack_geog_mean, stack_sum, stack_vespa_slow

contains

!===============================================================================
subroutine stack_fk(s, t1, t2, sxmin, sxmax, symin, symax, ds, out, pick, type, n, ux, uy)
!===============================================================================
! Perform f-k analysis on an array of SAC traces.  Search over a range of
! slowness vectors with maximum magnitude smax in ds increments.
!  INPUT:
!     s(:)    : SACtrace array of input traces
!     t1, t2  : Start and stop time window in s
!     sxmin   : Minimum slowness in x direction in s/deg
!     sxmax   : Maximum slowness in x direction in s/deg
!     symin   : Minimum slowness in y direction in s/deg
!     symax   : Maximum slowness in y direction in s/deg
!     ds      : Slowness increment in s/deg
!  INPUT (OPTIONAL):
!     pick(:) : Array of pick times relative to which vespagram is made
!     type    : Character determining stack type.  See stack_sum() for details.
!     n       : Power of the stack; see stack_sum() for details.
!  OUTPUT:
!     out(:,:): Allocatable array of size(n,n), where n = 2*smax/ds + 1,
!               containing the normalised beam power at each point over the time
!               window of interest, which is the summed squared amplitudes.
!  OUTPUT (OPTIONAL):
!     ux(:)   : Allocatable array containing the values of slowness in the x direction
!     uy(:)   : Allocatable array containing the values of slowness in the y direction
!
   type(SACtrace), intent(in) :: s(:)
   real(rs), intent(in) :: t1, t2, sxmin, sxmax, symin, symax, ds
   real(rs), allocatable, intent(inout) :: out(:,:)
   real(rs), intent(in), optional, dimension(size(s)) :: pick
   character(len=*), intent(in), optional :: type
   integer, intent(in), optional :: n
   real(rs), intent(out), allocatable, optional :: ux(:), uy(:)
   type(SACtrace) :: trace
   real(rs), dimension(size(s)) :: pick_in, x, y, r, phi, delay
   character(len=STACK_CHAR_LEN) :: type_in
   real(rs) :: lon, lat, uxi, uyi
   integer :: i, ix, iy, n_in, nx, ny

   ! Basic checks on input
   call stack_check(s)

   if (t2 <= t1) call stack_error('stack_fk: Start time must be before end time')
   if (sxmin >= sxmax) call stack_error('stack_fk: Minimum sx must be less than maximum')
   if (symin >= symax) call stack_error('stack_fk: Minimum sy must be less than maximum')
   if (present(pick)) then
      if (size(pick) /= size(s)) &
         call stack_error('stack_fk: Pick array must be same length as number of traces')
      if (any(pick > s%e .or. pick < s%b)) &
         call stack_error('stack_fk: Picks must not be outside trace')
      if (any(pick + t2 > s%e .or. pick - t1 < s%b)) &
         call stack_error('stack_fk: Window around picks is outside data range')
   endif
   if (any(s%stlo == SAC_rnull .or. s%stla == SAC_rnull)) &
      call stack_error('stack_fk: All stations must headers STLO and STLA filled')

   ! Change defaults if necessary
   type_in = 'linear'
   if (present(type)) type_in = type
   n_in = 2
   if (present(n)) n_in = n
   pick_in = 0._rs
   if (present(pick)) pick_in = pick

   ! Calculate mean coordinates and get array of cartesian coordinates in km,
   ! relative to the mean point at (0,0)
   call stack_calc_station_coords(s%stlo, s%stla, lon, lat, x, y, r, phi)

   ! Calculate size of output and allocate
   nx = int((sxmax - sxmin)/ds) + 1
   ny = int((symax - symin)/ds) + 1
   call stack_allocate(out, nx, ny)

   ! Create stack at each slowness point
   do iy = 1, ny
      uyi = symin + real(iy-1)*ds
      uyi = uyi*s_deg2s_km
      do ix = 1, nx
         uxi = sxmin + real(ix-1)*ds
         uxi = uxi*s_deg2s_km
         delay = pick_in - stack_station_delay(x, y, uxi, uyi)
         call stack_sum(s, trace, t1=t1, t2=t2, delay=delay, type=type_in, n=n_in)
         out(ix,iy) = sum(trace%trace**2)
      enddo
   enddo

   out = out/maxval(out)

   ! If requested, fill in the slowness axes
   if (present(ux)) then
      call stack_allocate(ux, nx)
      ux = [(sxmin + real(i-1)*ds, i = 1, nx)]
   endif
   if (present(uy)) then
      call stack_allocate(uy, ny)
      uy = [(symin + real(i-1)*ds, i = 1, ny)]
   endif

end subroutine stack_fk
!-------------------------------------------------------------------------------

!===============================================================================
subroutine stack_vespa_slow(s, t1, t2, s1, s2, ds, out, pick, type, n, envelope, &
                            time, slowness)
!===============================================================================
! Take an array of SAC traces and return the slowness vespagram.  This is done
! relative to the geographic mean point of the array, using the backazimuth from
! this point to the event which must be in at least the first trace's header.
!  INPUT:
!     s(:)    : SACtrace array of input traces
!     t1, t2  : Start and stop time window in s
!     s1, s2  : Start and end slownesses in s/deg
!     ds      : Slowness increment in s/deg
!  INPUT (OPTIONAL):
!     pick    : Array of pick times relative to which vespagram is made.
!               must be an array of size(s)
!     type    : Character determining stack type.  See stack_sum() for details.
!     n       : Power of the stack; see stack_sum() for details.
!     envelope: If .true., convert stack sum into envelope.
!  OUTPUT:
!     out(:,:): Alloctable array of size((t2 - t1)/s(1)%delta+1, (s2-s1)/ds+1)
!               containing the normalised beam power at each (s,t) point.
!  OUTPUT (OPTIONAL):
!     time(:) : Alloctable array of size((t2-t1)/s(1)%delta+1) containing the
!               values of the times in the vespa grid (s)
!     slow(:) : Alloctable array of size((s2-s1)/ds+1) containing the slownesses
!               in the vespa grid (s/deg)
!
   type(SACtrace), intent(in) :: s(:)
   real(rs), intent(in) :: t1, t2, s1, s2, ds
   real(rs), allocatable, intent(inout) :: out(:,:)
   real(rs), intent(in), optional :: pick(size(s))
   character(len=*), intent(in), optional :: type
   integer, intent(in), optional :: n
   logical, optional, intent(in) :: envelope
   real(rs), allocatable, intent(inout), optional :: time(:), slowness(:)
   type(SACtrace) :: trace
   real(rs) :: pick_in(size(s)), delay(size(s))
   character(len=STACK_CHAR_LEN) :: type_in
   integer :: n_in, ns, nt, i, j
   real(rs) :: lon, lat, x(size(s)), y(size(s)), r(size(s)), phi(size(s))
   real(rs) :: slow, ref_az, ref_baz, ref_delta, ux, uy

   ! Basic checks on input
   call stack_check(s)

   if (t2 <= t1) call stack_error('stack_vespa: Start time must be before end time')
   if (present(pick)) then
      if (size(pick) /= size(s)) &
         call stack_error('stack_vespa: Pick array must be same length as number of traces')
      if (any(pick > s%e .or. pick < s%b)) &
         call stack_error('stack_vespa: Picks must not be outside trace')
      if (any(pick + t2 > s%e .or. pick - t1 < s%b)) &
         call stack_error('stack_vespa: Window around picks is outside data range')
   endif
   if (s(1)%evlo == SAC_rnull .or. s(1)%evla == SAC_rnull) &
      call stack_error('stack_vespa: Event location headers must be in first trace')
   if (any(s%stlo == SAC_rnull .or. s%stla == SAC_rnull)) &
      call stack_error('stack_vespa: All stations must headers STLO and STLA filled')

   ! Change defaults if necessary
   type_in = 'linear'
   if (present(type)) type_in = type
   n_in = 2
   if (present(n)) n_in = n
   pick_in = 0._rs
   if (present(pick)) pick_in = pick

   ! Calculate mean coordinates and get array of cartesian coordinates in km,
   ! relative to the mean point at (0,0)
   call stack_calc_station_coords(s%stlo, s%stla, lon, lat, x, y, r, phi)
   ref_delta = stack_delta(s(1)%evlo, s(1)%evla, lon, lat)
   ref_baz = stack_azimuth(lon, lat, s(1)%evlo, s(1)%evla)
   ref_az = ref_baz + 180._rs

   ! Allocate vespagram array
   ns = int((s2 - s1)/ds) + 1
   nt = int((t2 - t1)/s(1)%delta) + 1
   call stack_allocate(out, nt, ns)

   ! Calculate stack at each slowness point, filling the vespagram
   do j = 1, ns
      slow = s1 + real(j-1)*ds ! s/deg
      slow = slow*s_deg2s_km ! s/km
      ux = slow*sin(torad*ref_az)
      uy = slow*cos(torad*ref_az)
      ! Create the delays at each station for this slowness
      delay = pick_in + stack_station_delay(x, y, ux, uy)
      call stack_sum(s, trace, t1=t1, t2=t2, delay=delay, type=type_in, n=n_in)
      out(:,j) = trace%trace
   enddo

   ! If desired, output time and slowness arrays
   if (present(time)) then
      call stack_allocate(time, nt)
      time = [(t1 + real(i-1)*s(1)%delta, i = 1, nt)]
   endif
   if (present(slowness)) then
      call stack_allocate(slowness, ns)
      slowness = [(s1 + real(i-1)*ds, i = 1, ns)]
   endif

   ! Output envelope if desired
   if (present(envelope)) then
      if (envelope) call stack_envelope(out)
   endif

   ! Normalise vespagram
   out = out/maxval(abs(out))

end subroutine stack_vespa_slow
!-------------------------------------------------------------------------------

!===============================================================================
subroutine stack_sum(s, out, t1, t2, pick, delay, type, n)
!===============================================================================
! Take an array of SAC traces and return the summed trace between times t1 and t2
! (if given), or just the whole trace.
!  INPUT:
!     s(:)   : SACtrace array of input traces
!  INPUT (OPTIONAL):
!     t1, t2 : Start and stop times for output stack.  Relative to O time, unless
!              pick array is supplied
!     pick(:): Array of pick times relative to which stack is performed.  Must be
!              an array of size(s)
!     delay(:):Array of delay times by which to shuffle traces.  Must be array of
!              size(s)
!     type   : Character containing one of:
!                 '[l]inear'        : Simple linear stack [default]
!                 '[n]throot'       : N-th root stack
!                 '[p]haseweighted' : Phase-weighted stack
!     n      : If 'nthroot' or 'phaseweighted' are chosed, this option determined
!              the power for the stack.  [Default 2]
!  OUTPUT:
!     out(:) : SACtrace containing the stack
!
   type(SACtrace), intent(in) :: s(:)
   type(SACtrace), intent(inout) :: out
   real(rs), intent(in), optional :: t1, t2, pick(:), delay(:)
   character(len=*), intent(in), optional :: type
   integer, intent(in), optional :: n
   real(rs) :: w1, w2
   integer :: npts
   real(rs), dimension(size(s)) :: pick_in, delay_in
   character(len=STACK_CHAR_LEN) :: type_in
   integer :: n_in

   ! Basic checks on input
   call stack_check(s)

   ! Populate internal pick and delay arrays
   if (present(pick)) then
      pick_in = pick
   else
      pick_in = 0._rs
   endif
   if (present(delay)) then
      delay_in = delay
   else
      delay_in = 0._rs
   endif

   ! Check input
   w1 = maxval(s%b)
   w2 = minval(s%e)
   if (present(t1)) w1 = t1
   if (present(t2)) w2 = t2
   if (w2 <= w1) call stack_error('stack_sum: Start time must be before end time')
   if (present(pick)) then
      if (size(pick) /= size(s)) &
         call stack_error('stack_sum: Pick array must be same length as number of traces')
      if (any(pick - delay > s%e .or. pick - delay < s%b)) &
         call stack_error('stack_sum: Picks must not be outside trace')
      if (any(pick + t2 - delay > s%e .or. pick - t1 - delay < s%b)) &
         call stack_error('stack_sum: Window around picks is outside data range')
   endif
   type_in = 'linear'
   if (present(type)) type_in = type
   n_in = 2
   if (present(n)) n_in = n

   ! Make space for stack
   npts = int((w2 - w1)/s(1)%delta) + 1
   call f90sac_newtrace(npts, s(1)%delta, out)
   out%b = w1
   out%e = w2

   ! Peform the stack
   select case (type_in(1:1))
      case ('l', 'L')
         call stack_sum_linear(s, pick_in, delay_in, w1, w2, npts, out%trace)
      case ('n', 'N')
         call stack_sum_nthroot(s, pick_in, delay_in, w1, w2, n_in, npts, out%trace)
      case ('p', 'P')
         call stack_sum_phaseweighted(s, pick_in, delay_in, w1, w2, n_in, npts, out%trace)
      case default
         call stack_error('stack_sum: Unimplemented stack type "'//trim(type_in)//'"')
   end select

end subroutine stack_sum
!-------------------------------------------------------------------------------

!===============================================================================
subroutine stack_sum_linear(s, pick, delay, w1, w2, npts, out)
!===============================================================================
! Perform a linear stack.
!  INPUT:
!     s(:)    : Array of SAC traces for stacking
!     pick(:) : Times relative to which w1 and w2 are made (one per SAC trace)
!     delay(:): Delay by which to shift traces (one per SAC trace)
!     w1, w2  : Start and stop times of stack, relative to pick(:)
!     npts    : Length of stacked trace
!  OUTPUT:
!     out(npts) : Array containing points of the stack
!
   type(SACtrace), intent(in) :: s(:)
   real(rs), intent(in) :: pick(:), delay(:), w1, w2
   integer, intent(in) :: npts
   real(rs), intent(out) :: out(npts)
   integer :: i, j, iw1, iw2

   out = 0._rs
!$omp parallel do default(none) shared(s, npts, out, pick, delay, w1, w2) &
!$omp    private(i, j, iw1, iw2)
   do i = 1, size(s)
      iw1 = nint((pick(i) - delay(i) + w1 - s(i)%b)/s(1)%delta) + 1
      iw2 = iw1 + npts - 1
      do j = iw1, iw2
         out(j-iw1+1) = out(j-iw1+1) + s(i)%trace(j)
      enddo
   enddo
!$omp end parallel do
   out = out/real(size(s))

end subroutine stack_sum_linear
!-------------------------------------------------------------------------------

!===============================================================================
subroutine stack_sum_nthroot(s, pick, delay, w1, w2, n, npts, out)
!===============================================================================
! Perform an N-th root stack.
!  INPUT:
!     s(:)    : Array of SAC traces for stacking
!     pick(:) : Times relative to which w1 and w2 are made (one per SAC trace)
!     delay(:): Delay by which to shift traces (one per SAC trace)
!     w1, w2  : Start and stop times of stack, relative to pick(:)
!     n       : Power to which to raise stack
!     npts    : Length of stacked trace
!  OUTPUT:
!     out(npts) : Array containing points of the stack
!
   type(SACtrace), intent(in) :: s(:)
   real(rs), intent(in) :: pick(:), delay(:), w1, w2
   integer, intent(in) :: n, npts
   real(rs), intent(out) :: out(npts)
   integer :: i, j, iw1, iw2

   out = 0._rs
!$omp parallel do default(none) shared(s, npts, n, out, pick, delay, w1, w2) &
!$omp    private(i, j, iw1, iw2)
   do i = 1, size(s)
      iw1 = nint((pick(i) - delay(i) + w1 - s(i)%b)/s(1)%delta) + 1
      iw2 = iw1 + npts - 1
      do j = iw1, iw2
         out(j-iw1+1) = out(j-iw1+1) + &
            sign(abs(s(i)%trace(j))**(1._rs/real(n)), s(i)%trace(j))
      enddo
   enddo
!$omp end parallel do
   out = sign(out**n, out)/real(size(s))
end subroutine stack_sum_nthroot
!-------------------------------------------------------------------------------

!===============================================================================
subroutine stack_sum_phaseweighted(s, pick, delay, w1, w2, nu, npts, out)
!===============================================================================
! Perform a phase-weighted stack.
!  INPUT:
!     s(:)    : Array of SAC traces for stacking
!     pick(:) : Times relative to which w1 and w2 are made (one per SAC trace)
!     delay(:): Delay by which to shift traces (one per SAC trace)
!     w1, w2  : Start and stop times of stack, relative to pick(:)
!     nu      : Power to which to raise coherency
!     npts    : Length of stacked trace
!  OUTPUT:
!     out(npts) : Array containing points of the stack
!
! The phase-weighted stack is given by:
!
!     v(t) = (1/N) \Sigma_{j=1}^N s_j(t) abs[(1/N) \Sigma_{k=1}^N exp(i\Phi_k(t))]^\nu
!
! (Eq. 4 of Schimmel & Paulssen, GJI, 1997)
! with N = number of traces, s_j(t) is the time-domain signal for the jth trace,
! i is sqrt(-1), \Phi_k(t) is the instantaneous phase of the kth trace, and \nu
! is the power parameter.  \Phi(t) is given by arg(s(t) + i*H(t)), where H(t)
! is the Hilbert transform of the trace s(t).
! We therefore must construct the Hilbert trace for each trace
!
   type(SACtrace), intent(in) :: s(:)
   real(rs), intent(in) :: pick(:), delay(:), w1, w2
   integer, intent(in) :: nu, npts
   real(rs), intent(out) :: out(npts)
   real(rs), dimension(npts,size(s)) :: trace, hilbert, phase
   real(rs) :: weight
   integer :: n, i, j, iw1, iw2

   n = size(s)

   ! Create Hilbert traces
   do i = 1, n
      iw1 = nint((pick(i) - delay(i) + w1 - s(i)%b)/s(1)%delta) + 1
      iw2 = iw1 + npts - 1
      trace(:,i) = s(i)%trace(iw1:iw2)
   enddo
   hilbert = stack_hilbert(trace, n, npts)

   ! Create array of phase at each point for each trace
   phase = atan2(hilbert, trace)

   ! Do the stack
   out = 0._rs
!$omp parallel do default(none) shared(phase, n, out, trace, nu, npts) &
!$omp    private(i, j, weight)
   do i = 1, n
      do j = 1, npts
         weight = abs(sum(exp(phase(j,:)))/real(n))
         out(j) = out(j) + trace(j,i)*weight**nu
      enddo
   enddo
!$omp end parallel do
   out = out/real(n)

end subroutine stack_sum_phaseweighted
!-------------------------------------------------------------------------------

!===============================================================================
function stack_station_delay(x, y, ux, uy) result(t)
!===============================================================================
! Return an array containing the relative station delay times for a wave with
! horizontal slowness components ux and uy, at stations with relative coordinates
! in x and y.
!  INPUT:
!     x(:), y(:) : Station coordinates relative to the array centre (units
!                  determine output)
!     ux, uy     : Horizontal slowness vector components: ux is east, uy is north
!                  (units should be s/distance, i.e., s/km)
!  OUTPUT:
!     t(:)       : Relative delay times for stations in s
!
   real(rs), intent(in) :: x(:), y(:), ux, uy
   real(rs) :: t(size(x))

   if (size(y) /= size(x)) &
      call stack_error('stack_station_delay: x and y locations must have same length')
   t = -(x*ux + y*uy)
end function stack_station_delay
!-------------------------------------------------------------------------------

!===============================================================================
function stack_hilbert(y, n, npts) result(h)
!===============================================================================
! Return the hilbert transformed version of y(npts,n), which contains n traces
! of npts length.
! This routine uses FFTW3, and for various reasons it is impractical to assume
! that it has been compiled correctly to handle multithreading, so we do not use
! OpenMP here.
! Note that because we are using the real-to-complex transforms, we only have the
! positive frequencies in c, so we can multiply everything by -i.
!
   use, intrinsic :: iso_c_binding
   include 'fftw3.f03'
   real(C_FLOAT), intent(in) :: y(npts,n)
   integer, intent(in) :: n, npts
   real(rs) :: h(npts,n), h_temp(npts), y_temp(npts)
   complex(C_FLOAT) :: c(npts/2+1)
   type(C_PTR) :: plan_fwd, plan_rev
   integer(C_INT), parameter :: fftw_plan_type = FFTW_ESTIMATE
   integer :: i

   ! Create plans, which we can reuse if we use the same arrays
   plan_fwd = fftwf_plan_dft_r2c_1d(int(npts, kind=C_INT), y_temp, c, fftw_plan_type)
   plan_rev = fftwf_plan_dft_c2r_1d(int(npts, kind=C_INT), c, h_temp, fftw_plan_type)
   ! Make Hilbert traces by multiplying the frequency-domain complex traces by -i
   do i = 1, n
      y_temp = y(:,i)
      call fftwf_execute_dft_r2c(plan_fwd, y_temp, c)
      c = c*complex(0._rs, -1._rs)
      call fftwf_execute_dft_c2r(plan_rev, c, h_temp)
      h(:,i) = h_temp
   enddo
   ! Normalise values back to original amplitude
   h = h/real(npts)
   ! Deassociate pointers
   call fftwf_destroy_plan(plan_fwd)
   call fftwf_destroy_plan(plan_rev)
end function stack_hilbert
!-------------------------------------------------------------------------------

!===============================================================================
subroutine stack_envelope(s)
!===============================================================================
! Replace the input set of traces s(npts,n) with their envelope.
!
   real(rs), intent(inout) :: s(:,:)
   integer :: npts, n

   npts = size(s, 1)
   n = size(s, 2)
   s = sqrt(s**2 + stack_hilbert(s, n, npts)**2)
end subroutine stack_envelope
!-------------------------------------------------------------------------------

!===============================================================================
subroutine stack_array_geography(s, lon, lat, gcarc, baz, evdp)
!===============================================================================
! Return the mean location, distance and some other information about the
! stack for this event.
!
   type(SACtrace), intent(in) :: s(:)
   real(rs), intent(out) :: lon, lat, gcarc, baz, evdp

   call stack_geog_mean(s%stlo, s%stla, lon, lat)
   gcarc = stack_delta(s(1)%evlo, s(1)%evla, lon, lat)
   baz = stack_azimuth(lon, lat, s(1)%evlo, s(1)%evla)
   evdp = s(1)%evdp
end subroutine stack_array_geography
!-------------------------------------------------------------------------------

!===============================================================================
subroutine stack_geog_mean(lon, lat, mean_lon, mean_lat)
!===============================================================================
! Calculate  mean geographic coordinates, given arrays of longitude and
! latitude in degrees.  Assumes points are on the same sphere.
!
   real(rs), intent(in), dimension(:) :: lon, lat
   real(rs), intent(out) :: mean_lon, mean_lat
   real(rs) :: x(3), xs(3), r
   integer :: i

   if (size(lon) /= size(lat)) &
      call stack_error('stack_geog_mean: Input arrays must be same length')
   xs = 0.
   do i = 1, size(lon)
      call stack_geog2cart(lon(i), lat(i), 1., x(1), x(2), x(3))
      xs = xs + x
   enddo
   mean_lon = atan2(xs(2), xs(1))*todeg
   r = sqrt(sum(xs**2))
   mean_lat = asin(xs(3)/r)*todeg
end subroutine stack_geog_mean
!-------------------------------------------------------------------------------

!===============================================================================
subroutine stack_calc_station_coords(lon, lat, mean_lon, mean_lat, xs, ys, dist, phi)
!===============================================================================
! Calculate the cartesian coordinates of the stations, relative to the mean
! longitude and latitude.  This is done by projecting the points on a sphere
! to the tangent plane at the centre of the array (lon_mean, lat_mean).
!  INPUT:
!     lon, lat : Arrays of geographic points (degrees)
!  OUTPUT:
!     mean_lon, mean_lat : Spherical mean of input points
!     xs, ys   : Arrays of coordinates of array plane, with y parallel to local
!                north at the mean point, and y parallel to local east (km)
!     dist     : Array of distances from mean point to station (km)
!     phi      : Array of azimuths from mean point to station (deg)
   real(rs), intent(in), dimension(:) :: lon, lat
   real(rs), intent(out) :: mean_lon, mean_lat
   real(rs), intent(out), dimension(size(lon)) :: xs, ys, dist, phi
   real(rs) :: x, y, z, d
   real(rs) :: m(3), n(3), r(3), s(3), t(3), north(3), p(3), norm
   integer :: i

   if (.not.all([size(lat), size(xs), size(ys), size(dist), size(phi)] &
                == size(lon))) &
      call stack_error('stack_calc_station_coords: Arrays must be the same length')
   call stack_geog_mean(lon, lat, mean_lon, mean_lat)
   if (abs(mean_lat) >= 89.999999) &
      call stack_error('stack_calc_station_coords: Array mean is on the pole')

   ! Find mean point and normal to plane
   call stack_geog2cart(mean_lon, mean_lat, R_EARTH_KM, m(1), m(2), m(3))
   n = m/sqrt(sum(m**2))
   ! Local north unit vector at mean point
   call stack_lonlat2local_north(mean_lon, mean_lat, north(1), north(2), north(3))
!    write(*,*) 0,0,0,0
!    write(*,*) n,0
!    write(*,*)
!    write(*,*)
!    write(*,*) 0,0,0,1
!    write(*,*) north,1
!    if (abs(dot_product(north, n)) > 1.e30*tiny(1._rs)) & ! Should be orthogonal
!       call stack_error('stack_calc_station_coords: Error in calculating normal or local north')
   do i = 1, size(lon)
      ! Calculate cartesian point of station on surface in km, r
      call stack_geog2cart(lon(i), lat(i), R_EARTH_KM, r(1), r(2), r(3))
      ! Vector to point of station projected to plane, s
      d = dot_product(n, m - r)
      s = r + d*n
      ! Vector t from mean point to station has length dist km
      t = s - m
      dist(i) = sqrt(sum(t**2))
      ! Angle
      phi(i) = acos(dot_product(t, north)/dist(i))
      ! p is cross-product between local north and vector from mean point
      ! to station
      p = cross_product(t, north)/dist(i)
      ! The angle is in the opposite direction if the cross product is antiparallel
      ! to the plane normal (i.e., p ^ n < 0)
      if (dot_product(p, n) < 0.) phi(i) = -phi(i)
   enddo

   ! And rexpress things onto the plane
   xs = dist*sin(phi)
   ys = dist*cos(phi)
   phi = todeg*phi
   phi = modulo(phi, 360._rs)

end subroutine stack_calc_station_coords
!-------------------------------------------------------------------------------

!===============================================================================
subroutine stack_geog2cart(lon, lat, r, x, y, z)
!===============================================================================
! Return the cartesian coordinates from geographic coordinates
   real(rs), intent(in) :: lon, lat, r
   real(rs), intent(out) :: x, y, z
   real :: lo, la

   lo = lon*torad
   la = lat*torad
   x = r*cos(lo)*cos(la)
   y = r*sin(lo)*cos(la)
   z = r*sin(la)
end subroutine stack_geog2cart
!-------------------------------------------------------------------------------

!===============================================================================
subroutine stack_lonlat2local_north(lon, lat, x, y, z)
!===============================================================================
! Find the unit vector which points locally north on the unit sphere, for
! geographic coodinates in degrees
   real(rs), intent(in) :: lon, lat
   real(rs), intent(out) :: x, y, z
   real(rs) :: lo, la

   lo = lon*torad
   la = lat*torad
   x = -cos(lo)*sin(la)
   y = -sin(lo)*sin(la)
   z = cos(la)
end subroutine stack_lonlat2local_north
!-------------------------------------------------------------------------------

!===============================================================================
function stack_azimuth(lon1, lat1, lon2, lat2) result(azimuth)
!===============================================================================
! Return the azimuth from point (lon1,lat1) to (lon2,lat2).  I/O in degrees.

   real(rs), intent(in) :: lon1, lat1, lon2, lat2
   real(rs) :: azimuth, rlon1, rlat1, rlon2, rlat2

   rlon1 = torad*lon1;  rlon2 = torad*lon2
   rlat1 = torad*lat1;  rlat2 = torad*lat2

   azimuth = atan2(sin(rlon2-rlon1)*cos(rlat2) , &
                   cos(rlat1)*sin(rlat2) - sin(rlat1)*cos(rlat2)*cos(rlon2-rlon1))
   azimuth = modulo(azimuth*todeg, 360._rs)

end function stack_azimuth

!===============================================================================
function stack_delta(lon1_in, lat1_in, lon2_in, lat2_in) result(delta)
!===============================================================================
! Returns the angular distance between two points on a sphere given
! the lat and lon of each using the Haversine formula.  I/O is in degrees.
!
   real(rs), intent(in) :: lat1_in, lon1_in, lat2_in, lon2_in
   real(rs) :: delta, lat1, lon1, lat2, lon2

   lat1 = torad*lat1_in;  lon1 = torad*lon1_in
   lat2 = torad*lat2_in;  lon2 = torad*lon2_in

   delta = atan2(sqrt((cos(lat2)*sin(lon2-lon1))**2 + (cos(lat1)*sin(lat2) - &
                       sin(lat1)*cos(lat2)*cos(lon2-lon1))**2) , &
                 sin(lat1)*sin(lat2) + cos(lat1)*cos(lat2)*cos(lon2-lon1))
   delta = delta*todeg

end function stack_delta
!-------------------------------------------------------------------------------

!===============================================================================
function cross_product(a, b) result(c)
!===============================================================================
   real(rs), intent(in) :: a(3), b(3)
   real(rs) :: c(3)
   c = [a(2)*b(3) - a(3)*b(2), a(3)*b(1) - a(1)*b(3), a(1)*b(2) - a(2)*b(1)]
end function cross_product
!-------------------------------------------------------------------------------

!===============================================================================
subroutine stack_check(s)
!===============================================================================
! Check that an array of SAC traces conforms to the criteria necessary for use
! in routines in this module.
!
   type(SACtrace), intent(in) :: s(:)
   integer :: n

   n = size(s)
   if (n == 1) then
      call stack_warning('stack_check: Only one trace in stack')
      return
   endif
   if (any(s(2:n)%delta /= s(1)%delta)) &
      call stack_error('stack_check: All traces must have same delta')
end subroutine stack_check
!-------------------------------------------------------------------------------

!===============================================================================
subroutine stack_error(string)
!===============================================================================
   character(len=*), intent(in) :: string
   write(lu_stderr,'(a)') 'Error: '// string
   error stop
end subroutine stack_error
!-------------------------------------------------------------------------------

!===============================================================================
subroutine stack_warning(string)
!===============================================================================
   character(len=*), intent(in) :: string
   write(lu_stderr,'(a)') 'Warning: '// string
end subroutine stack_warning
!-------------------------------------------------------------------------------

!===============================================================================
subroutine stack_allocate_r4_1d(a, n)
!===============================================================================
   real(r4), intent(inout), allocatable, dimension(:) :: a
   integer, intent(in) :: n
   if (allocated(a)) then
      if (size(a) == n) return
      deallocate(a)
      allocate(a(n))
      return
   else
      allocate(a(n))
   endif
end subroutine stack_allocate_r4_1d
!-------------------------------------------------------------------------------

!===============================================================================
subroutine stack_allocate_r4_2d(a, m, n)
!===============================================================================
   real(r4), intent(inout), allocatable, dimension(:, :) :: a
   integer, intent(in) :: m, n
   if (allocated(a)) then
      if (size(a,1) == m .and. size(a,2) == n) return
      deallocate(a)
      allocate(a(m,n))
      return
   else
      allocate(a(m,n))
   endif
end subroutine stack_allocate_r4_2d
!-------------------------------------------------------------------------------

end module stack
!-------------------------------------------------------------------------------


c     ****************************************************************
c     *                                                              *
c     *                      subroutine ouext1                       *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 12/21/20 (rhd)             *
c     *                                                              *
c     *     computes derived stress/strain values                    *
c     *     at gauss points or node points for later output.         *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine ouext1( span, stresses, nnode, ngp, nodpts,
     &                   num_short_stress, num_short_strain,
     &                   op_code, mxvl )
c
      use elblk_data, only : elestr
c
      implicit none
c
      integer :: span, nnode, ngp, num_short_stress, num_short_strain,
     &           op_code, mxvl
      logical :: stresses, nodpts
c
      integer :: nstrpt, strpt, invar_col, prin_col, evec_col
c
c                       find the number of strain points.
c
      nstrpt = ngp
      if( nodpts ) nstrpt = nnode
c
c                       compute additional data for output at
c                       each of the element nodes or gauss points
c                       of the element block.
c
c                       op_code = 1 : compute mises equiv. stress or
c                                     equiv. strain.
c                       op_code = 2 : compute invariants, principal
c                                     values.
c
      if( op_code .eq. 1 ) then
       do strpt = 1, nstrpt
         if( stresses) then
           call get_mises( span, elestr(1,1,strpt), elestr(1,8,strpt),
     &                     mxvl )
         else
            call get_equiv_strain( span, elestr(1,1,strpt),
     &                             elestr(1,7,strpt), mxvl )
         end if
       end do
       return
      end if
c
c                       compute invariants, principal values.
c
      invar_col = num_short_strain + 1
      if( stresses ) invar_col = num_short_stress + 1
      prin_col = invar_col + 3   ! 1st principal value
      evec_col = prin_col + 3    ! 1st direction cosines
c
      do strpt = 1, nstrpt
c
c                       compute the principal invariants of desired
c                       stress or strain.
c
       call get_invariants( span, mxvl, elestr(1,1,strpt),
     &                      elestr(1,invar_col,strpt), stresses )
c
c                       compute the principal stresses or
c                       principal strains and the direction
c                       cosines of their corresponding normals.
c                       descending order
c
       call get_princ_vals( span, mxvl, elestr(1,1,strpt),
     &                      elestr(1,prin_col,strpt),
     &                      elestr(1,evec_col,strpt), stresses )
c
      end do
c
      return
c
      contains   !  just to hide/protect the routine names
c     ========

c     ****************************************************************
c     *                                                              *
c     *                      subroutine get_mises                    *
c     *                                                              *
c     *                       written by : bh                        *
c     *                                                              *
c     *                   last modified : 1/20/2017 rhd              *
c     *                                                              *
c     *     mises equiv. stress                                      *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine get_mises( span, gpstr, mises, mxvl )
      use constants
      implicit none
c
      integer :: span, mxvl
      double precision :: gpstr(mxvl,*), mises(*)
c
      integer :: i
c
c                       compute the von-mises stress.
c
      do i = 1, span
        mises(i) = sqrt( (gpstr(i,1)-gpstr(i,2))**2+
     &                 (gpstr(i,2)-gpstr(i,3))**2+
     &                 (gpstr(i,1)-gpstr(i,3))**2+
     &             six*(gpstr(i,4)**2+gpstr(i,5)**2+
     &                  gpstr(i,6)**2) )*iroot2
      end do
c
      return
      end

c     ****************************************************************
c     *                                                              *
c     *                      subroutine get_equiv_strain             *
c     *                                                              *
c     *                       written by : bh                        *
c     *                                                              *
c     *                   last modified : 12/21/20 rhd               *
c     *                                                              *
c     *     computes effective strain measure  for block             *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine get_equiv_strain( span, str, efeps, mxvl )
c
      use constants
c
      implicit none
c
      integer :: span, mxvl
      double precision :: str(mxvl,*), efeps(*)
c
      integer :: i
      double precision :: exx, eyy, ezz, gamxy, gamyz, gamxz
c
c                       compute the effective strain measure.
c
      do i = 1, span
       exx = str(i,1)
       eyy = str(i,2)
       ezz = str(i,3)
       gamxy = str(i,4)
       gamyz = str(i,5)
       gamxz = str(i,6)
       efeps(i) = (root2/three) *
     &      sqrt( (exx-eyy)**2 + (exx-ezz)**2 + (eyy-ezz)**2 +
     &            onept5*( gamxy**2 + gamyz**2 + gamxz**2 ) )
      end do
c
      return
      end
c     ****************************************************************
c     *                                                              *
c     *                      subroutine get_invariants               *
c     *                                                              *
c     *                       written by : bh                        *
c     *                                                              *
c     *                   last modified : 12/21/20 rhd               *
c     *                                                              *
c     *     invariants of the stress or strain at a strain point     *
c     *                                                              *
c     ****************************************************************
c
      subroutine get_invariants( span, mxvl, str, inv, stresses )
c
      use constants
c
      implicit none
c
      integer :: span, mxvl
      double precision :: str(mxvl,*), inv(mxvl,*)
      logical :: stresses    ! true if doing stresses
c
c                    locals
c
      integer :: i
      double precision :: xx, yy, zz, xy, yz, xz, t1, t2, t3, t4, t5,
     &                    factor
c
      factor = half
      if( stresses ) factor = one
c
      do i = 1, span
        xx = str(i,1)
        yy = str(i,2)
        zz = str(i,3)
        xy = str(i,4) * factor
        yz = str(i,5) * factor
        xz = str(i,6) * factor
        inv(i,1) = xx + yy + zz
        inv(i,2) = -xy**2 - yz**2 - xz**2 + xx*yy + yy*zz + zz*xx
        t1 = xx*yy*zz
        t2 = two * xy*yz*xz
        t3 = xy*xy*zz
        t4 = yz*yz*xx
        t5 = xz*xz*yy
        inv(i,3) = t1 + t2 - t3 - t4 - t5
      end do
c
      return
      end
c     ****************************************************************
c     *                                                              *
c     *                      subroutine get_princ_vals               *
c     *                                                              *
c     *                       written by : bh                        *
c     *                                                              *
c     *                   last modified : 12/20/20 rhd               *
c     *                                                              *
c     *     computes the principal values and direction cosines      *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine get_princ_vals( span, mxvl, str, prstr, angles,
     &                           stresses )
c
      use constants
c
      implicit none
c
      integer :: span, mxvl
      logical :: stresses
      double precision :: str(mxvl,*), prstr(mxvl,*), angles(mxvl,*)
c
c                    locals
c
      integer :: i
      double precision :: factor, values(6), evalues(3), evectors(3,3)
c
      factor = half
      if( stresses ) factor = one
c
      do i = 1, span
        values(1) =  str(i,1)
        values(2) =  str(i,2)
        values(3) =  str(i,3)
        values(4) =  str(i,4) * factor
        values(5) =  str(i,5) * factor
        values(6) =  str(i,6) * factor
        call principal_values_ext1( values,  evectors, evalues )
        prstr(i,1:3)= evalues
        angles(i,1:3) = evectors(1:3,1)
        angles(i,4:6) = evectors(1:3,2)
        angles(i,7:9) = evectors(1:3,3)
      end do
c
      return
      end
c
      end subroutine ouext1

c     ****************************************************************
c     *                                                              *
c     *                    subroutine principal_values_ext          *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                last modified : 12/18/2020 rhd                *
c     *                                                              *
c     *  eigenvalues of symmetric 3x3 returned in descending order   *
c     *                                                              *
c     ****************************************************************
c
      subroutine principal_values_ext1( vector, evectors, evals)
c
      use global_data, only : out
      use constants
      implicit none
c
c              calculates the eigenvalues and normalized eigenvectors
c              of a symmetric 3x3 matrix using the jacobi algorithm.
c              not the fastest method but the most stable and accurate
c              especially for ill-conditioned input.
c
c              input vector not altered
c
c              vector: xx, yy, zz, xy, yz, xz
c
c              reference:  Numerical diagonalization of 3x3 matrcies
c                          Copyright (C) 2006  Joachim Kopp
c                          GNU Lesser General Public License
c                          his name for routine: dsyevj3
c
      double precision :: vector(6), evectors(3,3), evals(3)
c
      integer :: i, x, y, r
      double precision :: q(3,3), a(3,3), w(3), sd, so, s, c, t, g, h,
     &                    z, theta, thresh
c
      a(1,1) = vector(1)
      a(1,2) = vector(4)
      a(1,3) = vector(6)
      a(2,2) = vector(2)
      a(2,3) = vector(5)
      a(3,3) = vector(3)
c
      do x = 1, 3
        q(x,x) = one
        do y = 1, x-1
          q(x, y) = zero
          q(y, x) = zero
        end do
      end do
c
      do x = 1, 3
        w(x) = a(x,x)
      end do
c
      sd = zero
      do x = 1, 3
        sd = sd + abs(w(x))
      end do
      sd = sd**2
c
c              main iteration loop
c
      do i = 1, 50  ! max iterations
        so = zero
        do x = 1, 3
          do y = x+1, 3
            so = so + abs(a(x,y))
          end do
        end do
        if( so == zero ) then ! converged
           call principal_values_reorder_ext1
           return
        end if
c
        if( i < 4) then ! looser initial threshold
          thresh = 0.2d0 * so / 3**2
        else
          thresh = zero
        end if
c
c                do  a sweep
c
        do x = 1, 3
          do y = x+1, 3
            g = hundred * ( abs(a(x,y)) )
            if( i > 4 .and. abs(w(x)) + g == abs(w(x))
     &           .and. abs(w(y)) + g == abs(w(y)) ) then
              a(x, y) = zero
            else if( abs(a(x, y)) > thresh ) then
c                calculate jacobi transformation
              h = w(y) - w(x)
              if( abs(h) + g == abs(h) ) then
                t = a(x, y) / h
              else
                theta = half * h / a(x, y)
                if( theta < zero ) then
                  t = -one / (sqrt(one + theta**2) - theta)
                else
                  t = one / (sqrt(one + theta**2) + theta)
                end if
              end if
c
              c = one / sqrt( one + t**2 )
              s = t * c
              z = t * a(x, y)
c
c                apply jacobi transformation
c
              a(x, y) = zero
              w(x)    = w(x) - z
              w(y)    = w(y) + z
              do r = 1, x-1
                t       = a(r, x)
                a(r, x) = c * t - s * a(r, y)
                a(r, y) = s * t + c * a(r, y)
              end do
              do r = x+1, y-1
                t       = a(x, r)
                a(x, r) = c * t - s * a(r, y)
                a(r, y) = s * t + c * a(r, y)
              end do
              do r = y+1, 3
                t       = a(x, r)
                a(x, r) = c * t - s * a(y, r)
                a(y, r) = s * t + c * a(y, r)
              end do
c
c             update eigenvectors
c
              do r = 1, 3
                t       = q(r, x)
                q(r, x) = c * t - s * q(r, y)
                q(r, y) = s * t + c * q(r, y)
              end do
            end if
          end do ! on y
        end do ! on x
      end do ! on i

      write(out,9000)
      call die_abort
 9000 format(/1x,'>>>>> FATAL ERROR: routine principal_values.',
     &          ' Jacobi iterations failed to converge',/
     & /,'.....  analysis terminated  .....',// )
c
      contains
c     ========
c
      subroutine principal_values_reorder_ext1
      implicit none
c
c              put eigenvalues in descending order.
c              make eigenvector columns match ordering.
c
      integer :: k, i
c
      do i = 1, 3
        k = maxloc( w,dim=1 )
        evals(i) = w(k)
        evectors(1:3,i) = q(1:3,k)
        w(k) = -1.0d20
      end do
c
      return
      end subroutine principal_values_reorder_ext1
c
      end subroutine principal_values_ext1


subroutine plcd_turnof(a)
   ! DESCRIPTION
   !    This routine closes the run for the elastic solid prob
   !-----------------------------------------------------------------------
   use typre
!   use Mod_iofile
   use Mod_PLCD
   use Mod_Element
   use Mod_plcd_StrainGenerator
   use Mod_r1pElementAllocation
   use Mod_plcd_SIMP_TopologyOptimization
   use Mod_plcd_TD_TopologyOptimization
   use Mod_plcd_TD_StochasticTopologyOptimization
   implicit none
   class(PLCDProblem) :: a

   integer(ip) :: nelem,ndime,npoin,istage,ielem,vsize
   class(FiniteElement), pointer :: e => NULL()
   procedure(), pointer :: GetStrain => NULL()
   procedure(), pointer :: AddSphericalComponent => NULL()
   procedure(), pointer :: GetStressTensor => NULL()
   procedure(), pointer :: GetStrainTensor => NULL()
   procedure(), pointer :: GetStressVector => NULL()
   procedure(), pointer :: GetStrainVector => NULL()

   integer(ip) :: nsubstages

   deallocate(a%Materials)
   call a%Memor%deallocObj(0,'Materials','plcd_turnof',1*a%NumberOfMaterials)

   call a%Mesh%GetNelem(nelem)
   call a%Mesh%GetNpoin(npoin)
   call a%Mesh%GetNdime(ndime)

   call a%Memor%dealloc(size(a%Displacement,1),size(a%Displacement,2),size(a%Displacement,3),a%Displacement, 'Displacement','plcd_turnof')
   if (a%kfl_TransientProblem /= 0) then
      call a%Memor%dealloc(size(a%Velocity,1),size(a%Velocity,2),size(a%Velocity,3),a%Velocity,'Velocity','plcd_turnof')
      call a%Memor%dealloc(size(a%Acceleration,1),size(a%Acceleration,2),size(a%Acceleration,3),a%Acceleration,'Acceleration','plcd_turnof')
   endif
   if (a%kfl_FSI /= 0) then
      call a%Memor%dealloc(size(a%btraction,1),npoin,a%btraction, 'SolidTraction','plcd_turnof')
   endif
   call a%Memor%dealloc(a%ndofn,npoin,a%InternalForcesVector, 'InternalForcesVector','plcd_turnof')
   call a%Memor%dealloc(a%ndofn,npoin,a%ExternalForcesVector, 'ExternalForcesVector','plcd_turnof')
   call a%Memor%dealloc(a%ndofn,npoin,a%ResidualForcesVector, 'ResidualForcesVector','plcd_turnof')

   call a%DeallocStages

   !Stresses
   call GetVoigtsize(ndime,vsize)
   call AllocateGetStrain(ndime,GetStrain,a%kfl_LargeStrains)
   call AllocateAddSphericalComponent(ndime,AddSphericalComponent)
   call AllocateGetStressTensor(ndime,GetStressTensor)
   call AllocateGetStrainTensor(ndime,GetStrainTensor)
   call AllocateGetStressVector(ndime,GetStressVector)
   call AllocateGetStrainVector(ndime,GetStrainVector)

   call DeAllocateR2pElement(a%Mesh,vsize,a%Stress,a%Memor,'stress')
   !Strains
   if(a%PostprocessStrain) then
      call DeAllocateR2pElement(a%Mesh,vsize,a%Strain,a%Memor,'strain')
   endif

   !Mean Compute
   if (a%ComputeMeanflag) then
      call a%Memor%dealloc(vsize,a%MeanStress,'MeanStress','plcd_turnof')
      call a%Memor%dealloc(vsize,a%GMeanStress,'GMeanStress','plcd_turnof')
      call a%Memor%dealloc(vsize,vsize,a%MeanConst,'MeanConst','plcd_turnof')
   endif

   do ielem = 1,nelem
      call a%ElementMaterialsData(ielem)%p%Finalize
      deallocate(a%ElementMaterialsData(ielem)%p)
   enddo
   deallocate(a%ElementMaterialsData)
   call a%Memor%deallocObj(0,'ElementMaterialsData','plcd_turnof',nelem)

   if (a%UseSmoothedDisplacementGradient) then
      call a%Mesh%GetNdime(ndime)
      call a%Mesh%GetNpoin(npoin)
      call a%Memor%dealloc(ndime,ndime,npoin,a%SmoothedDisplacementGradient,'SmoothedDisplacementGradient','plcd_turnof')
   endif

    !UseUPFormulation
   if (a%UseUPFormulation) then
      call a%Mesh%GetNdime(ndime)
      call a%Mesh%GetNpoin(npoin)
      call a%Memor%dealloc(size(a%pressure,1),size(a%pressure,2),a%pressure,'pressure','plcd_turnof')
      call a%Memor%dealloc(ndime,npoin,a%UPResidualProjection,'UPResidualProjection','plcd_turnof')

      if (a%UPStoreSubscales) then
         call a%Mesh%GetNdime(ndime)
         call DeallocateR2pElement(a%Mesh,ndime,a%UPSubscales,a%Memor,'UPSubscales')
      endif

   endif

   !TopologyOptimization
   if (a%kfl_TopologyOptimization == 1) then
      call TurnofSIMP(a)
    elseif (a%kfl_TopologyOptimization==2) then
      call TurnofTD(a)
   end if

   !Stochastic Optimization
   if (a%kfl_StochasticTopologyOptimization == 1) then
      call plcd_TDSTO_turnof(a)
   endif

end subroutine plcd_turnof


!//=========================================================================
!// Oslo CTM3
!//=========================================================================
!// Ole Amund Sovde, June 2015
!//=========================================================================
!// UCI dry deposition routines.
!//=========================================================================
module scavenging_drydep_uci
  !// ----------------------------------------------------------------------
  !// MODULE: scavenging_drydep_uci
  !// DESCRIPTION: Treat dry deposition as a separate process.
  !//              Converted from UCI p-scav.f and modified for CTM3.
  !//
  !// ---(p-scav.f)    p-code 5.6 (Neu, Tang, Prather Aug 2008)
  !// Version: qcode_56d; 20090318
  !//     CTM3: modified VDEP
  !//           DRYDEP: Added LEMISDEP_INCHEM switch
  !//
  !// Contains
  !//   subroutine DRYSET_CTM3
  !//   subroutine DRYDEP
  !//   subroutine DEP_V2
  !//
  !// ----------------------------------------------------------------------
  implicit none
  !// ----------------------------------------------------------------------
  private
  public DRYSET_CTM3, DRYDEP
  !// ----------------------------------------------------------------------

contains

  !// ----------------------------------------------------------------------
  subroutine DRYSET_CTM3(INFILE)
    !// --------------------------------------------------------------------
    !// Sets UCI dry dep velocities.
    !// These deposition rates will not be used in CTM3; CTM3 uses a more
    !// sophisticated parameterisation to set VDEP.
    !//
    !// Modified for CTM3.
    !// Ole Amund Sovde, June 2012
    !// --------------------------------------------------------------------
    use cmn_precision, only: r8
    use cmn_size, only: IPAR, JPAR, NPAR
    use cmn_ctm, only: NTM, YDGRD, PLAND, NSCX
    use cmn_chem, only: TNAME
    use cmn_sfc, only: VDEPIN, VDEP
    use utilities, only: get_free_fileid
    !// --------------------------------------------------------------------
    implicit none
    !// --------------------------------------------------------------------
    !// Input
    character(len=*), intent(in) ::  INFILE
    !// Locals
    character(len=80) :: TITLE, SCAV_FMT
    character(len=10) :: XTRACR
    logical :: LXX_AER
    real(r8) :: XXDEP1, XXDEP2, XXDEP3, XXLIFE(9)
    integer :: N_TRACERS, I, J, N, NN, LSURF, FUN
    !// --------------------------------------------------------------------

    VDEPIN(:,:) = 0._r8

    write(*,'(a71)') '--------------------------------------------'// &
         '---------------------------'

    !// Open dry scavenging data file
      write(6,*) ' open file: '//trim(INFILE)
    fun = get_free_fileid()
    open(fun,file=INFILE,status='old',form='formatted')
    read(fun,'(a60)') TITLE
      write(6,*) trim(TITLE)
    read(fun,'(a)') SCAV_FMT
    read(fun,SCAV_FMT) N_TRACERS
    do N = 1, N_TRACERS
      read(fun,SCAV_FMT) I,XTRACR,XXDEP1,XXDEP2,XXDEP3
      !// Search for current tracers:
      do NN = 1, NTM
        if (TNAME(NN) .eq. XTRACR) then
          write(6,*) ' dry scavenging match: ', XTRACR,I,NN
          VDEPIN(NN,1) = XXDEP1 * 1.e-2_r8      ! v-dep in m/s
          VDEPIN(NN,2) = XXDEP2 * 1.e-2_r8
          VDEPIN(NN,3) = XXDEP3 * 1.e-2_r8
        end if
      end do
    end do
    close(fun)

    !// Map deposition velocities based on land/ocean/cryo surface
    do J = 1, JPAR
      do I = 1, IPAR
        if (abs(YDGRD(J)) .lt. 60._r8) then
          if (PLAND(I,J) .gt. 0.5_r8) then
            LSURF=1
          else
            LSURF=2
          end if
        else
          LSURF=3
        end if
        do N = 1, NTM
          !// CTM3: Changed order of indices
          VDEP(N,I,J) = VDEPIN(N,LSURF)
        end do
      end do
    end do

    !// --------------------------------------------------------------------
  end subroutine DRYSET_CTM3
  !// ----------------------------------------------------------------------

  !// ----------------------------------------------------------------------
  subroutine DRYDEP(BTT,BXT,BXX,BYT,BYY,BZT,BZZ,BXY,BXZ,BYZ, &
       UTTAU,DTDRYD,MP)
    !// --------------------------------------------------------------------
    !// all of this needs to be updated
    !// this method calculated the depostion velocity VDEP for each species
    !// and then just removes tracer & moments in the lowest part of LAYER=1
    !// using VDEP*DTDRYD to determine how much ***only layer L=1 affected!
    !// --------------------------------------------------------------------
    use cmn_precision, only: r8, rMom
    use cmn_size, only: LPAR, NPAR, IDBLK, JDBLK, LEMISDEP_INCHEM
    use cmn_ctm, only: NTM, MPBLKIB, MPBLKIE, MPBLKJB, MPBLKJE, JMON, NDPX
    use cmn_met, only: ZOFLE
    use cmn_sfc, only: VDEP
    use utilities, only: ctmExitC
    !// --------------------------------------------------------------------
    implicit none
    !// --------------------------------------------------------------------
    !// Input
    real(r8), intent(in) ::  UTTAU, DTDRYD
    integer, intent(in) ::  MP
    !// Input/Output
    real(r8), intent(inout) ::  BTT(LPAR,NPAR,IDBLK,JDBLK)
    real(rMom), intent(inout), dimension(LPAR,NPAR,IDBLK,JDBLK) :: &
         BXT, BXX, BYT, BYY, BZT, BZZ, BXY, BXZ, BYZ
    !// Locals
    real(r8) :: ETT, EZT, EZZ, EXZ, EYZ, EXT, EXX, EYT, EYY, EXY
    real(r8) :: XL, XDEP, DELZ, LSTAU
    integer :: I, J, II, JJ, M, N
    !// --------------------------------------------------------------------

    !//---collect column variables to calculate height of layers
    !//---R = 287.*(1-Q) + 461.5*Q -- assume 0.5% bl w.v.==> R = 288.
    !//---delta-z = dln(P) * R * T / g   where R/g = 288/9.81 = 29.36
    !// --------------------------------------------------------------------
    !do L = 1,LM+1
    !   POFL(L) = ETAA(L) + ETAB(L)*P(I,J)
    !end do
    !ZOFL(1) = 0._r8
    !do L = 1,LM
    !   DELZ = log(POFL(L)/POFL(L+1))*T(I,J,L)*29.36_r8
    !   ZOFL(L+1) = ZOFL(L) + DELZ
    !end do
    !DELZ = ZOFL(2)
    !// --------------------------------------------------------------------

    !// Swich for Oslo chemistry treatment of emissions. If they are to
    !// be treated as production terms in chemistry, they will be fetched
    !// in oc_main.f, so we just return from here.
    if (LEMISDEP_INCHEM) return

    M = JMON        ! may need to know month
    LSTAU = UTTAU   ! may need Local Solar TAU for each I
    !// begin super loop over OpenMP IJ-block
    do J = MPBLKJB(MP),MPBLKJE(MP)
      JJ   = J - MPBLKJB(MP) + 1
      do I = MPBLKIB(MP),MPBLKIE(MP)
        II   = I - MPBLKIB(MP) + 1

        !// NB dep velocity cannot reach beyond L=1, height = DELZ
        !// at 1 cm/s (fast) ==> 36 m in 1 hr, should be OK
        DELZ = ZOFLE(2,I,J) - ZOFLE(1,I,J)

        do N = 1, NTM
          if (NDPX .eq.0) then
            !// Fraction to be removed
            XDEP = VDEP(N,I,J) * DTDRYD / DELZ
            XDEP = min(0.99_r8, XDEP)
          else
            !// updated dry dep code should be function of veg, LAI, month...
            call ctmExitC('>>>>cannot run NDPX>0 dry dep with this code')
          end if
          if (XDEP .gt. 1.e-8_r8) then
            ETT   = BTT(1,N,II,JJ)
            EZT   = BZT(1,N,II,JJ)
            EZZ   = BZZ(1,N,II,JJ)
            EXZ   = BXZ(1,N,II,JJ)
            EYZ   = BYZ(1,N,II,JJ)
            EXT   = BXT(1,N,II,JJ)
            EXX   = BXX(1,N,II,JJ)
            EYT   = BYT(1,N,II,JJ)
            EYY   = BYY(1,N,II,JJ)
            EXY   = BXY(1,N,II,JJ)

            call DEP_V2(ETT,EZT,EZZ,EXZ,EYZ,EXT,EXX,EYT,EYY,EXY,XDEP,XL)

            BTT(1,N,II,JJ) = ETT
            BZT(1,N,II,JJ) = EZT
            BZZ(1,N,II,JJ) = EZZ
            BXZ(1,N,II,JJ) = EXZ
            BYZ(1,N,II,JJ) = EYZ
            BXT(1,N,II,JJ) = EXT
            BXX(1,N,II,JJ) = EXX
            BYT(1,N,II,JJ) = EYT
            BYY(1,N,II,JJ) = EYY
            BXY(1,N,II,JJ) = EXY
          end if
        end do

      end do
    end do

    !// --------------------------------------------------------------------
  end subroutine DRYDEP
  !// ----------------------------------------------------------------------

  !// ----------------------------------------------------------------------
  subroutine DEP_V2(ETT,EZT,EZZ,EXZ,EYZ,EXT,EXX,EYT,EYY,EXY,XDEP,XL)
    !// --------------------------------------------------------------------
    !// Remove tracer from lowest XDEP (fraction) of layer; total loss (XL)
    !// correct moments to reflect deposition.    Oliver(27/7/99)+MJP(7/02)
    !// --------------------------------------------------------------------
    use cmn_precision, only: r8
    !// --------------------------------------------------------------------
    implicit none
    !// --------------------------------------------------------------------
    !// Input
    real(r8), intent(in)    :: XDEP
    !// Input/Output
    real(r8), intent(inout) :: ETT,EZT,EZZ,EXZ,EYZ,EXT,EXX,EYT,EYY,EXY
    !// Output
    real(r8), intent(out)   :: XL
    !// Locals
    real(r8) :: EM, EPS, EPS1, EPS1Q, ETT0
    !// --------------------------------------------------------------------

    !// calling qlimit to restrain Z moments (mass EM not needed for Lim=2)
    EM = 0._r8
    call QLIMIT2 (ETT,EZT,EZZ,EXZ,EYZ)

    !// compute moments of tracer in fraction of layer not deposited
    ETT0  = ETT
    EPS   = min(1._r8, max(0._r8, XDEP))
    EPS1  = 1._r8 - EPS
    EPS1Q = EPS1 * EPS1

    ETT = EPS1 * (ETT + EPS * (EZT - (EPS1 - EPS) * EZZ))
    EZT = EPS1Q * (EZT + 3._r8 * EPS * EZZ)
    EZZ = EPS1 * EPS1Q * EZZ
    EXT = EPS1 * (EXT + EPS * EXZ)
    EYT = EPS1 * (EYT + EPS * EYZ)
    EXX = EPS1 * EXX
    EYY = EPS1 * EYY
    EXY = EPS1 * EXY
    EXZ = EPS1Q * EXZ
    EYZ = EPS1Q * EYZ

    !// put Z-moments back into full layer with bottom of layer zeroed
    XL   = ETT - ETT0
    EZZ  = EPS1Q * EZZ+ 5._r8 * EPS * (EPS1 * EZT - (EPS1 - EPS) * ETT)
    EZT  = EPS1 * EZT + 3._r8 * EPS * ETT
    EXZ  = EPS1 * EXZ + 3._r8 * EPS * EXT
    EYZ  = EPS1 * EYZ + 3._r8 * EPS * EYT

    !// --------------------------------------------------------------------
  end subroutine DEP_V2
  !// ----------------------------------------------------------------------

  !// ----------------------------------------------------------------------
end module scavenging_drydep_uci
!//=========================================================================


C    %W% %G%
      subroutine mdcint
C * * *
C * * * THIS SUBROUTINE INITIALIZES TABLES FOR MULTI-TERMINAL DC
C * * * IT IS CALLED BY INITL4.  IT CALLS GAMINT AND MMODIN.
C * * *
      include 'tspinc/params.inc'
      include 'tspinc/gamma.inc'
      include 'tspinc/blkcom1.inc'
      include 'tspinc/busvolt.inc'
      include 'tspinc/namec.inc'
      include 'tspinc/cntrl2.inc'
      include 'tspinc/toler.inc'
      include 'tspinc/param.inc'
      include 'tspinc/contrl.inc'
      include 'tspinc/fltopt.inc'
      include 'tspinc/matrow.inc'
      include 'tspinc/newton.inc'
      include 'tspinc/ecsind.inc'
      include 'tspinc/ectba.inc'
      include 'tspinc/mdctbl.inc'
      include 'tspinc/mdcfil.inc'
      include 'tspinc/dcblk.inc'
      include 'tspinc/ecstbb.inc'
      include 'tspinc/pointr.inc'
      include 'tspinc/prt.inc'

      equivalence (erio,tab(164)),(eroo,tab(165)),(eron,tab(166)),
     1            (etio,tab(167)),(eioo,tab(168)),(eion,tab(169)),
     2            (ectim1,tab(148)),(ectim2,tab(149))
      dimension zoecs(512)
      character*8 ibus1,dcbus1,dcbus2,name,name1,name2

      pi=3.14159265
      f135=3.0*sqrt(2.0)/pi
      rpib3=3.0/pi
      rpib18=18.0/(pi*pi)
      sqr2=sqrt(2.0)
      zero=0.0
      ipwr=2
      do 5000 itrr= 1,20
      mdcblk(itrr) = 0
 5000 continue
      n100 = 100
      ldcc=0
 6010 ldcc=ldcc+1
      if(ldcc.gt.ldc1) go to 11090
C * * *
C     INITIALIZE DCB,...,DCL TABLE
C * * *
      call redecs (dcb,kdcm(ldcc),msizeb)
      nbusp1 = nbus+1
      iopen=1
      mblck=1
      dts = dt / dcitol
C * * *
C     ZERO L-1,YMTRX TABLE
C * * *
      nbussq=nbus**2
      do 6012 i=1,10
      do 6012 ii=1,11
      dcc(i,ii)=0.0
 6012 dcg(i,ii)=0.0
      ind=lbt+nterm+1
C * * *
C * * * PREPARE THE ADMITTANCE TABLES YMTRX AND BLMTRX
C * * *
 6020 if(ind.gt.ndimc) go to 6030
      nb = idcb(ind)
      if(nb.gt.0) go to 6025
      ia = -nb
      if(ia.gt.10) ia = ia - 10
      ind=ind+1
      go to 6020
 6025 if(nb.le.10) go to 6027
      ind = ind + 1
      go to 6020
C * * *
C     SCALE INDUCTANCE,CURRENT TO PROPER UNITS
C * * *
 6027 dcb(ind + 2) = dcb(ind+2) * 0.001 * 60.0
      dcb(ind+3) = 1.0 / (dcb(ind+1) + 2*dcb(ind+2) / dts)
      dcb(ind+4) = dcb(ind+1) - 2*dcb(ind+2) / dts
C * * *
C     PREPARE PARTIAL L-1,YMTRX
C * * *
      ymtrx(ia,nb) = -dcb(ind+3)
      ymtrx(ia,ia) = ymtrx(ia,ia) + dcb(ind+3)
      blmtrx(ia,nb) = -1.0/dcb(ind+2)
      blmtrx(ia,ia) = blmtrx(ia,ia) + 1.0/dcb(ind+2)
      ind = ind + 8
      go to 6020
 6030 call ritecs(dcb,kdcm(ldcc),ndimc)
      if(keybrd(22).eq.0)go to 6060
C     DEBUG OUTPUT FOR DCB TABLE
      call prtout (1)
      write(outbuf,6040)
 6040 format(1x,'S 6040 I/DCB OUTPUT')
      kk = lbt + idcb(2)
      do 6044 k =1,kk
      write(outbuf,6041) k,idcb(k)
 6041 format(10x,i4,1x,i10)
      call prtout(1)
 6044 continue
 6042 continue
      if(kk .lt. ndimc) then
         k1 = kk+1
         k2 = k1
         if(idcb(k1) .lt. 0) k2 = k1+1
         k3 = k2+1
         k4 = k3+6
         do 6045 k = k1,k2
         write(outbuf,6041) k,idcb(k)
         call prtout(1)
 6045    continue
         do 6046 k =k3,k4
         write(outbuf,6043) k,dcb(k)
 6043    format(10x,i4,1x,e10.3)
         call prtout(1)
 6046    continue
         kk = k4
         go to 6042
      endif
 6050 format ('0S6050  DCB OUTPUT')
 6051 format (1x,8(i3,e13.5))
      do 6047 jjj = 1,17
 6047 dca(jjj) = eyr(jjj)
      write (outbuf,6053)
      call prtout (1)
      do 26052 jjj = 1,17,10
         kkk = min0 (jjj+9,17)
         write (outbuf,16053) (dca(i),i=jjj,kkk)
         call prtout (1)
26052 continue
      do 6052 jjj = 1,17
 6052 dca(jjj) = eyi(jjj)
      call prtout (1)
      do 26053 jjj = 1,17,10
         kkk = min0 (jjj+9,17)
         write (outbuf,16053) (dca(i),i=jjj,kkk)
         call prtout (1)
26053 continue
 6053 format ('0AT S6053 VOLTAGES')
16053 format (1x,10e13.4)
C * * *
C * * *  PREPARE THE REST OF THE DCA TABLE
C * * *
 6060 ind=0
      iblkt = 0
 6070 ind=ind+1
      if(ind.gt.nterm) go to 7061
      ind1 = lbt + ind
      call redecs(dca,idcb(ind1),msizea)
C****
C* YISOLN, NEWTON OPTION
C****
      go to ( 6080, 6075 ), inewts
C* REMOVE DC ADMIT. FROM YMATRIX DIAG. & STORE IN YADMIT TABLE
 6075 call getmat(iev, ii)
      atrow(ii-1) = atrow(ii-1) - gv
      atrow(ii  ) = atrow(ii  ) - bv
      gadmit(iev) =  gv
      badmit(iev) =  bv
      call putmat(iev, ii)
C * * *
C * * * ADD THE CONTRIBUTION FROM THE COMMUNTATING XFRMERS
C * * * TO THE DIAGONAL OF THE DC ADMITTANCE MATRICES
C * * *
 6080 ymtrx(ibus,ibus) = ymtrx(ibus,ibus) + yiop
      blmtrx(ibus,ibus)=blmtrx(ibus,ibus)+1.0/sl
      crated=crated*0.001
      cmx = cmx * crated
      cdesrd=cdesrd*.001
      do 6081 jtrr = 1,6
C * * *
C * * * INITIALIZE DCFIL TABLE FOR MODE CHANGE FILTER
C * * *
      dcfil(jtrr,ldcc) = csign*cinit
 6081 continue
      zero=0.0
C * * *
C * * * CHECK TO SEE IF THIS TERMINAL IS BEING DISABLED
C * * *
      if(idca(94) .ne. 0)then
         iblkt = iblkt + 1
         dcbus1 = exnamc(idca(46))
         write(errbuf(1),6085)dcbus1
 6085    format(5x,' DC CONVERTER ',a8,' IS BEING BLOCKED.')
         call prterr('W',1)
      endif
      if(abs(cinit) .gt. cmx)then
         dcbus1 = exnamc(idca(46))
         write(errbuf(1),6990) dcbus1,cinit,cmx
         call prterr('E',1)
 6990    format (1h0,5x,' INITIAL CURRENT EXCEEDS MAXIMUM CURRENT FOR ',
     1   a8,5x,' CINIT = ',f9.4,' CMAX = ',f9.4)
         iabort = 1
      endif
C * * * CONVERT CURRENT-REGULATOR GAIN FROM P.U. TO OHMS
C * * *
      ckalph = -ckalph * (rref*brdgno*f135 / crated)
      delcm = delcm*crated
C * * *
C * * * FIND COMMUTATING-BUS VOLTAGE IN VOLTS
C * * *
      e1 = eyr(iec)
      f1 = eyi(iec)
      ecn=sqrt(e1*e1+f1*f1)*txbse
      eop = f135 * ecn
      eco=ecn
      eocdn=ecn
      eocn = ecn
      eoco = eco
      rrll = rxpi * rll
      biim = cdcn * ziom + twovd + csign * f135 * eocn * cosan-vdinit
      ymtrx(ibus,nbusp1)=ymtrx(ibus,nbusp1)+(biim+csign*f135*eocn*cosan)
     1        * yiop
      cx = 2.0*xc*csign*cinit*rpib3
C * * *
C * * * MODERI= 1 FOR RECTIFIER = 2 AND = 3 FOR INVERTERS
C * * *
 7000 if(moderi.ne.1) go to 7010
      cosan=cosang
      coslim=cosmin
      dcv=f135*ecn*cosan-cinit*rxpi+twovd/2.0
      go to 7020
C * * *
C * * *  INVERTER
C * * *
 7010 cosan=cx/eop-cosang
      dcv=-f135*ecn*cosan-cinit*rxpi+twovd/2.0
      coslim=costop
 7020 edcan=dcv
      cinit=-cinit
      fdin=cinit
      if(moderi.eq.1)fdin=-cinit
C * * *
C * * * CHECK VARIABLE LIMITER VIOLATIONS
C * * *
      vpa=eop*(cosan+cosgam)
      dca(61) = vpa
C * * *
C * * * ICCDE = 2 MEANS CONSTANT EXTINCTION ANGLE
C * * *
      iccde = idca(93)
      if(iccde .eq. 2) vpa = vpa -  cx
      vpchek=abs(vpa-cx)
          if(moderi .eq. 2 .and. vpchek .lt. 1.0e-4) vpa = 0.0
      zmax=eop*(cosgam+coslim)
          if(vpa .le. zmax+1.0e-4 .and. vpa+1.0e-4 .ge. 0.0)
     1      go to 7040
C***** NEXT STATEMENT INCOMPLETE
      write (errbuf(1),7030) vpa,zero,zmax
      call prterr ('E',1)
 7030 format(1h0,a10,f5.1,'VALVE CNTRL LIMIT VIOLATION...X,XMIN,
     1 xmax=',3e15.6)
      iabort=1
C * * *
C * * *  V1N TO V4N ARE STATE VARIABLES FOR THE CURRENT REGULATOR
C * * *
 7040 v3n=vpa
      v2n=vpa
      v1n=vpa/ckalph
      bias=v1n
C * * *
C * * * INCORPORATE CONSTANT SLOPE FOR CURRENT MARGIN TERMINAL
C * * *
      cosgap = cosgam
      if(iccde .eq. 2) go to 7045
      if(moderi.ne.2) go to 7045
      frac=.25
      cosgap=2.*xc*rpib3*frac*delcm/eop+cosgam
      dca(61) = cx + eop*(cosgap-cosgam)
 7045 cdcn=cinit
C * * *
C * * *     TIME CONSTANTS TO PROPER UNITS
C * * *
      do 7050 i=1,5
 7050 dca(i)=dca(i)*frqbse
      do 7022 i=54,63
 7022 dca(10+i) = dca(i)
C          CONSTANT DC VOLTAGE OPERATION
      if(idca(82) .gt. 0) then
      if(dca(92) .le. 0.0) dca(92) = 0.0
         if(moderi .eq. 1) then
         vdref = dcv - dca(92)*fdin
         else
         vdref = dcv + dca(92)*fdin
         endif
         if(dca(91) .le. 0.0) dca(91) = vdref
         if(dca(91) .lt. vdref) then
         write(errbuf(1),7025) vdref,dca(91)
 7025 format(1x, 'CONSTANT DC VOLTABE OPERATION CONSTRAINT VIOLATION ',
     1           2e10.4)
         call prterr('E',1)
         iabort = 1
      endif
C
      endif
C * * *
C * * * DEBUG FOR DC MATRIX
C * * *
      if (keybrd(22).ne.0) then
         write (outbuf,7060)
         call prtout (1)
         do 27060 jjj = 1,msizea,8
            kkk = min0 (jjj+7,msizea)
            write (outbuf,17060) (i,dca(i),i=jjj,kkk)
            call prtout (1)
27060    continue
      endif
 7060 format('0S7060 DCA OUTPUT')
17060 format(1x,8(i4,e12.4))
C * * *
C * * * INITIALIZE MODULATION TABLES IF THEY EXIST
C * * *
      modcod = idca(78)
      if (modcod .eq. 0) then
         call ritecs(dca,idcb(ind1),msizea)
         go to 6070
      endif
      if(modcod .eq. 5) then
C * * *
C * * * INITIALIZE TABLES FOR GAMMA MODULATION
C * * *
         igam = idca(79)
C * * * INITALIIZE INVERTER BUS NUMBER
         igamno(igam) = idca(45)
C * * * INITALIZE GAMMA EXTINCTION ANGLE FROM POWER FLOW
         gama(igam) = acos(dca(33))
         vdcgam = edcan
         call gamint(igam,vdcgam)
      else
C * * *
C * * * INITIALIZE TABLES FOR OTHER MODULATION TYPES
C * * *
      if(modcod .gt. 0 .and. idca(15) .ne. 2) then
         imod = idca(79)
         call mmodin(imod)
      else
         idca(78) = 0
         idca(79) = 0
      endif
      endif
      call ritecs(dca,idcb(ind1),msizea)
      go to 6070
C     WRITE TO ECS  L-1, YMTRX
 7061 call ritecs(ymtrx,necsy,n100)
      call ritecs(blmtrx,necsg,n100)
      if(iblkt .ne. 0)then
         mdcblk(ldcc) = 1
         if(iblkt .ne. nterm)then
            write(errbuf(1),17061)
17061       format(5x,' AT LEAST ONE TERMINAL ON THIS MULTITERMINAL ',
     1             'LINE IS NOT BLOCKED.')
            iabort = 1
            call prterr('E',1)
          endif
      endif
      if(keybrd(22).eq.0) go to 7070
C * * *
C     DEBUG OUTPUT FOR L-1,YMATRIX
C * * *
      if (keybrd(22).ne.0) then
         write (outbuf,7062)
         call prtout (1)
         do 27062 i = 1,10
            write (outbuf,17062) (ymtrx(i,j),j=1,10)
            call prtout (1)
27062    continue
      endif
 7062 format('0AT S7062 YMTRX FOR CIRCUIT')
17062 format(1x,10e13.5)
      if (keybrd(22).ne.0) then
         write (outbuf,7065)
         call prtout (1)
         do 27065 i = 1,10
            write (outbuf,17065) (blmtrx(i,j),j=1,10)
            call prtout (1)
27065    continue
      endif
 7065 format('0AT S7062 BLMTRX FOR CIRCUIT')
17065 format(1x,10e13.5)
C * * *
C * * * FACTORIZE AND STORE YMTRX MATRIX
C * * *
 7070 do 7078 i = 1, nbus
      if(i.eq.1) go to 7076
      im = i - 1
      do 7074 j = 1, im
      if(ymtrx(j,i).eq.0.0) go to 7074
      zijc = ymtrx(j,i) / ymtrx(j,j)
      do 7072 k = i, nbus
 7072 ymtrx(i,k)=ymtrx(i,k)-ymtrx(j,k)*zijc
 7074 continue
 7076 recip = 1.0 / ymtrx(i,i)
      ymtrx(i,i) = recip
      i1 = i + 1
      do 7077 l = i1, nbus
 7077 ymtrx(i,l) = ymtrx(i,l) * recip
 7078 continue
      call ritecs(ymtrx,necsk,n100)
C * * *
C     INITIALIZE IDCF(NTERM) TABLE
C * * *
      do 7082 i = 1, nterm
 7082 idcf(i) = 1
C * * *
C     LOOP FOR ANOTHER DC CKT
C * * *
      go to 6010
11090 return
      end