MODULE domain
  USE oce
  USE dom_oce
  USE sbc_oce
  USE trc_oce
  USE phycst
  USE closea
  USE domhgr
  USE domzgr
  USE dommsk
  USE domwri
  USE domvvl
  USE c1d
  USE dyncor_c1d
  USE wet_dry, ONLY: ll_wd
  USE in_out_manager
  USE iom
  USE lbclnk
  USE lib_mpp
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: dom_init
  PUBLIC :: domain_cfg
  CONTAINS
  SUBROUTINE dom_init(cdstr)
    INTEGER :: ji, jj, jk, ik
    INTEGER :: iconf = 0
    CHARACTER(LEN = 64) :: cform = "(A12, 3(A13, I7))"
    CHARACTER(LEN = *), INTENT(IN) :: cdstr
    INTEGER, DIMENSION(jpi, jpj) :: ik_top, ik_bot
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: z1_hu_0, z1_hv_0
    IF (lwp) THEN
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) 'dom_init : domain initialization'
      WRITE(numout, FMT = *) '~~~~~~~~'
      WRITE(numout, FMT = *) '   Domain info'
      WRITE(numout, FMT = *) '      dimension of model:'
      WRITE(numout, FMT = *) '             Local domain      Global domain       Data domain '
      WRITE(numout, cform) '        ', '   jpi     : ', jpi, '   jpiglo  : ', jpiglo
      WRITE(numout, cform) '        ', '   jpj     : ', jpj, '   jpjglo  : ', jpjglo
      WRITE(numout, cform) '        ', '   jpk     : ', jpk, '   jpkglo  : ', jpkglo
      WRITE(numout, cform) '       ', '   jpij    : ', jpij
      WRITE(numout, FMT = *) '      mpp local domain info (mpp):'
      WRITE(numout, FMT = *) '              jpni    : ', jpni, '   nn_hls  : ', nn_hls
      WRITE(numout, FMT = *) '              jpnj    : ', jpnj, '   nn_hls  : ', nn_hls
      WRITE(numout, FMT = *) '              jpnij   : ', jpnij
      WRITE(numout, FMT = *) '      lateral boundary of the Global domain : jperio  = ', jperio
      SELECT CASE (jperio)
      CASE (0)
        WRITE(numout, FMT = *) '         (i.e. closed)'
      CASE (1)
        WRITE(numout, FMT = *) '         (i.e. cyclic east-west)'
      CASE (2)
        WRITE(numout, FMT = *) '         (i.e. equatorial symmetric)'
      CASE (3)
        WRITE(numout, FMT = *) '         (i.e. north fold with T-point pivot)'
      CASE (4)
        WRITE(numout, FMT = *) '         (i.e. cyclic east-west and north fold with T-point pivot)'
      CASE (5)
        WRITE(numout, FMT = *) '         (i.e. north fold with F-point pivot)'
      CASE (6)
        WRITE(numout, FMT = *) '         (i.e. cyclic east-west and north fold with F-point pivot)'
      CASE (7)
        WRITE(numout, FMT = *) '         (i.e. cyclic east-west and north-south)'
      CASE DEFAULT
        CALL ctl_stop('jperio is out of range')
      END SELECT
      WRITE(numout, FMT = *) '      Ocean model configuration used:'
      WRITE(numout, FMT = *) '         cn_cfg = ', TRIM(cn_cfg), '   nn_cfg = ', nn_cfg
    END IF
    lwxios = .FALSE.
    ln_xios_read = .FALSE.
    CALL dom_glo
    CALL dom_nam
    IF (lwxios) THEN
      CALL iom_set_rst_vars(rst_wfields)
      CALL iom_set_rstw_core(cdstr)
    END IF
    IF (cdstr == 'SAS') THEN
      IF (lrxios) THEN
        IF (lwp) WRITE(numout, FMT = *) 'Disable reading restart file using XIOS for SAS'
        lrxios = .FALSE.
      END IF
    END IF
    CALL dom_hgr
    CALL dom_zgr(ik_top, ik_bot)
    CALL dom_msk(ik_top, ik_bot)
    IF (ln_closea) CALL dom_clo
    !$ACC KERNELS
    DO jj = 1, jpj
      DO ji = 1, jpi
        ik = mikt(ji, jj)
        risfdep(ji, jj) = gdepw_0(ji, jj, ik)
      END DO
    END DO
    ht_0(:, :) = 0._wp
    hu_0(:, :) = 0._wp
    hv_0(:, :) = 0._wp
    DO jk = 1, jpk
      ht_0(:, :) = ht_0(:, :) + e3t_0(:, :, jk) * tmask(:, :, jk)
      hu_0(:, :) = hu_0(:, :) + e3u_0(:, :, jk) * umask(:, :, jk)
      hv_0(:, :) = hv_0(:, :) + e3v_0(:, :, jk) * vmask(:, :, jk)
    END DO
    !$ACC END KERNELS
    IF (ln_linssh) THEN
      !$ACC KERNELS
      gdept_b = gdept_0
      gdept_n = gdept_0
      gdepw_b = gdepw_0
      gdepw_n = gdepw_0
      gde3w_n = gde3w_0
      e3t_b = e3t_0
      e3t_n = e3t_0
      e3t_a = e3t_0
      e3u_b = e3u_0
      e3u_n = e3u_0
      e3u_a = e3u_0
      e3v_b = e3v_0
      e3v_n = e3v_0
      e3v_a = e3v_0
      e3f_n = e3f_0
      e3w_b = e3w_0
      e3w_n = e3w_0
      e3uw_b = e3uw_0
      e3uw_n = e3uw_0
      e3vw_b = e3vw_0
      e3vw_n = e3vw_0
      z1_hu_0(:, :) = ssumask(:, :) / (hu_0(:, :) + 1._wp - ssumask(:, :))
      z1_hv_0(:, :) = ssvmask(:, :) / (hv_0(:, :) + 1._wp - ssvmask(:, :))
      ht_n = ht_0
      hu_b = hu_0
      hu_n = hu_0
      hu_a = hu_0
      hv_b = hv_0
      hv_n = hv_0
      hv_a = hv_0
      r1_hu_b = z1_hu_0
      r1_hu_n = z1_hu_0
      r1_hu_a = z1_hu_0
      r1_hv_b = z1_hv_0
      r1_hv_n = z1_hv_0
      r1_hv_a = z1_hv_0
      !$ACC END KERNELS
    ELSE
      IF (.NOT. l_offline) CALL dom_vvl_init
    END IF
    IF (lk_c1d) CALL cor_c1d
    IF (ln_meshmask .AND. .NOT. ln_iscpl) CALL dom_wri
    IF (ln_meshmask .AND. ln_iscpl .AND. .NOT. ln_rstart) CALL dom_wri
    IF (.NOT. ln_rstart) CALL dom_ctl
    IF (ln_write_cfg) CALL cfg_write
    IF (lwp) THEN
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) 'dom_init :   ==>>>   END of domain initialization'
      WRITE(numout, FMT = *) '~~~~~~~~'
      WRITE(numout, FMT = *)
    END IF
  END SUBROUTINE dom_init
  SUBROUTINE dom_glo
    INTEGER :: ji, jj
    !$ACC KERNELS
    DO ji = 1, jpi
      mig(ji) = ji + nimpp - 1
    END DO
    DO jj = 1, jpj
      mjg(jj) = jj + njmpp - 1
    END DO
    DO ji = 1, jpiglo
      mi0(ji) = MAX(1, MIN(ji - nimpp + 1, jpi + 1))
      mi1(ji) = MAX(0, MIN(ji - nimpp + 1, jpi))
    END DO
    DO jj = 1, jpjglo
      mj0(jj) = MAX(1, MIN(jj - njmpp + 1, jpj + 1))
      mj1(jj) = MAX(0, MIN(jj - njmpp + 1, jpj))
    END DO
    !$ACC END KERNELS
    IF (lwp) THEN
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) 'dom_glo : domain: global <<==>> local '
      WRITE(numout, FMT = *) '~~~~~~~ '
      WRITE(numout, FMT = *) '   global domain:   jpiglo = ', jpiglo, ' jpjglo = ', jpjglo, ' jpkglo = ', jpkglo
      WRITE(numout, FMT = *) '   local  domain:   jpi    = ', jpi, ' jpj    = ', jpj, ' jpk    = ', jpk
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) '   conversion from local to global domain indices (and vise versa) done'
      IF (nn_print >= 1) THEN
        WRITE(numout, FMT = *)
        WRITE(numout, FMT = *) '          conversion local  ==> global i-index domain (mig)'
        WRITE(numout, 25) (mig(ji), ji = 1, jpi)
        WRITE(numout, FMT = *)
        WRITE(numout, FMT = *) '          conversion global ==> local  i-index domain'
        WRITE(numout, FMT = *) '             starting index (mi0)'
        WRITE(numout, 25) (mi0(ji), ji = 1, jpiglo)
        WRITE(numout, FMT = *) '             ending index (mi1)'
        WRITE(numout, 25) (mi1(ji), ji = 1, jpiglo)
        WRITE(numout, FMT = *)
        WRITE(numout, FMT = *) '          conversion local  ==> global j-index domain (mjg)'
        WRITE(numout, 25) (mjg(jj), jj = 1, jpj)
        WRITE(numout, FMT = *)
        WRITE(numout, FMT = *) '          conversion global ==> local  j-index domain'
        WRITE(numout, FMT = *) '             starting index (mj0)'
        WRITE(numout, 25) (mj0(jj), jj = 1, jpjglo)
        WRITE(numout, FMT = *) '             ending index (mj1)'
        WRITE(numout, 25) (mj1(jj), jj = 1, jpjglo)
      END IF
    END IF
25  FORMAT(100(10X, 19I4, /))
  END SUBROUTINE dom_glo
  SUBROUTINE dom_nam
    USE ioipsl
    INTEGER :: ios
    NAMELIST /namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list, nn_no, cn_exp, cn_ocerst_in, cn_ocerst_out, ln_rstart, nn_rstctl, nn_it000, nn_itend, nn_date0, nn_time0, nn_leapy, nn_istate, nn_stock, nn_write, ln_mskland, ln_clobber, nn_chunksz, nn_euler, ln_cfmeta, ln_iscpl, ln_xios_read, nn_wxios, ln_rstdate
    NAMELIST /namdom/ ln_linssh, rn_isfhmin, rn_rdt, rn_atfp, ln_crs, ln_meshmask
    IF (lwp) THEN
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) 'dom_nam : domain initialization through namelist read'
      WRITE(numout, FMT = *) '~~~~~~~ '
    END IF
    REWIND(UNIT = numnam_ref)
    READ(numnam_ref, namrun, IOSTAT = ios, ERR = 901)
901 IF (ios /= 0) CALL ctl_nam(ios, 'namrun in reference namelist', lwp)
    REWIND(UNIT = numnam_cfg)
    READ(numnam_cfg, namrun, IOSTAT = ios, ERR = 902)
902 IF (ios > 0) CALL ctl_nam(ios, 'namrun in configuration namelist', lwp)
    IF (lwm) WRITE(numond, namrun)
    IF (lwp) THEN
      WRITE(numout, FMT = *) '   Namelist : namrun   ---   run parameters'
      WRITE(numout, FMT = *) '      Assimilation cycle              nn_no           = ', nn_no
      WRITE(numout, FMT = *) '      experiment name for output      cn_exp          = ', TRIM(cn_exp)
      WRITE(numout, FMT = *) '      file prefix restart input       cn_ocerst_in    = ', TRIM(cn_ocerst_in)
      WRITE(numout, FMT = *) '      restart input directory         cn_ocerst_indir = ', TRIM(cn_ocerst_indir)
      WRITE(numout, FMT = *) '      file prefix restart output      cn_ocerst_out   = ', TRIM(cn_ocerst_out)
      WRITE(numout, FMT = *) '      restart output directory        cn_ocerst_outdir= ', TRIM(cn_ocerst_outdir)
      WRITE(numout, FMT = *) '      restart logical                 ln_rstart       = ', ln_rstart
      WRITE(numout, FMT = *) '      start with forward time step    nn_euler        = ', nn_euler
      WRITE(numout, FMT = *) '      control of time step            nn_rstctl       = ', nn_rstctl
      WRITE(numout, FMT = *) '      number of the first time step   nn_it000        = ', nn_it000
      WRITE(numout, FMT = *) '      number of the last time step    nn_itend        = ', nn_itend
      WRITE(numout, FMT = *) '      initial calendar date aammjj    nn_date0        = ', nn_date0
      WRITE(numout, FMT = *) '      initial time of day in hhmm     nn_time0        = ', nn_time0
      WRITE(numout, FMT = *) '      leap year calendar (0/1)        nn_leapy        = ', nn_leapy
      WRITE(numout, FMT = *) '      initial state output            nn_istate       = ', nn_istate
      IF (ln_rst_list) THEN
        WRITE(numout, FMT = *) '      list of restart dump times      nn_stocklist    =', nn_stocklist
      ELSE
        WRITE(numout, FMT = *) '      frequency of restart file       nn_stock        = ', nn_stock
      END IF
      WRITE(numout, FMT = *) '      frequency of output file        nn_write        = ', nn_write
      WRITE(numout, FMT = *) '      mask land points                ln_mskland      = ', ln_mskland
      WRITE(numout, FMT = *) '      date-stamp restart files        ln_rstdate = ', ln_rstdate
      WRITE(numout, FMT = *) '      additional CF standard metadata ln_cfmeta       = ', ln_cfmeta
      WRITE(numout, FMT = *) '      overwrite an existing file      ln_clobber      = ', ln_clobber
      WRITE(numout, FMT = *) '      NetCDF chunksize (bytes)        nn_chunksz      = ', nn_chunksz
      WRITE(numout, FMT = *) '      IS coupling at the restart step ln_iscpl        = ', ln_iscpl
      IF (TRIM(Agrif_CFixed()) == '0') THEN
        WRITE(numout, FMT = *) '      READ restart for a single file using XIOS ln_xios_read =', ln_xios_read
        WRITE(numout, FMT = *) '      Write restart using XIOS        nn_wxios   = ', nn_wxios
      ELSE
        WRITE(numout, FMT = *) "      AGRIF: nn_wxios will be ingored. See setting for parent"
        WRITE(numout, FMT = *) "      AGRIF: ln_xios_read will be ingored. See setting for parent"
      END IF
    END IF
    cexper = cn_exp
    nrstdt = nn_rstctl
    nit000 = nn_it000
    nitend = nn_itend
    ndate0 = nn_date0
    nleapy = nn_leapy
    ninist = nn_istate
    nstock = nn_stock
    nstocklist = nn_stocklist
    nwrite = nn_write
    neuler = nn_euler
    IF (neuler == 1 .AND. .NOT. ln_rstart) THEN
      IF (lwp) WRITE(numout, FMT = *)
      IF (lwp) WRITE(numout, FMT = *) '   ==>>>   Start from rest (ln_rstart=F)'
      IF (lwp) WRITE(numout, FMT = *) '           an Euler initial time step is used : nn_euler is forced to 0 '
      neuler = 0
    END IF
    IF (nstock == 0 .OR. nstock > nitend) THEN
      WRITE(ctmp1, FMT = *) 'nstock = ', nstock, ' it is forced to ', nitend
      CALL ctl_warn(ctmp1)
      nstock = nitend
    END IF
    IF (nwrite == 0) THEN
      WRITE(ctmp1, FMT = *) 'nwrite = ', nwrite, ' it is forced to ', nitend
      CALL ctl_warn(ctmp1)
      nwrite = nitend
    END IF
    IF (lwp) WRITE(numout, FMT = *)
    SELECT CASE (nleapy)
    CASE (1)
      CALL ioconf_calendar('gregorian')
      IF (lwp) WRITE(numout, FMT = *) '   ==>>>   The IOIPSL calendar is "gregorian", i.e. leap year'
    CASE (0)
      CALL ioconf_calendar('noleap')
      IF (lwp) WRITE(numout, FMT = *) '   ==>>>   The IOIPSL calendar is "noleap", i.e. no leap year'
    CASE (30)
      CALL ioconf_calendar('360d')
      IF (lwp) WRITE(numout, FMT = *) '   ==>>>   The IOIPSL calendar is "360d", i.e. 360 days in a year'
    END SELECT
    REWIND(UNIT = numnam_ref)
    READ(numnam_ref, namdom, IOSTAT = ios, ERR = 903)
903 IF (ios /= 0) CALL ctl_nam(ios, 'namdom in reference namelist', lwp)
    REWIND(UNIT = numnam_cfg)
    READ(numnam_cfg, namdom, IOSTAT = ios, ERR = 904)
904 IF (ios > 0) CALL ctl_nam(ios, 'namdom in configuration namelist', lwp)
    IF (lwm) WRITE(numond, namdom)
    IF (lwp) THEN
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) '   Namelist : namdom   ---   space & time domain'
      WRITE(numout, FMT = *) '      linear free surface (=T)                ln_linssh   = ', ln_linssh
      WRITE(numout, FMT = *) '      create mesh/mask file                   ln_meshmask = ', ln_meshmask
      WRITE(numout, FMT = *) '      treshold to open the isf cavity         rn_isfhmin  = ', rn_isfhmin, ' [m]'
      WRITE(numout, FMT = *) '      ocean time step                         rn_rdt      = ', rn_rdt
      WRITE(numout, FMT = *) '      asselin time filter parameter           rn_atfp     = ', rn_atfp
      WRITE(numout, FMT = *) '      online coarsening of dynamical fields   ln_crs      = ', ln_crs
    END IF
    atfp = rn_atfp
    rdt = rn_rdt
    IF (TRIM(Agrif_CFixed()) == '0') THEN
      lrxios = ln_xios_read .AND. ln_rstart
      IF (nn_wxios > 0) lwxios = .TRUE.
      nxioso = nn_wxios
    END IF
    snc4set % luse = .FALSE.
  END SUBROUTINE dom_nam
  SUBROUTINE dom_ctl
    INTEGER :: iimi1, ijmi1, iimi2, ijmi2, iima1, ijma1, iima2, ijma2
    INTEGER, DIMENSION(2) :: iloc
    REAL(KIND = wp) :: ze1min, ze1max, ze2min, ze2max
    IF (lk_mpp) THEN
      CALL mpp_minloc(e1t(:, :), tmask_i(:, :), ze1min, iimi1, ijmi1)
      CALL mpp_minloc(e2t(:, :), tmask_i(:, :), ze2min, iimi2, ijmi2)
      CALL mpp_maxloc(e1t(:, :), tmask_i(:, :), ze1max, iima1, ijma1)
      CALL mpp_maxloc(e2t(:, :), tmask_i(:, :), ze2max, iima2, ijma2)
    ELSE
      ze1min = MINVAL(e1t(:, :), mask = tmask_i(:, :) == 1._wp)
      ze2min = MINVAL(e2t(:, :), mask = tmask_i(:, :) == 1._wp)
      ze1max = MAXVAL(e1t(:, :), mask = tmask_i(:, :) == 1._wp)
      ze2max = MAXVAL(e2t(:, :), mask = tmask_i(:, :) == 1._wp)
      iloc = MINLOC(e1t(:, :), mask = tmask_i(:, :) == 1._wp)
      iimi1 = iloc(1) + nimpp - 1
      ijmi1 = iloc(2) + njmpp - 1
      iloc = MINLOC(e2t(:, :), mask = tmask_i(:, :) == 1._wp)
      iimi2 = iloc(1) + nimpp - 1
      ijmi2 = iloc(2) + njmpp - 1
      iloc = MAXLOC(e1t(:, :), mask = tmask_i(:, :) == 1._wp)
      iima1 = iloc(1) + nimpp - 1
      ijma1 = iloc(2) + njmpp - 1
      iloc = MAXLOC(e2t(:, :), mask = tmask_i(:, :) == 1._wp)
      iima2 = iloc(1) + nimpp - 1
      ijma2 = iloc(2) + njmpp - 1
    END IF
    IF (lwp) THEN
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) 'dom_ctl : extrema of the masked scale factors'
      WRITE(numout, FMT = *) '~~~~~~~'
      WRITE(numout, "(14x,'e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, iima1, ijma1
      WRITE(numout, "(14x,'e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, iimi1, ijmi1
      WRITE(numout, "(14x,'e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, iima2, ijma2
      WRITE(numout, "(14x,'e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, iimi2, ijmi2
    END IF
  END SUBROUTINE dom_ctl
  SUBROUTINE domain_cfg(ldtxt, cd_cfg, kk_cfg, kpi, kpj, kpk, kperio)
    CHARACTER(LEN = *), DIMENSION(:), INTENT(OUT) :: ldtxt
    CHARACTER(LEN = *), INTENT(OUT) :: cd_cfg
    INTEGER, INTENT(OUT) :: kk_cfg
    INTEGER, INTENT(OUT) :: kpi, kpj, kpk
    INTEGER, INTENT(OUT) :: kperio
    INTEGER :: inum, ii
    REAL(KIND = wp) :: zorca_res
    REAL(KIND = wp) :: ziglo, zjglo, zkglo, zperio
    ii = 1
    WRITE(ldtxt(ii), FMT = *) '           '
    ii = ii + 1
    WRITE(ldtxt(ii), FMT = *) 'domain_cfg : domain size read in ', TRIM(cn_domcfg), ' file'
    ii = ii + 1
    WRITE(ldtxt(ii), FMT = *) '~~~~~~~~~~ '
    ii = ii + 1
    CALL iom_open(cn_domcfg, inum)
    IF (iom_varid(inum, 'ORCA', ldstop = .FALSE.) > 0 .AND. iom_varid(inum, 'ORCA_index', ldstop = .FALSE.) > 0) THEN
      cd_cfg = 'ORCA'
      CALL iom_get(inum, 'ORCA_index', zorca_res)
      kk_cfg = NINT(zorca_res)
      WRITE(ldtxt(ii), FMT = *) '   .'
      ii = ii + 1
      WRITE(ldtxt(ii), FMT = *) '   ==>>>   ORCA configuration '
      ii = ii + 1
      WRITE(ldtxt(ii), FMT = *) '   .'
      ii = ii + 1
    ELSE
      cd_cfg = 'UNKNOWN'
      kk_cfg = - 9999999
      IF (iom_file(inum) % iolib == jpnf90) THEN
        CALL iom_getatt(inum, 'cn_cfg', cd_cfg)
        CALL iom_getatt(inum, 'nn_cfg', kk_cfg)
        IF (TRIM(cd_cfg) == '!') cd_cfg = 'UNKNOWN'
        IF (kk_cfg == - 999) kk_cfg = - 9999999
      END IF
    END IF
    CALL iom_get(inum, 'jpiglo', ziglo)
    kpi = NINT(ziglo)
    CALL iom_get(inum, 'jpjglo', zjglo)
    kpj = NINT(zjglo)
    CALL iom_get(inum, 'jpkglo', zkglo)
    kpk = NINT(zkglo)
    CALL iom_get(inum, 'jperio', zperio)
    kperio = NINT(zperio)
    CALL iom_close(inum)
    WRITE(ldtxt(ii), FMT = *) '      cn_cfg = ', TRIM(cd_cfg), '   nn_cfg = ', kk_cfg
    ii = ii + 1
    WRITE(ldtxt(ii), FMT = *) '      jpiglo = ', kpi
    ii = ii + 1
    WRITE(ldtxt(ii), FMT = *) '      jpjglo = ', kpj
    ii = ii + 1
    WRITE(ldtxt(ii), FMT = *) '      jpkglo = ', kpk
    ii = ii + 1
    WRITE(ldtxt(ii), FMT = *) '      type of global domain lateral boundary   jperio = ', kperio
    ii = ii + 1
  END SUBROUTINE domain_cfg
  SUBROUTINE cfg_write
    INTEGER :: ji, jj, jk
    INTEGER :: izco, izps, isco, icav
    INTEGER :: inum
    CHARACTER(LEN = 21) :: clnam
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: z2d
    IF (lwp) WRITE(numout, FMT = *)
    IF (lwp) WRITE(numout, FMT = *) 'cfg_write : create the domain configuration file (', TRIM(cn_domcfg_out), '.nc)'
    IF (lwp) WRITE(numout, FMT = *) '~~~~~~~~~'
    clnam = cn_domcfg_out
    CALL iom_open(TRIM(clnam), inum, ldwrt = .TRUE., kiolib = jprstlib)
    IF (cn_cfg == "ORCA") THEN
      CALL iom_rstput(0, 0, inum, 'ORCA', 1._wp, ktype = jp_i4)
      CALL iom_rstput(0, 0, inum, 'ORCA_index', REAL(nn_cfg, wp), ktype = jp_i4)
    END IF
    CALL iom_rstput(0, 0, inum, 'jpiglo', REAL(jpiglo, wp), ktype = jp_i4)
    CALL iom_rstput(0, 0, inum, 'jpjglo', REAL(jpjglo, wp), ktype = jp_i4)
    CALL iom_rstput(0, 0, inum, 'jpkglo', REAL(jpk, wp), ktype = jp_i4)
    CALL iom_rstput(0, 0, inum, 'jperio', REAL(jperio, wp), ktype = jp_i4)
    IF (ln_zco) THEN
      izco = 1
    ELSE
      izco = 0
    END IF
    IF (ln_zps) THEN
      izps = 1
    ELSE
      izps = 0
    END IF
    IF (ln_sco) THEN
      isco = 1
    ELSE
      isco = 0
    END IF
    CALL iom_rstput(0, 0, inum, 'ln_zco', REAL(izco, wp), ktype = jp_i4)
    CALL iom_rstput(0, 0, inum, 'ln_zps', REAL(izps, wp), ktype = jp_i4)
    CALL iom_rstput(0, 0, inum, 'ln_sco', REAL(isco, wp), ktype = jp_i4)
    IF (ln_isfcav) THEN
      icav = 1
    ELSE
      icav = 0
    END IF
    CALL iom_rstput(0, 0, inum, 'ln_isfcav', REAL(icav, wp), ktype = jp_i4)
    CALL iom_rstput(0, 0, inum, 'glamt', glamt, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'glamu', glamu, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'glamv', glamv, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'glamf', glamf, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'gphit', gphit, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'gphiu', gphiu, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'gphiv', gphiv, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'gphif', gphif, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e1t', e1t, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e1u', e1u, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e1v', e1v, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e1f', e1f, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e2t', e2t, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e2u', e2u, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e2v', e2v, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e2f', e2f, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'ff_f', ff_f, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'ff_t', ff_t, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e3t_1d', e3t_1d, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e3w_1d', e3w_1d, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e3t_0', e3t_0, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e3u_0', e3u_0, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e3v_0', e3v_0, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e3f_0', e3f_0, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e3w_0', e3w_0, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e3uw_0', e3uw_0, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e3vw_0', e3vw_0, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'top_level', REAL(mikt, wp) * ssmask, ktype = jp_i4)
    CALL iom_rstput(0, 0, inum, 'bottom_level', REAL(mbkt, wp) * ssmask, ktype = jp_i4)
    IF (ln_sco) THEN
      CALL dom_stiff(z2d)
      CALL iom_rstput(0, 0, inum, 'stiffness', z2d)
    END IF
    IF (ll_wd) THEN
      CALL iom_rstput(0, 0, inum, 'ht_0', ht_0, ktype = jp_r8)
    END IF
    IF (iom_file(inum) % iolib == jpnf90) THEN
      CALL iom_putatt(inum, 'nn_cfg', nn_cfg)
      CALL iom_putatt(inum, 'cn_cfg', TRIM(cn_cfg))
    END IF
    CALL iom_close(inum)
  END SUBROUTINE cfg_write
END MODULE domain


module tag_boxes_module

  use BoxLib
  use f2kcli
  use list_box_module
  use boxarray_module
  use ml_boxarray_module
  use layout_module
  use multifab_module
  use box_util_module
  use bl_IO_module
  use cluster_module
  use ml_layout_module

  implicit none

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! MUST set this to .true. if tagging uses ghost cells (e.g., tagging on gradient). !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  logical, save :: tagging_needs_ghost_cells = .false.

contains

  subroutine tag_boxes(mf,tagboxes,dx,lev,aux_tag_mf)

    use variables, ONLY: rho_comp, spec_comp, temp_comp

    use network, ONLY: network_species_index

    type( multifab)          , intent(in   ) :: mf
    type(lmultifab)          , intent(inout) :: tagboxes
    real(dp_t)               , intent(in   ) :: dx
    integer                  , intent(in   ) :: lev
    type( multifab), optional, intent(in   ) :: aux_tag_mf

    real(kind = dp_t), pointer :: sp(:,:,:,:)
    logical          , pointer :: tp(:,:,:,:)
    integer           :: i, lo(mf%dim), hi(mf%dim), ng

    integer           :: ihe4

    ihe4 = network_species_index("helium-4")

    ng = mf%ng

    do i = 1, nfabs(mf)
       sp => dataptr(mf, i)
       tp => dataptr(tagboxes, i)
       lo =  lwb(get_box(tagboxes, i))
       hi =  upb(get_box(tagboxes, i))

       select case (mf%dim)
       case (2)
          call bl_error("ERROR: 2-d tag_boxes not implemented")
       case  (3)
          call tag_boxes_3d(tp(:,:,:,1),sp(:,:,:,rho_comp),&
               sp(:,:,:,spec_comp-1+ihe4),sp(:,:,:,temp_comp),ng,lo,hi,dx,lev)
       end select
    end do

  end subroutine tag_boxes

  subroutine tag_boxes_3d(tagbox,rho,rho_Xhe,temp,ng,lo,hi,dx,lev)

    use bl_constants_module, ONLY: HALF
    use probin_module, ONLY: prob_lo, prob_hi, octant
    use probin_module, ONLY: tag_rhomin, tag_critxhe, tag_crittemp
    use geometry, only: center

    integer          , intent(in   ) :: lo(:),hi(:),ng
    logical          , intent(  out) :: tagbox(lo(1):,lo(2):,lo(3):)
    real(kind = dp_t), intent(in   ) ::     rho(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:)
    real(kind = dp_t), intent(in   ) :: rho_Xhe(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:)
    real(kind = dp_t), intent(in   ) :: temp(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:)
    real(dp_t)       , intent(in   ) :: dx
    integer, optional, intent(in   ) :: lev

    real(kind = dp_t) :: Xhe, cur_temp, x, y, z

    integer :: i,j,k,llev

    real(kind = dp_t) :: RHOMIN, RHOMIN4
    real(kind = dp_t) :: CRITXHE
    real(kind = dp_t) :: CRITTEMP

    llev = 1; if (present(lev)) llev = lev
    RHOMIN   = tag_rhomin
    RHOMIN4  = 5.0d5
    CRITXHE  = tag_critxhe
    CRITTEMP = tag_crittemp

    tagbox = .false.

    !First refine based on the most physically interesting cells:
    !  level 1:   helium mass fraction > 0.01 and we haven't gotten too far
    !                from the stellar surface as determined by density.  This
    !                roughly traces the convective shell
    !  level 2-3: to resolve the thinnest shells, we refine up to a 3rd level the
    !                hottest cells with T > tag_crittemp
    !
    select case(llev)
    case (1)
!$omp parallel do private(i,j,k,Xhe,cur_temp)
      do k = lo(3),hi(3)
         do j = lo(2),hi(2)
            do i = lo(1),hi(1)
               Xhe = rho_Xhe(i,j,k)/rho(i,j,k)
               cur_temp = temp(i,j,k)
               if (cur_temp > CRITTEMP .or.  &
                    (Xhe > CRITXHE    .and.  &
                    rho(i,j,k) >= RHOMIN)    &
                  ) then
                  tagbox(i,j,k) = .true.
               end if
            end do
         enddo
      end do
!$omp end parallel do
    case (2)
!$omp parallel do private(i,j,k,cur_temp)
      do k = lo(3),hi(3)
         do j = lo(2),hi(2)
            do i = lo(1),hi(1)
               cur_temp = temp(i,j,k)
               if (cur_temp > CRITTEMP) then
                  tagbox(i,j,k) = .true.
               end if
            end do
         enddo
      end do
!$omp end parallel do
    case (3)
!$omp parallel do private(i,j,k,cur_temp)
      do k = lo(3),hi(3)
         do j = lo(2),hi(2)
            do i = lo(1),hi(1)
               cur_temp = temp(i,j,k)
               if (cur_temp > CRITTEMP .and. rho(i,j,k) >= RHOMIN4) then
                  tagbox(i,j,k) = .true.
               end if
            end do
         enddo
      end do
!$omp end parallel do
    case default
       call bl_error("tag_boxes.f90: Need to write tagging condition for this level")
    end select

    ! Now we refine the very center of the star (helps the averaging)
    if (octant) then

!$omp parallel do private(i,j,k)
       do k = lo(3),hi(3)
          do j = lo(2),hi(2)
             do i = lo(1),hi(1)
                if (sqrt(dble(i)**2 + dble(j)**2 + dble(k)**2) < 10.0) then
                   tagbox(i,j,k) = .true.
                end if
             end do
          enddo
       end do
!$omp end parallel do

    else

       ! note: dx is a scalar here

!$omp parallel do private(i,j,k,x,y,z)
       do k = lo(3),hi(3)
          z = prob_lo(3) + (dble(k)+HALF)*dx

          do j = lo(2),hi(2)
             y = prob_lo(2) + (dble(j)+HALF)*dx

             do i = lo(1),hi(1)
                x = prob_lo(1) + (dble(i)+HALF)*dx

                if (sqrt((x-center(1))**2 + &
                         (y-center(2))**2 + &
                         (z-center(3))**2) < 10.0*dx) then
                   tagbox(i,j,k) = .true.
                end if

             end do
          enddo
       end do
!$omp end parallel do

    end if

  end subroutine tag_boxes_3d

end module tag_boxes_module


*-----------------------------------------------------------------------
*     brci_est
*-----------------------------------------------------------------------
*     This routine reads .j and .c vectors from lower n and generates
*     an estimate. The program needs <name>.j.est and <name>.c.est to be
*     present in the working directory
*     THis routin has been tested with the parallel code only
*     and it was foiund that for very large cases (100K), it may result
*     in 30% better performance
*
      subroutine brci_est(JJ,A,ncfg,nume,iuc,file_base,lest)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      parameter (MTERM=31, MEIG=31)
      character*64 string_c, string_e, s_tmp, string
      CHARACTER EL*3,ATOM*6,TERMs(MTERM)*6
!      COMMON/LABEL/ EL(NWD),ATOM,TERMs
      logical leigen(MEIG)
      character term_bl(mterm)*3
      integer q(8),iouj,iuc
      character (len = 64)      :: config_tmp
      character (len = 66)      :: config(MEIG)
      integer, dimension(2)     :: max_comp(MEIG)
      integer, dimension(1)     :: mx
      integer                   :: MAX_read, lstring
      integer                   :: ui_c_est, ui_j_est
      double precision A(nume*ncfg+nume)
      integer JJ, ncfg, nume
      character*128 file_c,file_c_est,file_j_est,file_base
      logical  l_match, lest
      integer len_atom, len_str

      integer Z_NUMBER, NCFG_EST
      integer J_EST, NUME_EST
      double precision, allocatable, dimension(:) :: VECT_EST
      character (len = 66), allocatable, dimension(:) :: config_est
      character (len = 66), allocatable, dimension(:) :: coupl_est
      character*64 string_co, string_cu

      l_match = .false.
      ui_c_est = 44
      ui_j_est = 45

      len_atom = LEN_TRIM(file_base)

      file_c_est = file_base(1:len_atom)//'.c.est'
      file_j_est = file_base(1:len_atom)//'.j.est'

      inquire(FILE=file_c_est, exist = lest)
      if (.not.lest) then
         print*, ' No initial estimates: ', file_c_est
         return
      end if

      inquire(FILE=file_j_est, exist = lest)
      if (.not.lest) then
         print*, ' No initial estimates: ', file_j_est
         return
      endif

      OPEN(UNIT=ui_c_est,FILE=file_c_est,STATUS='OLD')
      OPEN(UNIT=ui_j_est,FILE=file_j_est,STATUS='OLD')

      !write
!     ... read estimate: *.j.est
      rewind (ui_j_est)
      read(ui_j_est,'(A4,i2,A34,i7)') s_tmp, Z_NUMBER, s_tmp, NCFG_EST
      read(ui_j_est,'(A64)') s_tmp
      read(ui_j_est,'(A64)') s_tmp

*     ... find the corresponding J
      J_EST = -1;
      do while (J_EST.NE.JJ)
         read(ui_j_est,'(A64)') string
         len_str = len_trim(string)
         if (len_str == 26) then
            read(string,'(A8,i4,A10,i4)') s_tmp,J_EST,s_tmp,NUME_EST
         end if
      end do

      if(J_EST==JJ) then
          A(1:nume*ncfg) = 0;
      else
          print*, 'No 2*J = ', JJ, ' found'
          lest = .false.
          return
      end if

*     allocate memory for VECT_EST = NUME_EST*NCFG_EST
      allocate(VECT_EST(NUME_EST*NCFG_EST+NUME_EST));

*     ... allocate memory for conf+coupl from the estimate
      allocate(config_est(ncfg));
      allocate(coupl_est(ncfg));

*     ... read all eigenvectors (NUME_EST) for the required J
      iin = min(NUME_EST,nume)
      do i = 1,iin
         read(ui_j_est,'(A64)') string
         read(ui_j_est,'(A6,F16.9,A42)')
     :              string,VECT_EST(NUME_EST*NCFG_EST+i),string
         read(ui_j_est,'(7F11.8)')
     :                (VECT_EST((i-1)*NCFG_EST+j), j=1,NCFG_EST)
      end do

*     ... read *.c.est (configurations of the estimates)
      read(ui_c_est,'(A64)') string
      read(ui_c_est,'(A64)') string
      do i = 1, NCFG_EST
         read(ui_c_est,'(A64)') config_est(i)
         read(ui_c_est,'(A64)') coupl_est(i)
      end do

*     ... read 2 blank lines from file 'clist'
      rewind (iuc);
      Read (iuc,'(A64)') string_c
      Read (iuc,'(A64)') string_c
*
      ir = 0;
*     ... map all estimates
      do i = 1,NCFG_EST
        do while (.not.l_match)
           READ(iuc,'(A64)',end = 1) string_co
           READ(iuc,'(A64)',end = 1) string_cu
           !print*, string_co, 'string_co'
           !print*, string_cu, 'string_cu'
           !print*,config_est(i), 'config_est(i)'
           !print*, coupl_est(i), 'coupl_est(i)'
           ir = ir + 1;
           if(lle(string_co,config_est(i))
     :           .and.lge(string_co,config_est(i))) then
              if(lle(string_cu,coupl_est(i))
     :           .and.lge(string_cu,coupl_est(i))) then
                 !print*, 'match'
                 l_match = .true.
                 do in = 1,NUME_EST
                    A(ncfg*(in-1)+ir) =
     :                   VECT_EST(NCFG_EST*(in-1)+i)
                    !print*, VECT_EST(NCFG_EST*(in-1)+i)
                 end do
              end if
           end if
        end do
        l_match = .false.
1       continue
      end do

      do i = 1, NCFG_EST
         A(NCFG*nume+i) = VECT_EST(NCFG_EST*NUME_EST+i)
      end do

      close(ui_c_est);
      close(ui_j_est);

      deallocate(config_est);
      deallocate(coupl_est);
      deallocate(VECT_EST);

      return
      end


!
! Emission_Module
!
! Module containing the emission radiative transfer
! solution procedures in the CRTM.
!
!
! CREATION HISTORY:
!       Written by:     Quanhua Liu, QSS at JCSDA; quanhua.liu@noaa.gov
!                       Yong Han,    NOAA/NESDIS;  yong.han@noaa.gov
!                       Paul van Delst; CIMMS/SSEC; paul.vandelst@noaa.gov
!                       08-Jun-2004

MODULE Emission_Module

  ! ------------------
  ! Environment set up
  ! ------------------
  ! Module use statements
  USE RTV_Define
  USE CRTM_Parameters
  USE Type_Kinds

  IMPLICIT NONE

  ! --------------------
  ! Default visibilities
  ! --------------------
  ! Everything private by default
  PRIVATE

  PUBLIC CRTM_Emission
  PUBLIC CRTM_Emission_TL
  PUBLIC CRTM_Emission_AD

  ! -----------------
  ! Module parameters
  ! -----------------

CONTAINS

!################################################################################
!################################################################################
!##                                                                            ##
!##                        ## PRIVATE MODULE ROUTINES ##                       ##
!##                                                                            ##
!################################################################################
!################################################################################

  SUBROUTINE CRTM_Emission(n_Layers, & ! Input  number of atmospheric layers
                           n_Angles, & ! number angles used in SfcOptics
                    Diffuse_Surface, & ! Input  TRUE: Lambertian, FALSE: specular
                                  u, & ! Input  cosine of local viewing angle
                               T_OD, & ! Input  nadir layer optical depth
                  Planck_Atmosphere, & ! Input  atmospheric layer Planck radiance
                     Planck_Surface, & ! Input  surface Planck radiance
                         emissivity, & ! Input  surface emissivity
                       reflectivity, & ! Input  surface reflectivity matrix
                direct_reflectivity, & ! Input  reflectivity for direct irradiance
                  cosmic_background, & ! Input  cosmic background radiance
                   Solar_irradiance, & ! Input  Solar spectral irradiance
                   Is_Solar_Channel, & ! Input  Indicate solar affected channel
               Source_Zenith_Radian, & ! Input  Point source (e.g. solar) zenith angle
                                RTV)   ! Output TOA radiance and others
! ----------------------------------------------------------------------------- !
!  FUNCTION: Compute IR/MW upward radiance at the top of the profile.           !
!    This code heritages the concept from previous operational code.            !
!    It starts from cosmic background downward.                                 !
!    The downward radiance at the lower level is the transmitted radiance       !
!    from upper level adding the layer downward source function.                !
!    The downward angle is either the same as satellite viewing zenith for a    !
!    specular surface or the diffuse angle for a lambertian surface. The upward !
!    radiance at the surface is the surface emission term adding from surface   !
!    reflected downward radiance. Then, the upward radiance is the sum of       !
!    from the lower level transmitted radiance adding the upward layer          !
!    source function.                                                           !
!                                                                               !
!    Quanhua Liu    Quanhua.Liu@noaa.gov                                        !
! ----------------------------------------------------------------------------- !

    ! Arguments
    INTEGER,                     INTENT(IN)     :: n_Layers
    INTEGER,                     INTENT(IN)     :: n_Angles
    LOGICAL,                     INTENT(IN)     :: Diffuse_Surface
    REAL(fp),                    INTENT(IN)     :: u
    REAL(fp), DIMENSION(:),      INTENT(IN)     :: T_OD
    REAL(fp), DIMENSION(0:),     INTENT(IN)     :: Planck_Atmosphere
    REAL(fp),                    INTENT(IN)     :: Planck_Surface
    REAL(fp), DIMENSION(:),      INTENT(IN)     :: emissivity
    REAL(fp), DIMENSION(:,:),    INTENT(IN)     :: reflectivity
    REAL(fp), DIMENSION(:),      INTENT(IN)     :: direct_reflectivity
    REAL(fp),                    INTENT(IN)     :: cosmic_background
    REAL(fp),                    INTENT(IN)     :: Solar_irradiance
    LOGICAL,                     INTENT(IN)     :: Is_Solar_Channel
    REAL(fp),                    INTENT(IN)     :: Source_Zenith_Radian
    TYPE(RTV_type),              INTENT(IN OUT) :: RTV
    ! Local variables
    REAL(fp) :: layer_source_up, cosine_u0
    INTEGER :: k

    ! --------------------
    ! Downwelling radiance
    ! --------------------
    ! Determing secant downward angle from surface behavior
    IF( Diffuse_Surface ) THEN
      RTV%Secant_Down_Angle = SECANT_DIFFUSIVITY
    ELSE
      RTV%Secant_Down_Angle = ONE/u
    END IF

    ! Start from the top of the atmosphere
    RTV%e_Level_Rad_DOWN(0) = cosmic_background
    RTV%Total_OD = ZERO

    ! Loop from top layer to bottom layer
    DO k = 1, n_Layers
      ! Accumulate optical depth
      RTV%Total_OD = RTV%Total_OD + T_OD(k)
      ! Layer downward transmittance
      RTV%e_Layer_Trans_DOWN(k) = EXP(-T_OD(k)*RTV%Secant_Down_Angle)
      ! Downward radiance
      RTV%e_Level_Rad_DOWN(k) = (RTV%e_Level_Rad_DOWN(k-1)*RTV%e_Layer_Trans_DOWN(k)) + &
                                (Planck_Atmosphere(k)*(ONE-RTV%e_Layer_Trans_DOWN(k)))

      RTV%e_Layer_Trans_UP(k) = EXP(-T_OD(k)/u)

      ! GSI cloud detection
      RTV%e_Cloud_Radiance_UP(k) = RTV%e_Source_UP(k-1) + Planck_Atmosphere(k)*RTV%e_Level_Trans_UP(k-1)
      RTV%e_Source_UP(k) = RTV%e_Source_UP(k-1)+RTV%e_Level_Trans_UP(k-1)*Planck_Atmosphere(k)*(ONE-RTV%e_Layer_Trans_UP(k))
      RTV%e_Level_Trans_UP(k) = RTV%e_Level_Trans_UP(k-1)*RTV%e_Layer_Trans_UP(k)
    END DO

    ! ----------------
    ! Surface radiance
    ! ----------------
    ! upward radiance at the surface ( emission part + reflection part)
    RTV%e_Level_Rad_UP(n_Layers) = (emissivity(n_Angles)*Planck_Surface) + &
                                   (reflectivity(1,1)*RTV%e_Level_Rad_DOWN(n_Layers))

    ! Solar contribution to the upward radiance at the surface
    RTV%Down_Solar_Radiance = ZERO
    IF( Is_Solar_Channel ) THEN
      cosine_u0 = COS(Source_Zenith_Radian)
      IF( cosine_u0 > ZERO) THEN
        RTV%Down_Solar_Radiance = cosine_u0*EXP(-RTV%Total_OD/cosine_u0)*Solar_Irradiance/PI
        RTV%e_Level_Rad_UP(n_Layers) = RTV%e_Level_Rad_UP(n_Layers) + &
          (RTV%Down_Solar_Radiance*direct_reflectivity(1))
      END IF
    END IF

    ! ------------------
    ! Upwelling radiance
    ! ------------------
    ! Initialise upwelling radiance
    RTV%Up_Radiance = ZERO

    ! Loop from SFC->TOA
    DO k = n_Layers, 1, -1
      ! layer upwelling transmittance
!!      RTV%e_Layer_Trans_UP(k) = EXP(-T_OD(k)/u)
      ! layer upwelling source function
      layer_source_up = Planck_Atmosphere(k) * ( ONE - RTV%e_Layer_Trans_UP(k) )
      ! upwelling radiance (including reflected downwelling and surface)
      RTV%e_Level_Rad_UP(k-1) = (RTV%e_Level_Rad_UP(k)*RTV%e_Layer_Trans_UP(k)) + &
                                layer_source_up
      ! upwelling radiance (atmospheric portion only)
      RTV%Up_Radiance = (RTV%Up_Radiance*RTV%e_Layer_Trans_UP(k)) + layer_source_up
    END DO

  END SUBROUTINE CRTM_Emission

  SUBROUTINE CRTM_Emission_TL(n_Layers, & ! Input  number of atmospheric layers
                              n_Angles, & ! number angles used in SfcOptics
                                     u, & ! Input  cosine of local viewing angle
                     Planck_Atmosphere, & ! Input  atmospheric layer Planck radiance
                        Planck_Surface, & ! Input  surface Planck radiance
                            emissivity, & ! Input  surface emissivity
                          reflectivity, & ! Input  surface reflectivity matrix
                   direct_reflectivity, & ! Input  reflectivity for direct irradiance
                      Solar_irradiance, & ! Input  Solar spectral irradiance
                      Is_Solar_Channel, & ! Input  Indicate solar affected channel
                  Source_Zenith_Radian, & ! Input  Point source (e.g. solar) zenith angle
                                   RTV, & ! Input  Structure containing forward part results
                               T_OD_TL, & ! Input  tangent-linear of layer optical depth
                  Planck_Atmosphere_TL, & ! Input  TL atmospheric layer Planck radiance
                     Planck_Surface_TL, & ! Input  TL surface Planck radiance
                         emissivity_TL, & ! Input  TL surface emissivity
                       reflectivity_TL, & ! Input  TL surface reflectivity matrix
                direct_reflectivity_TL, & ! Input  TL surface ditrct reflectivity
                             up_rad_TL)   ! Output TL TOA radiance
! --------------------------------------------------------------------------- !
!  FUNCTION: Compute tangent-linear upward radiance at the top of the         !
!    atmosphere using carried results in RTV structure from forward           !
!    calculation.                                                             !
!    Quanhua Liu    Quanhua.Liu@noaa.gov                                      !
! --------------------------------------------------------------------------- !
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: n_Layers, n_Angles
      LOGICAL, INTENT(IN) :: Is_Solar_Channel
      REAL (fp), INTENT(IN) :: Solar_irradiance, Source_Zenith_Radian
      REAL (fp), INTENT(IN), DIMENSION( : ) ::  emissivity,T_OD_TL,emissivity_TL
      REAL (fp), INTENT(IN), DIMENSION( :,: ) :: reflectivity ,reflectivity_TL
      REAL (fp), INTENT(IN), DIMENSION( : ) :: direct_reflectivity,direct_reflectivity_TL
      REAL (fp), INTENT(IN), DIMENSION( 0: ) :: Planck_Atmosphere,Planck_Atmosphere_TL
      REAL (fp), INTENT(IN) :: Planck_Surface,u,Planck_Surface_TL
      REAL (fp), INTENT(INOUT) :: up_rad_TL

    !   Structure RTV carried in variables from forward calculation.
      TYPE(RTV_type), INTENT( IN) :: RTV
    !  internal variables
      REAL (fp) :: layer_source_up_TL, layer_source_down_TL,a_TL,down_rad_TL
      REAL (fp) :: Total_OD, Total_OD_TL
      INTEGER :: k
      REAL( fp) :: cosine_u0

    !#--------------------------------------------------------------------------#
    !#                -- Downwelling TL radiance   --                           #
    !#--------------------------------------------------------------------------#

      down_rad_TL = ZERO
      Total_OD_TL = ZERO

      Total_OD = RTV%Total_OD

      DO k = 1, n_Layers
       ! accumulate tangent-linear optical depth
       Total_OD_TL = Total_OD_TL + T_OD_TL(k)
       a_TL = -T_OD_TL(k) * RTV%Secant_Down_Angle

       layer_source_down_TL = Planck_Atmosphere_TL(k) * ( ONE - RTV%e_Layer_Trans_DOWN(k) ) &
                            - Planck_Atmosphere(k) * RTV%e_Layer_Trans_DOWN(k) * a_TL

     ! downward tangent-linear radiance
     !    down_rad(k) = down_rad(k-1) * layer_trans(k) + layer_source_down
       down_rad_TL = down_rad_TL*RTV%e_Layer_Trans_DOWN(k)  &
       +RTV%e_Level_Rad_DOWN(k-1)*RTV%e_Layer_Trans_DOWN(k)*a_TL+layer_source_down_TL
      ENDDO

    !#--------------------------------------------------------------------------#
    !#                -- at surface   --                                        #
    !#--------------------------------------------------------------------------#

      ! upward tangent-linear radiance at the surface
       up_rad_TL =emissivity_TL(n_Angles)*Planck_Surface+emissivity(n_Angles)*Planck_Surface_TL &
       +reflectivity_TL(1,1)*RTV%e_Level_Rad_DOWN(n_Layers)+reflectivity(1,1)*down_rad_TL

      ! point source (e.g. solar radiation)
       IF( Is_Solar_Channel ) THEN
        cosine_u0 = cos(Source_Zenith_Radian)
        IF( cosine_u0 > ZERO) THEN
        up_rad_TL = up_rad_TL + cosine_u0*Solar_Irradiance/PI &
                  * direct_reflectivity_TL(1) * exp(-Total_OD/cosine_u0)   &
                  - Solar_Irradiance/PI * direct_reflectivity(1)    &
                  * Total_OD_TL * exp(-Total_OD/cosine_u0)
        ENDIF
       ENDIF

    !#--------------------------------------------------------------------------#
    !#            -- Upwelling TL radiance   --                                 #
    !#--------------------------------------------------------------------------#

      DO k = n_Layers, 1, -1
       a_TL = -T_OD_TL(k)/u
       layer_source_up_TL = Planck_Atmosphere_TL(k) * ( ONE - RTV%e_Layer_Trans_UP(k) ) &
                          - Planck_Atmosphere(k) * RTV%e_Layer_Trans_UP(k) * a_TL

      ! upward tangent linear radiance
       up_rad_TL=up_rad_TL*RTV%e_Layer_Trans_UP(k)  &
       +RTV%e_Level_Rad_UP(k)*RTV%e_Layer_Trans_UP(k)*a_TL+layer_source_up_TL
      ENDDO
!
      RETURN
      END SUBROUTINE CRTM_Emission_TL
!
!
      SUBROUTINE CRTM_Emission_AD(n_Layers, & ! Input  number of atmospheric layers
                                  n_Angles, & ! number angles used in SfcOptics
                                         u, & ! Input  cosine of local viewing angle
                         Planck_Atmosphere, & ! Input  atmospheric layer Planck radiance
                            Planck_Surface, & ! Input  surface Planck radiance
                                emissivity, & ! Input  surface emissivity
                              reflectivity, & ! Input  surface reflectivity matrix
                       direct_reflectivity, & ! Input  surface reflectivity matrix
                          Solar_irradiance, & ! Input  Solar spectral irradiance
                          Is_Solar_Channel, & ! Input  Indicate solar affected channel
                      Source_Zenith_Radian, & ! Input  Point source (e.g. solar) zenith angle
                                       RTV, & ! Input  Structure containing forward part results
                              up_rad_AD_in, & ! Input  adjoint radiance at the top
                                   T_OD_AD, & ! Output AD layer optical depth
                      Planck_Atmosphere_AD, & ! Output AD atmospheric layer Planck radiance
                         Planck_Surface_AD, & ! Output AD surface Planck radiance
                             emissivity_AD, & ! Output AD surface emissivity
                           reflectivity_AD, & ! Output AD surface reflectivity matrix
                    direct_reflectivity_AD)   ! Output AD surface direct reflectivity
! --------------------------------------------------------------------------- !
!  FUNCTION: Compute adjoint upward radiance at the top of the                !
!    atmosphere using carried results in RTV structure from forward           !
!    calculation.                                                             !
!    Quanhua Liu    Quanhua.Liu@noaa.gov                                      !
! --------------------------------------------------------------------------- !
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: n_Layers, n_Angles
      LOGICAL, INTENT(IN) :: Is_Solar_Channel
      REAL (fp), INTENT(IN) :: Solar_Irradiance, Source_Zenith_Radian
      REAL (fp), INTENT(IN), DIMENSION( : ) ::  emissivity
      REAL (fp), INTENT(IN), DIMENSION( :,: ) :: reflectivity
      REAL (fp), INTENT(IN), DIMENSION( : ) :: direct_reflectivity
      REAL (fp), INTENT(IN), DIMENSION( 0: ) ::  Planck_Atmosphere
      REAL (fp), INTENT(IN) :: Planck_Surface,u
      REAL (fp), INTENT(IN) :: up_rad_AD_in
      REAL (fp), INTENT(IN OUT), DIMENSION( : ) ::  T_OD_AD,emissivity_AD
      REAL (fp), INTENT(IN OUT), DIMENSION( :,: ) :: reflectivity_AD
      REAL (fp), INTENT(IN OUT), DIMENSION( : ) :: direct_reflectivity_AD
      REAL (fp), INTENT(IN OUT), DIMENSION( 0: ) ::  Planck_Atmosphere_AD
      REAL (fp), INTENT(IN OUT) :: Planck_Surface_AD
      TYPE(RTV_type), INTENT( IN) :: RTV
    !  internal variables
      REAL (fp) :: layer_source_up_AD, layer_source_down_AD,a_AD,down_rad_AD
      REAL (fp) :: cosine_u0, up_rad_AD, Total_OD, Total_OD_AD
      INTEGER :: k
!
    ! Initialize variables
      Total_OD_AD = ZERO
      T_OD_AD = ZERO
      Planck_Atmosphere_AD = ZERO
      Planck_Surface_AD = ZERO
      emissivity_AD = ZERO
      reflectivity_AD = ZERO
      direct_reflectivity_AD = ZERO
      up_rad_AD = up_rad_AD_in

    ! Total column optical depth carried from forward part
      Total_OD = RTV%Total_OD

    !#--------------------------------------------------------------------------#
    !#                -- Upwelling adjoint radiance   --                        #
    !#--------------------------------------------------------------------------#
!
      DO k = 1, n_Layers
       a_AD = RTV%e_Level_Rad_UP(k)*RTV%e_Layer_Trans_UP(k)*up_rad_AD
       layer_source_up_AD = up_rad_AD
       up_rad_AD = up_rad_AD * RTV%e_Layer_Trans_UP(k)

       Planck_Atmosphere_AD(k) = Planck_Atmosphere_AD(k) + &
              layer_source_up_AD * (ONE - RTV%e_Layer_Trans_UP(k))
       a_AD = a_AD - Planck_Atmosphere(k) * RTV%e_Layer_Trans_UP(k)* layer_source_up_AD

       T_OD_AD(k) = T_OD_AD(k) - a_AD/u
      ENDDO
    !#--------------------------------------------------------------------------#
    !#                -- at surface   --                                        #
    !#--------------------------------------------------------------------------#

       IF( Is_Solar_Channel ) THEN
        cosine_u0 = cos(Source_Zenith_Radian)
        IF( cosine_u0 > ZERO) THEN
        Total_OD_AD = -Solar_Irradiance/PI * direct_reflectivity(1) &
                    * up_rad_AD * exp(-Total_OD/cosine_u0)
        direct_reflectivity_AD(1) = cosine_u0 * Solar_Irradiance/PI &
                    * up_rad_AD* exp(-Total_OD/cosine_u0)
        ENDIF
       ENDIF

      emissivity_AD(n_Angles)=up_rad_AD*Planck_Surface
      Planck_Surface_AD = emissivity(n_Angles)*up_rad_AD
      reflectivity_AD(1,1)=up_rad_AD*RTV%e_Level_Rad_DOWN(n_Layers)
      down_rad_AD = reflectivity(1,1)*up_rad_AD
!
    !#--------------------------------------------------------------------------#
    !#                -- Downward adjoint radiance   --                         #
    !#--------------------------------------------------------------------------#
      DO k = n_Layers, 1, -1

       a_AD = RTV%e_Level_Rad_DOWN(k-1)*RTV%e_Layer_Trans_DOWN(k)*down_rad_AD
       layer_source_down_AD = down_rad_AD
       down_rad_AD = down_rad_AD*RTV%e_Layer_Trans_DOWN(k)

       Planck_Atmosphere_AD(k) = Planck_Atmosphere_AD(k) + layer_source_down_AD * &
                                 (ONE - RTV%e_Layer_Trans_DOWN(k))
       a_AD = a_AD - Planck_Atmosphere(k) * RTV%e_Layer_Trans_DOWN(k)* layer_source_down_AD

       T_OD_AD(k) = T_OD_AD(k) - a_AD * RTV%Secant_Down_Angle

       T_OD_AD(k) = T_OD_AD(k) + Total_OD_AD
      ENDDO

      down_rad_AD = ZERO

      RETURN
      END SUBROUTINE CRTM_Emission_AD

END MODULE Emission_Module


MODULE obs_readmdt
  USE par_kind
  USE par_oce
  USE in_out_manager
  USE obs_surf_def
  USE obs_inter_sup
  USE obs_inter_h2d
  USE obs_utils
  USE iom_nf90
  USE netcdf
  USE lib_mpp
  USE dom_oce, ONLY: tmask, tmask_i, e1e2t, gphit, glamt
  USE obs_const, ONLY: obfillflt
  USE oce, ONLY: sshn
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: obs_rea_mdt
  PUBLIC :: obs_offset_mdt
  INTEGER, PUBLIC :: nn_msshc = 1
  REAL(KIND = wp), PUBLIC :: rn_mdtcorr = 1.61_wp
  REAL(KIND = wp), PUBLIC :: rn_mdtcutoff = 65.0_wp
  CONTAINS
  SUBROUTINE obs_rea_mdt(sladata, k2dint)
    USE iom
    TYPE(obs_surf), INTENT(INOUT) :: sladata
    INTEGER, INTENT(IN) :: k2dint
    CHARACTER(LEN = 12), PARAMETER :: cpname = 'obs_rea_mdt'
    CHARACTER(LEN = 20), PARAMETER :: mdtname = 'slaReferenceLevel.nc'
    INTEGER :: jobs
    INTEGER :: jpimdt, jpjmdt
    INTEGER :: iico, ijco
    INTEGER :: i_nx_id, i_ny_id, i_file_id, i_var_id, i_stat
    INTEGER :: nummdt
    REAL(KIND = wp), DIMENSION(1) :: zext, zobsmask
    REAL(KIND = wp), DIMENSION(2, 2, 1) :: zweig
    REAL(KIND = wp), DIMENSION(:, :, :), ALLOCATABLE :: zmask, zmdtl, zglam, zgphi
    INTEGER, DIMENSION(:, :, :), ALLOCATABLE :: igrdi, igrdj
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: z_mdt, mdtmask
    REAL(KIND = wp) :: zlam, zphi, zfill, zinfill
    IF (lwp) WRITE(numout, FMT = *)
    IF (lwp) WRITE(numout, FMT = *) ' obs_rea_mdt : Read MDT for referencing altimeter anomalies'
    IF (lwp) WRITE(numout, FMT = *) ' ------------- '
    CALL FLUSH(numout)
    CALL iom_open(mdtname, nummdt)
    CALL iom_get(nummdt, jpdom_data, 'sossheig', z_mdt(:, :), 1)
    CALL iom_close(nummdt)
    zinfill = 0.0
    i_stat = nf90_open(mdtname, nf90_nowrite, nummdt)
    i_stat = nf90_inq_varid(nummdt, 'sossheig', i_var_id)
    i_stat = nf90_get_att(nummdt, i_var_id, "_FillValue", zinfill)
    zfill = zinfill
    i_stat = nf90_close(nummdt)
    WHERE (z_mdt(:, :) /= zfill)
      mdtmask(:, :) = tmask(:, :, 1)
    ELSEWHERE
      mdtmask(:, :) = 0
    END WHERE
    IF (nn_msshc == 1 .OR. nn_msshc == 2) CALL obs_offset_mdt(jpi, jpj, z_mdt, zfill)
    ALLOCATE(igrdi(2, 2, sladata % nsurf), igrdj(2, 2, sladata % nsurf), zglam(2, 2, sladata % nsurf), zgphi(2, 2, sladata % nsurf), zmask(2, 2, sladata % nsurf), zmdtl(2, 2, sladata % nsurf))
    DO jobs = 1, sladata % nsurf
      igrdi(1, 1, jobs) = sladata % mi(jobs) - 1
      igrdj(1, 1, jobs) = sladata % mj(jobs) - 1
      igrdi(1, 2, jobs) = sladata % mi(jobs) - 1
      igrdj(1, 2, jobs) = sladata % mj(jobs)
      igrdi(2, 1, jobs) = sladata % mi(jobs)
      igrdj(2, 1, jobs) = sladata % mj(jobs) - 1
      igrdi(2, 2, jobs) = sladata % mi(jobs)
      igrdj(2, 2, jobs) = sladata % mj(jobs)
    END DO
    CALL obs_int_comm_2d(2, 2, sladata % nsurf, jpi, jpj, igrdi, igrdj, glamt, zglam)
    CALL obs_int_comm_2d(2, 2, sladata % nsurf, jpi, jpj, igrdi, igrdj, gphit, zgphi)
    CALL obs_int_comm_2d(2, 2, sladata % nsurf, jpi, jpj, igrdi, igrdj, mdtmask, zmask)
    CALL obs_int_comm_2d(2, 2, sladata % nsurf, jpi, jpj, igrdi, igrdj, z_mdt, zmdtl)
    DO jobs = 1, sladata % nsurf
      zlam = sladata % rlam(jobs)
      zphi = sladata % rphi(jobs)
      CALL obs_int_h2d_init(1, 1, k2dint, zlam, zphi, zglam(:, :, jobs), zgphi(:, :, jobs), zmask(:, :, jobs), zweig, zobsmask)
      CALL obs_int_h2d(1, 1, zweig, zmdtl(:, :, jobs), zext)
      sladata % rext(jobs, 2) = zext(1)
      IF (zobsmask(1) == 0) sladata % nqc(jobs) = IBSET(sladata % nqc(jobs), 15)
    END DO
    DEALLOCATE(igrdi, igrdj, zglam, zgphi, zmask, zmdtl)
    IF (lwp) WRITE(numout, FMT = *) ' ------------- '
  END SUBROUTINE obs_rea_mdt
  SUBROUTINE obs_offset_mdt(kpi, kpj, mdt, zfill)
    INTEGER, INTENT(IN) :: kpi, kpj
    REAL(KIND = wp), DIMENSION(kpi, kpj), INTENT(INOUT) :: mdt
    REAL(KIND = wp), INTENT(IN   ) :: zfill
    INTEGER :: ji, jj
    REAL(KIND = wp) :: zdxdy, zarea, zeta1, zeta2, zcorr_mdt, zcorr_bcketa, zcorr
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zpromsk
    CHARACTER(LEN = 14), PARAMETER :: cpname = 'obs_offset_mdt'
    !$ACC KERNELS
    DO ji = 1, jpi
      DO jj = 1, jpj
        zpromsk(ji, jj) = tmask_i(ji, jj)
        IF ((gphit(ji, jj) .GT. rn_mdtcutoff) .OR. (gphit(ji, jj) .LT. - rn_mdtcutoff) .OR. (mdt(ji, jj) .EQ. zfill)) zpromsk(ji, jj) = 0.0
      END DO
    END DO
    zarea = 0.0
    zeta1 = 0.0
    zeta2 = 0.0
    DO jj = 1, jpj
      DO ji = 1, jpi
        zdxdy = e1e2t(ji, jj) * zpromsk(ji, jj)
        zarea = zarea + zdxdy
        zeta1 = zeta1 + mdt(ji, jj) * zdxdy
        zeta2 = zeta2 + sshn(ji, jj) * zdxdy
      END DO
    END DO
    !$ACC END KERNELS
    IF (lk_mpp) CALL mpp_sum(zeta1)
    IF (lk_mpp) CALL mpp_sum(zeta2)
    IF (lk_mpp) CALL mpp_sum(zarea)
    zcorr_mdt = zeta1 / zarea
    zcorr_bcketa = zeta2 / zarea
    zcorr = zcorr_mdt - zcorr_bcketa
    IF (nn_msshc == 1) mdt(:, :) = mdt(:, :) - zcorr
    IF (nn_msshc == 2) mdt(:, :) = mdt(:, :) - rn_mdtcorr
    IF (lwp) THEN
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) ' obs_readmdt : rn_mdtcutoff     = ', rn_mdtcutoff
      WRITE(numout, FMT = *) ' -----------   zcorr_mdt     = ', zcorr_mdt
      WRITE(numout, FMT = *) '               zcorr_bcketa  = ', zcorr_bcketa
      WRITE(numout, FMT = *) '               zcorr         = ', zcorr
      WRITE(numout, FMT = *) '               nn_msshc        = ', nn_msshc
    END IF
    IF (nn_msshc == 0) WRITE(numout, FMT = *) '           MSSH correction is not applied'
    IF (nn_msshc == 1) WRITE(numout, FMT = *) '           MSSH correction is applied'
    IF (nn_msshc == 2) WRITE(numout, FMT = *) '           User defined MSSH correction'
  END SUBROUTINE obs_offset_mdt
END MODULE obs_readmdt


      subroutine reccnst

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine inputs measured loadings to the stream network
!!    for routing through the watershed where the records are averaged
!!    over the entire period of record

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    bactlpcnst(:)|# cfu/100ml  |average daily less persistent bacteria
!!                               |loading to reach
!!    bactpcnst(:)|# cfu/100ml   |average daily persistent bacteria loading
!!                               |to reach
!!    cbodcnst(:) |kg/day        |average daily CBOD loading to reach
!!    chlacnst(:) |kg/day        |average daily chlorophyll-a loading to reach
!!    cmtl1cnst(:)|kg/day        |average daily conservative metal #1 loading
!!    cmtl2cnst(:)|kg/day        |average daily conservative metal #2 loading
!!    cmtl3cnst(:)|kg/day        |average daily conservative metal #3 loading
!!    disoxcnst(:)|kg/day        |average daily dissolved oxygen loading to reach
!!    flocnst(:)  |m^3 H2O/day   |average daily water loading to reach
!!    ievent      |none          |rainfall/runoff code
!!                               |0 daily rainfall/curve number technique
!!                               |1 sub-daily rainfall/Green&Ampt/hourly
!!                               |  routing
!!    ihout       |none          |hydrograph storage location number
!!    inum1       |none          |file number
!!    mvaro       |none          |max number of variables routed through the
!!                               |reach
!!    minpcnst(:) |kg P/day      |average daily soluble P loading to reach
!!    nh3cnst(:)  |kg N/day      |average daily ammonia loading to reach
!!    no2cnst(:)  |kg N/day      |average daily nitrite loading to reach
!!    no3cnst(:)  |kg N/day      |average daily nitrate loading to reach
!!    orgncnst(:) |kg N/day      |average daily organic N loading to reach
!!    orgpcnst(:) |kg P/day      |average daily organic P loading to reach
!!    sedcnst(:)  |metric tons/d |average daily sediment loading to reach
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name             |units        |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    hhvaroute(2,:,:) |m^3          |volume of water
!!    hhvaroute(3,:,:) |metric tons  |sediment
!!    hhvaroute(4,:,:) |kg N         |organic N
!!    hhvaroute(5,:,:) |kg P         |organic P
!!    hhvaroute(6,:,:) |kg N         |NO3-N
!!    hhvaroute(7,:,:) |kg P         |mineral (soluble) P
!!    hhvaroute(13,:,:)|kg           |chlorophyll-a
!!    hhvaroute(14,:,:)|kg N         |NH3
!!    hhvaroute(15,:,:)|kg N         |NO2
!!    hhvaroute(16,:,:)|kg           |carbonaceous biological oxygen demand
!!    hhvaroute(17,:,:)|kg           |dissolved oxygen
!!    hhvaroute(18,:,:)|# cfu/100ml  |persistent bacteria
!!    hhvaroute(19,:,:)|# cfu/100ml  |less persistent bacteria
!!    hhvaroute(20,:,:)|kg           |conservative metal #1
!!    hhvaroute(21,:,:)|kg           |conservative metal #2
!!    hhvaroute(22,:,:)|kg           |conservative metal #3
!!    varoute(2,:)     |m^3          |volume of water
!!    varoute(3,:)     |metric tons  |sediment
!!    varoute(4,:)     |kg N         |organic N
!!    varoute(5,:)     |kg P         |organic P
!!    varoute(6,:)     |kg N         |NO3-N
!!    varoute(7,:)     |kg P         |mineral (soluble) P
!!    varoute(13,:)    |kg           |chlorophyll-a
!!    varoute(14,:)    |kg N         |NH3
!!    varoute(15,:)    |kg N         |NO2
!!    varoute(16,:)    |kg           |CBOD
!!    varoute(17,:)    |kg           |dissolved oxygen
!!    varoute(18,:)    |# cfu/100ml  |persistent bacteria
!!    varoute(19,:)    |# cfu/100ml  |less persistent bacteria
!!    varoute(20,:)    |kg           |conservative metal #1
!!    varoute(21,:)    |kg           |conservative metal #2
!!    varoute(22,:)    |kg           |conservative metal #3
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ii          |none          |counter
!!    j           |none          |counter
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer :: ii, j

!! zero flow out variables
      do j = 1, mvaro
        varoute(j,ihout) = 0.
        if (ievent > 0) then
          do ii = 1, nstep
            hhvaroute(j,ihout,ii) = 0.
          end do
        endif
      end do

      varoute(2,ihout) = flocnst(inum1)
      varoute(3,ihout) = sedcnst(inum1)
      varoute(4,ihout) = orgncnst(inum1)
      varoute(5,ihout) = orgpcnst(inum1)
      varoute(6,ihout) = no3cnst(inum1)
      varoute(7,ihout) = minpcnst(inum1)
      varoute(11,ihout) = solpstcnst(inum1)
      varoute(12,ihout) = srbpstcnst(inum1)
      varoute(13,ihout) = chlacnst(inum1)
      varoute(14,ihout) = nh3cnst(inum1)
      varoute(15,ihout) = no2cnst(inum1)
      varoute(16,ihout) = cbodcnst(inum1)
      varoute(17,ihout) = disoxcnst(inum1)
      varoute(18,ihout) = bactpcnst(inum1)
      varoute(19,ihout) = bactlpcnst(inum1)
      varoute(20,ihout) = cmtl1cnst(inum1)
      varoute(21,ihout) = cmtl2cnst(inum1)
      varoute(22,ihout) = cmtl3cnst(inum1)

      !! Assumed equal distribution of sediment
      varoute(23,ihout) = sedcnst(inum1) * 0.   ! sand
      varoute(24,ihout) = sedcnst(inum1) * 1.   ! silt
      varoute(25,ihout) = sedcnst(inum1) * 0.   ! cla
      varoute(26,ihout) = sedcnst(inum1) * 0.   ! sag
      varoute(27,ihout) = sedcnst(inum1) * 0.   ! lag
      varoute(28,ihout) = 0.                    ! gravel

      if (ievent > 0) then
        do ii = 1,nstep
          hhvaroute(2,ihout,ii) = flocnst(inum1) / real(nstep)
          hhvaroute(3,ihout,ii) = sedcnst(inum1) / real(nstep)
          hhvaroute(4,ihout,ii) = orgncnst(inum1) / real(nstep)
          hhvaroute(5,ihout,ii) = orgpcnst(inum1) / real(nstep)
          hhvaroute(6,ihout,ii) = no3cnst(inum1) / real(nstep)
          hhvaroute(7,ihout,ii) = minpcnst(inum1) / real(nstep)
          hhvaroute(11,ihout,ii) = solpstcnst(inum1) / real(nstep)
          hhvaroute(12,ihout,ii) = srbpstcnst(inum1) / real(nstep)
          hhvaroute(13,ihout,ii) = chlacnst(inum1) / real(nstep)
          hhvaroute(14,ihout,ii) = nh3cnst(inum1) / real(nstep)
          hhvaroute(15,ihout,ii) = no2cnst(inum1) / real(nstep)
          hhvaroute(16,ihout,ii) = cbodcnst(inum1) / real(nstep)
          hhvaroute(17,ihout,ii) = disoxcnst(inum1) / real(nstep)
          hhvaroute(18,ihout,ii) = bactpcnst(inum1) / real(nstep)
          hhvaroute(19,ihout,ii) = bactlpcnst(inum1) / real(nstep)
          hhvaroute(20,ihout,ii) = cmtl1cnst(inum1) / real(nstep)
          hhvaroute(21,ihout,ii) = cmtl2cnst(inum1) / real(nstep)
          hhvaroute(22,ihout,ii) = cmtl3cnst(inum1) / real(nstep)
        end do
      end if

      return
      end


program de_mierda
    use dynamo
    implicit none
    integer :: i, t
    logical, dimension(:), allocatable :: acs

    call dynamo_header

    call mm_file_process( "borra", "opls" )
    call mm_system_construct( "borra", "seq" )

    allocate( acs(1:natoms) )

    acs = atom_selection( subsystem = (/ "A" /), residue_number = (/ 144 /), &
        atom_name = (/ "C", "O" /) )
    acs = acs .or. atom_selection( subsystem = (/ "A" /), residue_number = (/ 145 /), &
        atom_name = (/ "N  ", "H43", "CA ", "CB ", "SG ", "C34", "C24", "H63", "N23", &
        "H62", "C21", "O22", "C26", "H64", "H65", "C27", "H66", "C29", "H67", "H68", &
        "C30", "H69", "H70", "N31", "H71", "C32", "O33", "O35", "H72", "C36", "H73", &
        "H74", "O37", "H75", "H47", "H48", "H46", "C  ", "O  " /) )
    acs = acs .or. atom_selection( subsystem = (/ "A" /), residue_number = (/ 146 /), &
        atom_name = (/ "N  ", "H  ", "CA ", "HA3", "HA2" /) )
    acs = acs .or. atom_selection( subsystem = (/ "A" /), residue_number = (/ 41 /), &
        atom_name = (/ "CB ", "HB3", "HB2", "CG ", "ND1", "CE1", "HE1", "NE2", "HE2", &
        "CD2", "HD2" /) )

    open( unit = 999, file = "data", action = "write", form = "unformatted" )
    write( 999 ) atmchg
    ! - ATMEPS(I)   = 2.0_DP * SQRT ( TYPES(MM)%EPSILON )
    write( 999 ) ( atmeps * 0.5d0 ) ** 2
! - HACK_AMBER -----------------------------------------------
!    ! - ATMSIG(I)   = 0.5_DP * TYPES(MM)%SIGMA
!    write( 999 ) ( atmsig * 2.0d0 ) * 0.5612310241546865d0
! - DEFAULT --------------------------------------------------
    ! - ATMSIG(I)   = SQRT ( TYPES(MM)%SIGMA )
    write( 999 ) ( atmsig ** 2 ) * 0.5612310241546865d0
! ------------------------------------------------------------
    close( 999 )
    ! - exlcusions -
    write( *, "(a)" ) "        self.exc = []"
    write( *, "(a)" ) "        # ------------------------------"
    do i = 1, nbonds
        t = 0
        if( acs( bonds(i)%i ) ) t = t + 1
        if( acs( bonds(i)%j ) ) t = t + 1
        if( t == 0 .or. t == 2 ) cycle
        write( *, "(a,f8.1,a,f8.3,a,i6,a,i6,a)" ) &
                "        self.exc.append( qm3.engines.mmres.distance(", &
                bonds(i)%fc, ", ", bonds(i)%eq, &
                ", [", bonds(i)%i - 1, ", ", bonds(i)%j - 1, " ] ) )"
        write( *, "(a)" ) "        self.exc[-1].ffac = 0.0"
        if( acs( bonds(i)%i ) ) then
            write( *, "(a)" ) "        self.exc[-1].gfac = [ 1.0, 0.0 ]"
        else
            write( *, "(a)" ) "        self.exc[-1].gfac = [ 0.0, 1.0 ]"
        end if
    end do
    write( *, "(a)" ) "        # ------------------------------"
    do i = 1, nangles
        t = 0
        if( acs( angles(i)%i ) ) t = t + 1
        if( acs( angles(i)%j ) ) t = t + 1
        if( acs( angles(i)%k ) ) t = t + 1
        if( t == 0 .or. t == 2 .or. t == 3 ) cycle
        write( *, "(a,f8.1,a,f8.3,a,i6,a,i6,a,i6,a)" ) &
                "        self.exc.append( qm3.engines.mmres.angle(", &
                angles(i)%fc, ", ", angles(i)%eq, &
                ", [", angles(i)%i - 1, &
                ", ", angles(i)%j - 1, &
                ", ", angles(i)%k - 1, " ] ) )"
        write( *, "(a)" ) "        self.exc[-1].ffac = 0.0"
        if( acs( angles(i)%i ) ) then
            write( *, "(a)" ) "        self.exc[-1].gfac = [ 1.0, 0.0, 0.0 ]"
        else if( acs( angles(i)%j ) ) then
            write( *, "(a)" ) "        self.exc[-1].gfac = [ 0.0, 1.0, 0.0 ]"
        else
            write( *, "(a)" ) "        self.exc[-1].gfac = [ 0.0, 0.0, 1.0 ]"
        end if
    end do
    write( *, "(a)" ) "        # ------------------------------"
    do i = 1, ndihedrals
        t = 0
        if( acs( dihedrals(i)%i ) ) t = t + 1
        if( acs( dihedrals(i)%j ) ) t = t + 1
        if( acs( dihedrals(i)%k ) ) t = t + 1
        if( acs( dihedrals(i)%l ) ) t = t + 1
        if( t == 0 .or. t == 3 .or. t == 4 ) cycle
        write( *, "(a,i3,a,f8.4,a,f6.1,a,a,i6,a,i6,a,i6,a,i6,a)" ) &
                "        self.exc.append( qm3.engines.mmres.dihedral( { ", &
                dihedrals(i)%period, ": [ ", dihedrals(i)%fc, ", ", 180.d0 * dihedrals(i)%phase," ] }", &
                ", [", dihedrals(i)%i - 1, &
                ", ", dihedrals(i)%j - 1, &
                ", ", dihedrals(i)%k - 1, &
                ", ", dihedrals(i)%l - 1, " ] ) )"
        write( *, "(a)" ) "        self.exc[-1].ffac = 0.0"
        write( *, "(a)", advance = "no" ) "        self.exc[-1].gfac = [ "
        if( acs( dihedrals(i)%i ) ) then
            write( *, "(a)", advance = "no" ) "1.0, "
        else
            write( *, "(a)", advance = "no" ) "0.0, "
        end if
        if( acs( dihedrals(i)%j ) ) then
            write( *, "(a)", advance = "no" ) "1.0, "
        else
            write( *, "(a)", advance = "no" ) "0.0, "
        end if
        if( acs( dihedrals(i)%k ) ) then
            write( *, "(a)", advance = "no" ) "1.0, "
        else
            write( *, "(a)", advance = "no" ) "0.0, "
        end if
        if( acs( dihedrals(i)%l ) ) then
            write( *, "(a)" ) "1.0 ]"
        else
            write( *, "(a)" ) "0.0 ]"
        end if
    end do

end