diff --git a/ben02/mod_ben02.F90 b/ben02/mod_ben02.F90 index f7154cca..513da355 100644 --- a/ben02/mod_ben02.F90 +++ b/ben02/mod_ben02.F90 @@ -658,11 +658,10 @@ subroutine initai real, dimension(0:atm_nwgt) :: r_wgt real :: piloc,min_d,d,r,l2 integer :: atm_idm_t,atm_jdm_t,idm_t,jdm_t,atm_nwgt_t,nw_2,is,js,it, & - jt,iso,jso,m,n,i,j,iii,ism1,isp1,jsm1,jsp1,itm1,itp1,jtm1, & - jtp1 + jt,iso,jso,m,n,i,j,iii,ism1,isp1,jsm1,jsp1,itm1,itp1,jtm1, & + jtp1,nfu logical :: dimok,exists character :: filename*120 - integer :: nfu ! --- Get global coordinates of p-points. call xcaget(tmp2da,plat,1) @@ -689,12 +688,12 @@ subroutine initai ! --- - Allocate memory for the atmospheric interpolation. allocate(atm_lon(atm_idm,atm_jdm), & - atm_lat(atm_idm,atm_jdm), & - atm_mask(atm_idm,atm_jdm), & - atm_topo(atm_idm,atm_jdm), & - atm_wgt(atm_nwgt,itdm,jtdm), & - atm_iwgt(atm_nwgt,itdm,jtdm), & - atm_jwgt(atm_nwgt,itdm,jtdm)) + atm_lat(atm_idm,atm_jdm), & + atm_mask(atm_idm,atm_jdm), & + atm_topo(atm_idm,atm_jdm), & + atm_wgt(atm_nwgt,itdm,jtdm), & + atm_iwgt(atm_nwgt,itdm,jtdm), & + atm_jwgt(atm_nwgt,itdm,jtdm)) ! --- - Read atmospheric lon/lat coordinates and land mask. filename = atm_path(1:atm_path_len)//'land.sfc.gauss.nc' @@ -881,12 +880,12 @@ subroutine fnlzai if (mnproc == 1) then deallocate(atm_lon, & - atm_lat, & - atm_mask, & - atm_topo, & - atm_wgt, & - atm_iwgt, & - atm_jwgt) + atm_lat, & + atm_mask, & + atm_topo, & + atm_wgt, & + atm_iwgt, & + atm_jwgt) end if end subroutine fnlzai @@ -1936,8 +1935,7 @@ subroutine rdcsic real, dimension(atm_idm,atm_jdm) :: atm_field real*4, dimension(atm_idm,atm_jdm) :: atm_field_r4 real, dimension(itdm,jtdm) :: tmp2d - integer :: i,j,k - integer :: nfu + integer :: i,j,k,nfu if (mnproc == 1) then write (lp,*) 'reading atm. climatological ice concentration...' @@ -1991,8 +1989,7 @@ subroutine rdctsf real, dimension(itdm,jtdm) :: tmp2d real :: dx2,dy2 integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: smtmsk - integer :: i,j,k,l - integer :: nfu + integer :: i,j,k,l,nfu if (mnproc == 1) then write (lp,*) & @@ -2105,53 +2102,52 @@ subroutine inifrc_ben02clim sht_sum,fwf_fac,dangle,garea,le,albedo,fac,swa_ave,lwa_ave, & lht_ave,sht_ave,crnf,cswa,A_cgs2mks real*4 :: rw4 - integer :: i,j,k,l,il,jl + integer :: i,j,k,l,il,jl,nfu integer*2 :: rn2,ri2,rj2 - integer :: nfu A_cgs2mks = 1./(L_mks2cgs**2) ! --- Allocate memory for additional monthly forcing fields. allocate(taud (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12), & - tauxd (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12), & - tauyd (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12), & - dswrfl(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12), & - nlwrfs(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12), & - shtflx(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12), & - lhtflx(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12), & - precip(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12), & - clouds(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12), & - slpres(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12), & - runoff(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12)) + tauxd (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12), & + tauyd (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12), & + dswrfl(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12), & + nlwrfs(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12), & + shtflx(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12), & + lhtflx(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12), & + precip(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12), & + clouds(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12), & + slpres(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12), & + runoff(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12)) ! --- Allocate memory for transfer coefficients, gustiness squared, and ! --- air density allocate(cd_d(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - ch_d(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - ce_d(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - wg2_d(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - cd_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - ch_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - ce_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - wg2_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - rhoa(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)) + ch_d(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + ce_d(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + wg2_d(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + cd_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + ch_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + ce_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + wg2_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + rhoa(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)) ! --- Allocate memory for accumulation variables allocate(tsi_tda(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - tml_tda(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - sml_tda(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - alb_tda(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - fice_tda(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - tsi(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)) + tml_tda(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + sml_tda(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + alb_tda(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + fice_tda(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + tsi(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)) ! --- Allocate memory for derivative of non-solar heat flux by surface ! --- temperature, albedos and instantaneous runoff flux and runoff ! --- reservoar allocate(dfl(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - albw(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - alb(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - rnfins(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - rnfres(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)) + albw(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + alb(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + rnfins(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + rnfres(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)) ! --- number of iteration in the computation of transfer coefficients. tciter = 5 @@ -2171,8 +2167,8 @@ subroutine inifrc_ben02clim ! --- Allocate memory for temporary fields if (mnproc == 1) then allocate(atm_sktclm(atm_idm,atm_jdm,12), & - atm_field(atm_idm,atm_jdm), & - atm_field_r4(atm_idm,atm_jdm)) + atm_field(atm_idm,atm_jdm), & + atm_field_r4(atm_idm,atm_jdm)) end if ! --- Compute smoothing weights atm_ice_swgt and atm_rnf_swgt. For @@ -2658,8 +2654,8 @@ subroutine inifrc_ben02clim ! --- - areas allocate(rnf_wgt (atm_abdm,atm_idm,atm_jdm), & - rnf_ocdpi(atm_abdm,atm_idm,atm_jdm), & - rnf_ocdpj(atm_abdm,atm_idm,atm_jdm)) + rnf_ocdpi(atm_abdm,atm_idm,atm_jdm), & + rnf_ocdpj(atm_abdm,atm_idm,atm_jdm)) if (expcnf == 'single_column') then rnf_wgt = 0. @@ -2752,8 +2748,8 @@ subroutine inifrc_ben02clim if (mnproc == 1) then close (unit = nfu) deallocate(rnf_wgt, & - rnf_ocdpi, & - rnf_ocdpj) + rnf_ocdpi, & + rnf_ocdpj) end if call xctilr(runoff, 1,12, nbdy,nbdy, halo_ps) @@ -2761,8 +2757,8 @@ subroutine inifrc_ben02clim ! --- Deallocate memory used for interpolation of surface fields. if (mnproc == 1) then deallocate(atm_sktclm, & - atm_field, & - atm_field_r4) + atm_field, & + atm_field_r4) end if call fnlzai @@ -2935,53 +2931,52 @@ subroutine inifrc_ben02syn real :: dx2,dy2 real*4 :: rw4 - integer :: errstat,i,j,k,l + integer :: errstat,i,j,k,l,nfu integer*2 :: rn2,ri2,rj2 - integer :: nfu ! --- Allocate memory for daily forcing fields. allocate(taud (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & - tauxd (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & - tauyd (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & - dswrfl(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & - nlwrfs(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & - shtflx(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & - lhtflx(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & - precip(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & - clouds(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & - slpres(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & - runoff(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & - tmpsfc(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & - ricec (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5)) + tauxd (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & + tauyd (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & + dswrfl(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & + nlwrfs(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & + shtflx(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & + lhtflx(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & + precip(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & + clouds(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & + slpres(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & + runoff(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & + tmpsfc(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5), & + ricec (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,5)) ! --- Allocate memory for transfer coefficients, gustiness squared, and ! --- air density allocate(cd_d(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - ch_d(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - ce_d(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - wg2_d(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - cd_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - ch_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - ce_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - wg2_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - rhoa(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)) + ch_d(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + ce_d(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + wg2_d(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + cd_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + ch_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + ce_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + wg2_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + rhoa(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)) ! --- Allocate memory for accumulation variables allocate(tsi_tda(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - tml_tda(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - sml_tda(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - alb_tda(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - fice_tda(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - tsi(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)) + tml_tda(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + sml_tda(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + alb_tda(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + fice_tda(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + tsi(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)) ! --- Allocate memory for derivative of non-solar heat flux by surface ! --- temperature, albedos and instantaneous runoff flux and runoff ! --- reservoar allocate(dfl(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - albw(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - alb(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - rnfins(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & - rnfres(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)) + albw(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + alb(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + rnfins(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), & + rnfres(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)) ! --- Number of iteration in the computation of transfer coefficients. tciter = 1 @@ -3067,8 +3062,8 @@ subroutine inifrc_ben02syn ! --- - areas allocate(rnf_wgt (atm_abdm,atm_idm,atm_jdm), & - rnf_ocdpi(atm_abdm,atm_idm,atm_jdm), & - rnf_ocdpj(atm_abdm,atm_idm,atm_jdm)) + rnf_ocdpi(atm_abdm,atm_idm,atm_jdm), & + rnf_ocdpj(atm_abdm,atm_idm,atm_jdm)) open (newunit=nfu,file = 'runoffweights.uf', & form='unformatted',status='old',action = 'read') diff --git a/ben02/mod_thermf_ben02.F90 b/ben02/mod_thermf_ben02.F90 index 3bf91c3c..da3968f3 100644 --- a/ben02/mod_thermf_ben02.F90 +++ b/ben02/mod_thermf_ben02.F90 @@ -1,18 +1,18 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2002-2023 Mats Bentsen, Mehmet Ilicak - +! Copyright (C) 2002-2024 Mats Bentsen, Mehmet Ilicak +! ! This file is part of BLOM. - +! ! BLOM is free software: you can redistribute it and/or modify it under the ! terms of the GNU Lesser General Public License as published by the Free ! Software Foundation, either version 3 of the License, or (at your option) ! any later version. - +! ! BLOM is distributed in the hope that it will be useful, but WITHOUT ANY ! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS ! FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for ! more details. - +! ! You should have received a copy of the GNU Lesser General Public License ! along with BLOM. If not, see . ! ------------------------------------------------------------------------------ @@ -25,7 +25,7 @@ module mod_thermf_ben02 nstep_in_day, baclin, & xmi, l1mi, l2mi, l3mi, l4mi, l5mi use mod_xc - use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml + use mod_vcoord, only: vcoord_tag, vcoord_isopyc_bulkml use mod_grid, only: scp2, plat, area use mod_state, only: dp, temp, saln, p use mod_swtfrz, only: swtfrz @@ -468,7 +468,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) ricclm(i,j,l3mi),ricclm(i,j,l4mi), & ricclm(i,j,l5mi),xmi) sstc = (1.-rice)*max(sstc,tice_f)+rice*tice_f - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then dpmxl = dp(i,j,1+nn)+dp(i,j,2+nn) hmxl = dpmxl/onem tmxl = (temp(i,j,1+nn)*dp(i,j,1+nn) & @@ -526,7 +526,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) sssc = intp1d(sssclm(i,j,l1mi),sssclm(i,j,l2mi), & sssclm(i,j,l3mi),sssclm(i,j,l4mi), & sssclm(i,j,l5mi),xmi) - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then dpmxl = dp(i,j,1+nn)+dp(i,j,2+nn) hmxl = dpmxl/onem smxl = (saln(i,j,1+nn)*dp(i,j,1+nn) & @@ -737,7 +737,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) call chksummsk(salrlx,ip,1,'salrlx') call chksummsk(iagem,ip,1,'iagem') call chksummsk(ustar,ip,1,'ustar') - if (vcoord_type_tag /= isopyc_bulkml) then + if (vcoord_tag /= vcoord_isopyc_bulkml) then call chksummsk(t_rs_nonloc, ip, kk+1, 't_rs_nonloc') call chksummsk(s_rs_nonloc, ip, kk+1, 's_rs_nonloc') end if diff --git a/cesm/mod_thermf_cesm.F90 b/cesm/mod_thermf_cesm.F90 index 2a60245a..d9a0d01a 100644 --- a/cesm/mod_thermf_cesm.F90 +++ b/cesm/mod_thermf_cesm.F90 @@ -25,7 +25,7 @@ module mod_thermf_cesm nday_of_year, baclin, & xmi, l1mi, l2mi, l3mi, l4mi, l5mi use mod_xc - use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml + use mod_vcoord, only: vcoord_tag, vcoord_isopyc_bulkml use mod_grid, only: scp2, area use mod_state, only: dp, temp, saln, p use mod_swtfrz, only: swtfrz @@ -211,7 +211,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) ricclm(i,j,l3mi),ricclm(i,j,l4mi), ricclm(i,j,l5mi),xmi) sstc = (1.-rice)*max(sstc,tice_f)+rice*tice_f end if - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then dpmxl = dp(i,j,1+nn)+dp(i,j,2+nn) hmxl = dpmxl/onem tmxl = (temp(i,j,1+nn)*dp(i,j,1+nn) + temp(i,j,2+nn)*dp(i,j,2+nn))/dpmxl+t0deg @@ -267,7 +267,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) sssc = intp1d(sssclm(i,j,l1mi),sssclm(i,j,l2mi), & sssclm(i,j,l3mi),sssclm(i,j,l4mi),sssclm(i,j,l5mi),xmi) end if - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then dpmxl = dp(i,j,1+nn)+dp(i,j,2+nn) hmxl = dpmxl/onem smxl = (saln(i,j,1+nn)*dp(i,j,1+nn) + saln(i,j,2+nn)*dp(i,j,2+nn))/dpmxl @@ -427,7 +427,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) call chksummsk(ustar,ip,1,'ustar') call chksummsk(frzpot,ip,1,'frzpot') call chksummsk(mltpot,ip,1,'mltpot') - if (vcoord_type_tag /= isopyc_bulkml) then + if (vcoord_tag /= vcoord_isopyc_bulkml) then call chksummsk(t_rs_nonloc, ip, kk+1, 't_rs_nonloc') call chksummsk(s_rs_nonloc, ip, kk+1, 's_rs_nonloc') end if diff --git a/channel/mod_channel.F90 b/channel/mod_channel.F90 index 5e283124..f305b9fd 100644 --- a/channel/mod_channel.F90 +++ b/channel/mod_channel.F90 @@ -71,10 +71,9 @@ subroutine geoenv_channel real(r8), dimension(itdm,jtdm) :: rtmp real(r8) :: sldepth,sfdepth,rdepth,cwidth,swidth,scxy, & corio0, beta0, d_corru, r - integer :: i,j,l,ios + integer :: nfu,i,j,l,ios integer, dimension(:), allocatable :: seed logical :: fexist - integer :: nfu ! Read parameters from the namelist namelist /idlgeo/ sldepth,sfdepth,rdepth,acorru,wlcorru, & @@ -217,9 +216,8 @@ subroutine ictsz_channel 1 - nbdy:jdm + nbdy, kdm) :: dz real(r8), dimension(kdm) :: sigmr0, dz0 real(r8) :: S0,sig0,sig0dz,sigdz,sigscl,dztop,dzmax,dzscl - integer i,j,k,l,ios + integer :: nfu,i,j,k,l,ios logical :: fexist - integer :: nfu namelist /idlini/ S0,sig0,sig0dz,sigdz,sigscl,dztop,dzmax,dzscl @@ -334,9 +332,8 @@ subroutine inifrc_channel intrinsic tanh real(r8) :: ztx0,mty0,sst0,sss0 - integer :: i,j,l,k,ios + integer :: nfu,i,j,l,k,ios logical :: fexist - integer :: nfu namelist /idlfor/ ztx0,mty0,sst0,sss0 diff --git a/cime_config/buildlib_2.1 b/cime_config/buildlib_2.1 index b36dc37d..55009bf4 100755 --- a/cime_config/buildlib_2.1 +++ b/cime_config/buildlib_2.1 @@ -53,7 +53,6 @@ def _main_func(): objroot = case.get_value("OBJROOT") comp_root_dir_ocn = case.get_value("COMP_ROOT_DIR_OCN") - turbclo = case.get_value("BLOM_TURBULENT_CLOSURE") tracers = case.get_value("BLOM_TRACER_MODULES") driver = case.get_value("COMP_INTERFACE") @@ -65,18 +64,17 @@ def _main_func(): os.path.join(comp_root_dir_ocn, "channel"), os.path.join(comp_root_dir_ocn, "single_column"), os.path.join(comp_root_dir_ocn, "pkgs", "CVMix-src", "src", "shared"), - os.path.join(comp_root_dir_ocn, "pkgs", "M4AGO-sinking-scheme", "src"), - os.path.join(comp_root_dir_ocn, "phy")] - - if turbclo != 0 and tracers != 0: - paths.append(os.path.join(comp_root_dir_ocn, "trc")) + os.path.join(comp_root_dir_ocn, "phy"), + os.path.join(comp_root_dir_ocn, "trc"), + os.path.join(comp_root_dir_ocn, "idlage")] if tracers != 0: for module in tracers.split(): if module == "iage": - paths.append(os.path.join(comp_root_dir_ocn, "idlage")) + continue elif module == "ecosys": paths.append(os.path.join(comp_root_dir_ocn, "hamocc")) + paths.append(os.path.join(comp_root_dir_ocn, "pkgs", "M4AGO-sinking-scheme", "src")) else: expect(False, "tracer module {} is not recognized".format(module)) diff --git a/cime_config/buildlib_2.2 b/cime_config/buildlib_2.2 index 343bab26..358b29e4 100755 --- a/cime_config/buildlib_2.2 +++ b/cime_config/buildlib_2.2 @@ -54,7 +54,6 @@ def _main_func(): objroot = case.get_value("OBJROOT") comp_root_dir_ocn = case.get_value("COMP_ROOT_DIR_OCN") - turbclo = case.get_value("BLOM_TURBULENT_CLOSURE") tracers = case.get_value("BLOM_TRACER_MODULES") driver = case.get_value("COMP_INTERFACE") diff --git a/cime_config/buildnml b/cime_config/buildnml index 6ef0f906..d9f39183 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -262,6 +262,7 @@ def buildnml(case, caseroot, compname): if case.get_value("BLOM_VCOORD") == "cntiso_hybrid": groups.append('vcoord') + groups.append('ale_regrid_remap') if "ecosys" in case.get_value("BLOM_TRACER_MODULES"): groups.append("bgcnml") diff --git a/cime_config/namelist_definition_blom.xml b/cime_config/namelist_definition_blom.xml index 3ee1e529..26b1d48f 100644 --- a/cime_config/namelist_definition_blom.xml +++ b/cime_config/namelist_definition_blom.xml @@ -914,13 +914,77 @@ $BLOM_VCOORD - add desc + Vertical coordinate type. Valid types: 'isopyc_bulkml', 'cntiso_hybrid', 'plevel' - + + char + vcoord + vcoord + + 'inicon' + + Reference potential density specification: Valid specs.: 'inicon', 'namelist' + + + char vcoord vcoord + + 'inflation' + + Pressure level specification: Valid specs.: 'inflation', 'namelist' + + + + real + vcoord + vcoord + + 2.5 + + Minimum surface layer thickness (m) + + + + real + vcoord + vcoord + + 1.08 + + Minimum layer thickness inflation factor + + + + real + vcoord + vcoord + + -1.,-1. + + Array of reference potential densities (kg/m3) + + + + real + vcoord + vcoord + + -1.,-1. + + Array of pressure levels (m) + + + + + + + + char + ale_regrid_remap + ale_regrid_remap ppm @@ -929,8 +993,8 @@ integer - vcoord - vcoord + ale_regrid_remap + ale_regrid_remap 6 @@ -939,8 +1003,8 @@ integer - vcoord - vcoord + ale_regrid_remap + ale_regrid_remap 4 @@ -949,8 +1013,8 @@ char - vcoord - vcoord + ale_regrid_remap + ale_regrid_remap monotonic @@ -959,8 +1023,8 @@ char - vcoord - vcoord + ale_regrid_remap + ale_regrid_remap non_oscillatory @@ -969,8 +1033,8 @@ char - vcoord - vcoord + ale_regrid_remap + ale_regrid_remap non_oscillatory @@ -979,8 +1043,8 @@ logical - vcoord - vcoord + ale_regrid_remap + ale_regrid_remap .false. @@ -989,8 +1053,8 @@ logical - vcoord - vcoord + ale_regrid_remap + ale_regrid_remap .false. @@ -999,8 +1063,8 @@ logical - vcoord - vcoord + ale_regrid_remap + ale_regrid_remap .true. @@ -1009,8 +1073,8 @@ logical - vcoord - vcoord + ale_regrid_remap + ale_regrid_remap .false. @@ -1019,8 +1083,8 @@ logical - vcoord - vcoord + ale_regrid_remap + ale_regrid_remap .true. @@ -1029,68 +1093,38 @@ logical - vcoord - vcoord + ale_regrid_remap + ale_regrid_remap .false. add desc - - real - vcoord - vcoord - - 2.5 - - add desc - - - - real - vcoord - vcoord - - 1.08 - - add desc - - real - vcoord - vcoord + ale_regrid_remap + ale_regrid_remap .1 add desc - - integer - vcoord - vcoord - - 4 - - add desc - - - - integer - vcoord - vcoord + + char + ale_regrid_remap + ale_regrid_remap - 2 + 'nudge' - add desc + Valid mehtods: 'nudge', 'direct' real - vcoord - vcoord + ale_regrid_remap + ale_regrid_remap 86400. @@ -1099,8 +1133,8 @@ real - vcoord - vcoord + ale_regrid_remap + ale_regrid_remap .75 @@ -1109,8 +1143,8 @@ real - vcoord - vcoord + ale_regrid_remap + ale_regrid_remap 50000. 50000.e4 @@ -1122,6 +1156,26 @@ add desc + + integer + ale_regrid_remap + ale_regrid_remap + + 4 + + add desc + + + + integer + ale_regrid_remap + ale_regrid_remap + + 2 + + add desc + + diff --git a/drivers/noforc/blom.F b/drivers/noforc/blom.F index c583c3e3..6cfe47ee 100644 --- a/drivers/noforc/blom.F +++ b/drivers/noforc/blom.F @@ -37,8 +37,7 @@ program blom # include "mpif.h" #endif c - integer i - integer nfu + integer :: nfu, i c #ifdef MPI call mpi_init diff --git a/drivers/nuopc/ocn_import_export.F90 b/drivers/nuopc/ocn_import_export.F90 index fdcd1611..a2d84468 100644 --- a/drivers/nuopc/ocn_import_export.F90 +++ b/drivers/nuopc/ocn_import_export.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2022 Mats Bentsen +! Copyright (C) 2022-2024 Mats Bentsen ! ! This file is part of BLOM. ! @@ -37,7 +37,7 @@ module ocn_import_export use mod_forcing, only: wavsrc_opt, wavsrc_extern, sprfac, prfac, & flxco2, flxdms, flxbrf, flxn2o, flxnh3 use mod_difest, only: obldepth - use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid + use mod_vcoord, only: vcoord_tag, vcoord_isopyc_bulkml use mod_cesm, only: frzpot, mltpot, & swa_da, nsf_da, hmlt_da, lip_da, sop_da, eva_da, & rnf_da, rfi_da, fmltfz_da, sfl_da, ztx_da, mty_da, & @@ -596,8 +596,8 @@ subroutine blom_accflds enddo !$omp end parallel do - select case (vcoord_type_tag) - case (isopyc_bulkml) + select case (vcoord_tag) + case (vcoord_isopyc_bulkml) q = baclin/onem !$omp parallel do private(l, i) do j = 1, jj @@ -608,7 +608,7 @@ subroutine blom_accflds enddo enddo !$omp end parallel do - case (cntiso_hybrid) + case default !$omp parallel do private(l, i) do j = 1, jj do l = 1, isp(j) @@ -618,12 +618,6 @@ subroutine blom_accflds enddo enddo !$omp end parallel do - case default - if (mnproc == 1.and. first_call) then - write(lp,*) subname//': unsupported vertical coordinate!' - end if - call xcstop(subname) - stop subname end select if (index_Faoo_fco2 > 0) then diff --git a/fuk95/mod_fuk95.F90 b/fuk95/mod_fuk95.F90 index 3a53976d..041aa089 100644 --- a/fuk95/mod_fuk95.F90 +++ b/fuk95/mod_fuk95.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2021-2022 Mats Bentsen +! Copyright (C) 2021-2024 Mats Bentsen ! ! This file is part of BLOM. ! @@ -28,7 +28,7 @@ module mod_fuk95 use mod_constants, only: g, rearth, rho0, pi, radian, epsilz, & L_mks2cgs, R_mks2cgs use mod_xc - use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid, sigmar + use mod_vcoord, only: vcoord_tag, vcoord_isopyc_bulkml, sigmar use mod_grid, only: qclon, qclat, pclon, pclat, uclon, uclat, vclon, vclat, & scqx, scqy, scpx, scpy, scux, scuy, scvx, scvy, & scq2, scp2, scu2, scv2, & @@ -286,144 +286,136 @@ subroutine ictsz_fuk95 ! Set reference potential density, interface depths and layer salinity and ! temperature. - select case (vcoord_type_tag) + select case (vcoord_tag) - case (isopyc_bulkml) + case (vcoord_isopyc_bulkml) - ! For vertical coordinate featuring bulk surface mixed with - ! isopycnic layers below, set layer reference potential densities - ! and corresponding isopycnic layer structure. The bulk mixed layer - ! is set to the minimum mixed layer thickness. + ! For vertical coordinate featuring bulk surface mixed with + ! isopycnic layers below, set layer reference potential densities + ! and corresponding isopycnic layer structure. The bulk mixed layer + ! is set to the minimum mixed layer thickness. - drhojet = rhoc*f*u0*l0/(g*h1) - dsig = (drho + drhojet)/(kk - 4) - sigref(kk) = rhob - rho0 - sigref(kk - 1) = rhoc + .5_r8*(drho + drhojet) - rho0 - do k = kk - 2, 1, -1 - sigref(k) = sigref(k + 1) - dsig - enddo + drhojet = rhoc*f*u0*l0/(g*h1) + dsig = (drho + drhojet)/(kk - 4) + sigref(kk) = rhob - rho0 + sigref(kk - 1) = rhoc + .5_r8*(drho + drhojet) - rho0 + do k = kk - 2, 1, -1 + sigref(k) = sigref(k + 1) - dsig + enddo - !$omp parallel do private(k, l, i) - do j = 1, jj - do k = 1, kk - do l = 1, isp(j) - do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) - sigmar(i, j, k) = sigref(k) - sigma(i, j, k) = sigref(k) - saln(i, j, k) = saln0 - temp(i, j, k) = tofsig(sigma(i, j, k), saln(i, j, k)) + !$omp parallel do private(k, l, i) + do j = 1, jj + do k = 1, kk + do l = 1, isp(j) + do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) + sigmar(i, j, k) = sigref(k) + sigma(i, j, k) = sigref(k) + saln(i, j, k) = saln0 + temp(i, j, k) = tofsig(sigma(i, j, k), saln(i, j, k)) + enddo enddo enddo enddo - enddo - !$omp end parallel do + !$omp end parallel do - !$omp parallel do private(k, l, i, x, sigm, sigi) - do j = 1, jj - do l = 1, isp(j) - do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) - x = x_nudge(real(i, r8), real(j, r8)) - z(i, j, 1) = 0._r8 - z(i, j, 2) = .5_r8*mltmin*L_mks2cgs - z(i, j, 3) = mltmin*L_mks2cgs - z(i, j, kk ) = h1 - z(i, j, kk + 1) = h0 - sigm = rhoc*(1._r8 + f*u0*x_psi(x)/(g*h1)) - rho0 - sigma(i, j, 1) = sigm & - + .5_r8*drho*(z(i, j, 2) + z(i, j, 1) - h1)/h1 - sigma(i, j, 2) = sigm & - + .5_r8*drho*(z(i, j, 3) + z(i, j, 2) - h1)/h1 - temp(i, j, 1) = tofsig(sigma(i, j, 1), saln(i, j, 1)) - temp(i, j, 2) = tofsig(sigma(i, j, 2), saln(i, j, 2)) - enddo - enddo - do k = 4, kk - 1 + !$omp parallel do private(k, l, i, x, sigm, sigi) + do j = 1, jj do l = 1, isp(j) do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) x = x_nudge(real(i, r8), real(j, r8)) + z(i, j, 1) = 0._r8 + z(i, j, 2) = .5_r8*mltmin*L_mks2cgs + z(i, j, 3) = mltmin*L_mks2cgs + z(i, j, kk ) = h1 + z(i, j, kk + 1) = h0 sigm = rhoc*(1._r8 + f*u0*x_psi(x)/(g*h1)) - rho0 - sigi = .5_r8*(sigref(k - 1) + sigref(k)) - z(i, j, k) = ((sigi - sigm)/drho + .5_r8)*h1 - z(i, j, k) = min(z(i, j, kk) - mindz*(kk - k), & - max(z(i, j, 3), z(i, j, k))) + sigma(i, j, 1) = sigm & + + .5_r8*drho*(z(i, j, 2) + z(i, j, 1) - h1)/h1 + sigma(i, j, 2) = sigm & + + .5_r8*drho*(z(i, j, 3) + z(i, j, 2) - h1)/h1 + temp(i, j, 1) = tofsig(sigma(i, j, 1), saln(i, j, 1)) + temp(i, j, 2) = tofsig(sigma(i, j, 2), saln(i, j, 2)) enddo enddo - enddo - enddo - !$omp end parallel do - - case (cntiso_hybrid) - - ! For hybrid vertical coordinate featuring pressure coordinates - ! towards the surface and continous isopycnal below, set layer - ! interface reference potential densities. Initially the lowest - ! model layer occupy everything below the active layer, while the - ! active layer is distributed equally among the remaining model - ! layers using constant z-level interfaces. - - ! drhojet = rhoc*f*u0*l0/(g*h1) - ! dsig = (drho + drhojet)/(kk - 4) - ! sigref(kk) = .5_r8*(rhob + rhoc) + .25_r8*(drho + drhojet) - rho0 - ! sigref(kk - 1) = rhoc + .5_r8*(drho + drhojet - dsig) - rho0 - ! do k = kk - 2, 1, -1 - ! sigref(k) = sigref(k + 1) - dsig - ! enddo - drhojet = rhoc*f*u0*l0/(g*h1) - dsig = (drho + drhojet)/(kk - 5) - sigref(kk - 2) = rhoc + .5_r8*(drho + drhojet - dsig) - rho0 - do k = kk - 3, 1, -1 - sigref(k) = sigref(k + 1) - dsig - enddo - sigref(kk ) = rhob - rho0 - sigref(kk - 1) = (2._r8*sigref(kk - 2) + sigref(kk))/3._r8 - sigref(kk ) = (sigref(kk - 2) + 2._r8*sigref(kk))/3._r8 - - !$omp parallel do private(k, l, i) - do j = 1, jj - do k = 1, kk - do l = 1, isp(j) - do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) - sigmar(i, j, k) = sigref(k) - saln(i, j, k) = saln0 - z(i, j, k) = real(k - 1, r8)*h0/real(kk, r8) + do k = 4, kk - 1 + do l = 1, isp(j) + do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) + x = x_nudge(real(i, r8), real(j, r8)) + sigm = rhoc*(1._r8 + f*u0*x_psi(x)/(g*h1)) - rho0 + sigi = .5_r8*(sigref(k - 1) + sigref(k)) + z(i, j, k) = ((sigi - sigm)/drho + .5_r8)*h1 + z(i, j, k) = min(z(i, j, kk) - mindz*(kk - k), & + max(z(i, j, 3), z(i, j, k))) + enddo enddo enddo enddo - do l = 1, isp(j) - do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) - z(i, j, kk + 1) = h0 - enddo + !$omp end parallel do + + case default + + ! For hybrid vertical coordinate featuring pressure coordinates + ! towards the surface and continous isopycnal below, set layer + ! interface reference potential densities. Initially the lowest + ! model layer occupy everything below the active layer, while the + ! active layer is distributed equally among the remaining model + ! layers using constant z-level interfaces. + + ! drhojet = rhoc*f*u0*l0/(g*h1) + ! dsig = (drho + drhojet)/(kk - 4) + ! sigref(kk) = .5_r8*(rhob + rhoc) + .25_r8*(drho + drhojet) - rho0 + ! sigref(kk - 1) = rhoc + .5_r8*(drho + drhojet - dsig) - rho0 + ! do k = kk - 2, 1, -1 + ! sigref(k) = sigref(k + 1) - dsig + ! enddo + drhojet = rhoc*f*u0*l0/(g*h1) + dsig = (drho + drhojet)/(kk - 5) + sigref(kk - 2) = rhoc + .5_r8*(drho + drhojet - dsig) - rho0 + do k = kk - 3, 1, -1 + sigref(k) = sigref(k + 1) - dsig enddo - enddo - !$omp end parallel do - - s0 = rhob - rho0 - !$omp parallel do private(k, l, i, x, s1) - do j = 1, jj - do k = 1, kk + sigref(kk ) = rhob - rho0 + sigref(kk - 1) = (2._r8*sigref(kk - 2) + sigref(kk))/3._r8 + sigref(kk ) = (sigref(kk - 2) + 2._r8*sigref(kk))/3._r8 + + !$omp parallel do private(k, l, i) + do j = 1, jj + do k = 1, kk + do l = 1, isp(j) + do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) + sigmar(i, j, k) = sigref(k) + saln(i, j, k) = saln0 + z(i, j, k) = real(k - 1, r8)*h0/real(kk, r8) + enddo + enddo + enddo do l = 1, isp(j) do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) - x = x_nudge(real(i, r8), real(j, r8)) - s1 = rhoc*(1._r8 + f*u0*x_psi(x)/(g*h1)) - rho0 & - + .5_r8*drho*(z(i, j, k + 1) + z(i, j, k) - h1)/h1 - sigma(i, j, k) = & - ( s1*max(0._r8, min(z(i, j, k + 1), h1) - z(i, j, k)) & - + s0*max(0._r8, z(i, j, k + 1) - max(z(i, j, k), h1))) & - /(z(i, j, k + 1) - z(i, j, k)) - temp(i, j, k) = tofsig(sigma(i, j, k), saln(i, j, k)) + z(i, j, kk + 1) = h0 enddo enddo enddo - enddo - !$omp end parallel do - - case default - - if (mnproc.eq.1) then - write (lp,*) 'ictsz_fuk95: unsupported vertical coordinate!' - endif - call xcstop('(ictsz_fuk95)') - stop '(ictsz_fuk95)' + !$omp end parallel do + + s0 = rhob - rho0 + !$omp parallel do private(k, l, i, x, s1) + do j = 1, jj + do k = 1, kk + do l = 1, isp(j) + do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) + x = x_nudge(real(i, r8), real(j, r8)) + s1 = rhoc*(1._r8 + f*u0*x_psi(x)/(g*h1)) - rho0 & + + .5_r8*drho*(z(i, j, k + 1) + z(i, j, k) - h1)/h1 + sigma(i, j, k) = & + ( s1*max(0._r8, min(z(i, j, k + 1), h1) - z(i, j, k)) & + + s0*max(0._r8, z(i, j, k + 1) - max(z(i, j, k), h1))) & + /(z(i, j, k + 1) - z(i, j, k)) + temp(i, j, k) = tofsig(sigma(i, j, k), saln(i, j, k)) + enddo + enddo + enddo + enddo + !$omp end parallel do end select diff --git a/phy/meson.build b/phy/meson.build index 85b1d8e8..97703a3f 100644 --- a/phy/meson.build +++ b/phy/meson.build @@ -1,6 +1,9 @@ sources += files( 'crc.c', 'mod_advect.F90', +'mod_ale_forcing.F90', +'mod_ale_regrid_remap.F90', +'mod_ale_vdiff.F90', 'mod_barotp.F90', 'mod_bigrid.F90', 'mod_blom_init.F90', @@ -11,7 +14,6 @@ sources += files( 'mod_chkvar.F90', 'mod_cmnfld.F90', 'mod_cmnfld_routines.F90', -'mod_cntiso_hybrid_forcing.F90', 'mod_config.F90', 'mod_constants.F90', 'mod_convec.F90', @@ -62,7 +64,6 @@ sources += files( 'mod_types.F90', 'mod_utility.F90', 'mod_vcoord.F90', -'mod_vdiff.F90', 'mod_wdiflx.F90', 'mod_wtime.F90', 'mod_xc.F90') diff --git a/phy/mod_advect.F90 b/phy/mod_advect.F90 index d4f933a4..e2fcdc55 100644 --- a/phy/mod_advect.F90 +++ b/phy/mod_advect.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2007-2020 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2007-2024 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -147,7 +147,7 @@ subroutine advect(m,n,mm,nn,k1m,k1n) vtflx(1-nbdy,1-nbdy,km), & usflx(1-nbdy,1-nbdy,km), & vsflx(1-nbdy,1-nbdy,km), & - kn,trc) + kn) end do !$omp end parallel do @@ -198,7 +198,7 @@ subroutine advect(m,n,mm,nn,k1m,k1n) vtflx(1-nbdy,1-nbdy,km), & usflx(1-nbdy,1-nbdy,km), & vsflx(1-nbdy,1-nbdy,km), & - kn,trc) + kn) end do !$omp end parallel do else diff --git a/phy/mod_cntiso_hybrid_forcing.F90 b/phy/mod_ale_forcing.F90 similarity index 88% rename from phy/mod_cntiso_hybrid_forcing.F90 rename to phy/mod_ale_forcing.F90 index 63cc09c4..5b5720d2 100644 --- a/phy/mod_cntiso_hybrid_forcing.F90 +++ b/phy/mod_ale_forcing.F90 @@ -17,7 +17,11 @@ ! along with BLOM. If not, see . ! ------------------------------------------------------------------------------ -module mod_cntiso_hybrid_forcing +module mod_ale_forcing +! ------------------------------------------------------------------------------ +! This module contains procedures for computing penetration factors and buoyancy +! flux at model layer interfaces when the ALE method is used. +! ------------------------------------------------------------------------------ use mod_types, only: r8 use mod_constants, only: g, spcifh, alpha0, onem, onecm, onemu, L_mks2cgs @@ -33,15 +37,15 @@ module mod_cntiso_hybrid_forcing implicit none private - public :: cntiso_hybrid_forcing + public :: ale_forcing contains - subroutine cntiso_hybrid_forcing(m, n, mm, nn, k1m, k1n) - ! ------------------------------------------------------------------------------ - ! Compute penetration factors for shortwave and brine flux and compute interface - ! buoyancy flux. - ! ------------------------------------------------------------------------------ + subroutine ale_forcing(m, n, mm, nn, k1m, k1n) + ! ---------------------------------------------------------------------------- + ! Compute penetration factors for shortwave and brine flux and compute + ! interface buoyancy flux. + ! ---------------------------------------------------------------------------- ! Arguments integer, intent(in) :: m, n, mm, nn, k1m, k1n @@ -61,9 +65,9 @@ subroutine cntiso_hybrid_forcing(m, n, mm, nn, k1m, k1n) cpi = 1._r8/spcifh ! Multiplicative inverse of specific heat capacity. gaa = g*alpha0*alpha0 - ! --------------------------------------------------------------------------- + ! -------------------------------------------------------------------------- ! Compute shortwave flux penetration factors. - ! --------------------------------------------------------------------------- + ! -------------------------------------------------------------------------- ! Maximum pressure of shortwave absorption. pmax = swamxd*onem @@ -89,8 +93,9 @@ subroutine cntiso_hybrid_forcing(m, n, mm, nn, k1m, k1n) if (p(i,j,k+1) > pmax) exit enddo - ! Modify penetration factors so that fluxes destined to penetrate below - ! the lowest model layer are evenly absorbed in the water column. + ! Modify penetration factors so that fluxes destined to penetrate + ! below the lowest model layer are evenly absorbed in the water + ! column. pmaxi = 1._r8/min(pmax, p(i,j,kmax+1)) nlbot = t_sw_nonloc(i,j,kmax+1) do k = kmax+1, kk+1 @@ -110,9 +115,9 @@ subroutine cntiso_hybrid_forcing(m, n, mm, nn, k1m, k1n) enddo !$omp end parallel do - ! --------------------------------------------------------------------------- + ! -------------------------------------------------------------------------- ! Compute brine flux penetration factors. - ! --------------------------------------------------------------------------- + ! -------------------------------------------------------------------------- !$omp parallel do private(l, i, lei, pmax, kmax, k, kn, q, q3, pmaxi, nlbot) do j = 1, jj @@ -139,8 +144,9 @@ subroutine cntiso_hybrid_forcing(m, n, mm, nn, k1m, k1n) if (p(i,j,k+1) > pmax) exit enddo - ! Modify penetration factors so that fluxes destined to penetrate below - ! the lowest model layer are evenly absorbed in the water column. + ! Modify penetration factors so that fluxes destined to penetrate + ! below the lowest model layer are evenly absorbed in the water + ! column. pmaxi = 1._r8/min(pmax, p(i,j,kmax+1)) nlbot = s_br_nonloc(i,j,kmax+1) do k = kmax+1, kk+1 @@ -160,9 +166,9 @@ subroutine cntiso_hybrid_forcing(m, n, mm, nn, k1m, k1n) enddo !$omp end parallel do - ! --------------------------------------------------------------------------- + ! -------------------------------------------------------------------------- ! Compute buoyancy flux. - ! --------------------------------------------------------------------------- + ! -------------------------------------------------------------------------- !$omp parallel do private(l, i, dsgdt, dsgds, hf, hfsw, hfns, sf, sfbr, sfnb, k) do j = 1, jj @@ -199,13 +205,13 @@ subroutine cntiso_hybrid_forcing(m, n, mm, nn, k1m, k1n) if (csdiag) then if (mnproc == 1) then - write (lp,*) 'cntiso_hybrid_forcing:' + write (lp,*) 'ale_forcing:' endif call chksummsk(t_sw_nonloc, ip, kk+1, 't_sw_nonloc') call chksummsk(s_br_nonloc, ip, kk+1, 's_br_nonloc') call chksummsk(buoyfl, ip, kk+1, 'buoyfl') endif - end subroutine cntiso_hybrid_forcing + end subroutine ale_forcing -end module mod_cntiso_hybrid_forcing +end module mod_ale_forcing diff --git a/phy/mod_ale_regrid_remap.F90 b/phy/mod_ale_regrid_remap.F90 new file mode 100644 index 00000000..4c8e93d1 --- /dev/null +++ b/phy/mod_ale_regrid_remap.F90 @@ -0,0 +1,1622 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2021-2024 Mats Bentsen, Mehmet Ilicak +! +! This file is part of BLOM. +! +! BLOM is free software: you can redistribute it and/or modify it under the +! terms of the GNU Lesser General Public License as published by the Free +! Software Foundation, either version 3 of the License, or (at your option) +! any later version. +! +! BLOM is distributed in the hope that it will be useful, but WITHOUT ANY +! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +! FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for +! more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with BLOM. If not, see . +! ------------------------------------------------------------------------------ + +module mod_ale_regrid_remap +! ------------------------------------------------------------------------------ +! This module contains parameter, variables and procedures related to the +! regridding and remapping needed by the ALE method. +! ------------------------------------------------------------------------------ + + use mod_types, only: r8 + use mod_config, only: inst_suffix + use mod_constants, only: g, epsilp, onem + use mod_time, only: delt1 + use mod_xc + use mod_grid, only: scuy, scvx, scp2, scuxi, scvyi, scp2i + use mod_vcoord, only: vcoord_tag, vcoord_isopyc_bulkml, & + vcoord_cntiso_hybrid, vcoord_plevel, & + sigmar, plevel + use mod_eos, only: sig, dsigdt, dsigds + use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma, p, pu, pv + use mod_hor3map, only: recon_grd_struct, recon_src_struct, remap_struct, & + hor3map_plm, hor3map_ppm, hor3map_pqm, & + hor3map_monotonic, hor3map_non_oscillatory, & + hor3map_non_oscillatory_posdef, & + initialize_rcgs, initialize_rcss, initialize_rms, & + prepare_reconstruction, reconstruct, & + extract_polycoeff, regrid, & + prepare_remapping, remap, & + hor3map_noerr, hor3map_errstr + use mod_diffusion, only: ltedtp_opt, ltedtp_neutral, difiso, difmxp + use mod_ndiff, only: ndiff_prep_jslice, ndiff_uflx_jslice, & + ndiff_vflx_jslice, ndiff_update_trc_jslice + use mod_checksum, only: csdiag, chksummsk + use mod_tracers, only: ntr, trc + + implicit none + private + + ! Options with default values, modifiable by namelist. + character(len = 80) :: & + reconstruction_method = 'ppm', & + density_limiting = 'monotonic', & + tracer_limiting = 'non_oscillatory', & + velocity_limiting = 'non_oscillatory', & + regrid_method = 'nudge' + logical :: & + density_pc_upper_bndr = .false., & + density_pc_lower_bndr = .false., & + tracer_pc_upper_bndr = .true., & + tracer_pc_lower_bndr = .false., & + velocity_pc_upper_bndr = .true., & + velocity_pc_lower_bndr = .false. + real(r8) :: & + dpmin_interior = .1_r8, & + regrid_nudge_ts = 86400._r8, & + stab_fac_limit = .75_r8, & + smooth_diff_max = 50000._r8 + integer :: & + upper_bndr_ord = 6, & + lower_bndr_ord = 4, & + dktzu = 4, & + dktzl = 2 + + ! Options derived from string options. + integer :: & + reconstruction_method_tag, & + density_limiting_tag, & + tracer_limiting_tag, & + velocity_limiting_tag, & + regrid_method_tag + + real(r8), parameter :: & + bfsq_min = 1.e-7_r8, & ! Minimum buoyancy frequency squared in + ! monotonized potential density to be used + ! in regridding [s-2]. + regrid_mval = - 1.e33_r8, & ! Missing value for regridding. + x_eps = 1.e-14_r8 ! Small non-dimensional value used in the + ! construction of Bezier curves. + integer, parameter :: & + regrid_method_direct = 1, & ! Regrid method (vcoord_tag == + ! vcoord_cntiso_hybrid): On the basis of + ! reconstructed potential density, regrid + ! interface pressures so interface + ! potential densities match target values. + regrid_method_nudge = 2 ! Regrid method (vcoord_tag == + ! vcoord_cntiso_hybrid): Nudge interface + ! pressures to reduce the deviation from + ! the interface reference potential + ! density. + + integer :: ntr_loc + + type(recon_grd_struct) :: rcgs + type(recon_src_struct) :: d_rcss, v_rcss + type(recon_src_struct), allocatable, dimension(:) :: trc_rcss + type(remap_struct) :: rms + + public :: regrid_method_tag, regrid_method_direct, & + readnml_ale_regrid_remap, init_ale_regrid_remap, & + ale_regrid_remap + +contains + + ! --------------------------------------------------------------------------- + ! Private procedures. + ! --------------------------------------------------------------------------- + + pure function peval0(pc) result(f) + + real(r8), dimension(:), intent(in) :: pc + + real(r8) :: f + + f = pc(1) + + end function peval0 + + pure function peval1(pc) result(f) + + real(r8), dimension(:), intent(in) :: pc + + real(r8) :: f + + f = pc(1) + pc(2) + pc(3) + pc(4) + pc(5) + + end function peval1 + + pure function dpeval0(pc) result(f) + + real(r8), dimension(:), intent(in) :: pc + + real(r8) :: f + + f = pc(2) + + end function dpeval0 + + pure function dpeval1(pc) result(f) + + real(r8), dimension(:), intent(in) :: pc + + real(r8) :: f + + real(r8), parameter :: & + c2 = 2._r8, & + c3 = 3._r8, & + c4 = 4._r8 + + f = pc(2) + c2*pc(3) + c3*pc(4) + c4*pc(5) + + end function dpeval1 + + subroutine reconstruct_trc_jslice(p_src, ksmx, tpc_src, t_srcdi, & + ilb, iub, j, js, nn) + ! --------------------------------------------------------------------------- + ! Vertically reconstruct temperature, salinity and additional tracers along a + ! j-slice of the model data. + ! --------------------------------------------------------------------------- + + real(r8), dimension(:,1-nbdy:), intent(out) :: p_src + integer, dimension(1-nbdy:), intent(out) :: ksmx + real(r8), intent(out), dimension(:,:,:,1-nbdy:) :: tpc_src, t_srcdi + integer, intent(in) :: ilb, iub, j, js, nn + + real(r8), dimension(kdm,ntr_loc) :: trc_1d + integer :: l, i, k, kn, nt, errstat + + + do l = 1, isp(j) + do i = max(ilb, ifp(j,l)), min(iub, ilp(j,l)) + + ! Compute source layer interface pressure and copy variables into 1D + ! arrays. + p_src(1,i) = p(i,j,1) + do k = 1, kk + kn = k + nn + p_src(k+1,i) = p_src(k,i) + dp(i,j,k+nn) + trc_1d(k,1) = temp(i,j,kn) + trc_1d(k,2) = saln(i,j,kn) + do nt = 1, ntr + trc_1d(k,nt+2) = trc(i,j,kn,nt) + enddo + enddo + + ! Find index of deepest source layer with non-zero thickness. + ksmx(i) = kk + do k = kk, 1, -1 + if (p_src(k,i) == p_src(kk+1,i)) ksmx(i) = k - 1 + enddo + + errstat = prepare_reconstruction(rcgs, p_src(:,i), i, js) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(prep_recon_jslice)') + stop '(prep_recon_jslice)' + endif + + ! Reconstruct tracers. + do nt = 1, ntr_loc + errstat = reconstruct(rcgs, trc_rcss(nt), trc_1d(:,nt), i, js) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(recon_trc_jslice)') + stop '(recon_trc_jslice)' + endif + enddo + + ! Extract polynomial coefficients of the reconstructions and store + ! tracer variables in dual interface arrays with with values + ! corresponding to upper and lower interface of each layer. + do nt = 1, ntr_loc + errstat = extract_polycoeff(trc_rcss(nt), tpc_src(:,:,nt,i), & + i, js) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(recon_trc_jslice)') + stop '(recon_trc_jslice)' + endif + do k = 1, ksmx(i) + t_srcdi(1,k,nt,i) = peval0(tpc_src(:,k,nt,i)) + t_srcdi(2,k,nt,i) = peval1(tpc_src(:,k,nt,i)) + enddo + enddo + + enddo + enddo + + end subroutine reconstruct_trc_jslice + + subroutine regrid_plevel_jslice(p_src, p_dst, ilb, iub, j) + ! --------------------------------------------------------------------------- + ! For vcoord == 'plevel', regrid interface pressures to specified pressure + ! levels. + ! --------------------------------------------------------------------------- + + real(r8), dimension(:,1-nbdy:), intent(in) :: p_src + real(r8), dimension(:,1-nbdy:), intent(out) :: p_dst + integer, intent(in) :: ilb, iub, j + + integer :: l, i, k + + do l = 1, isp(j) + do i = max(ilb, ifp(j,l)), min(iub, ilp(j,l)) + do k = 1, kk + p_dst(k,i) = min(plevel(k) + p_src(1,i), p_src(kk+1,i)) + enddo + p_dst(kk+1,i) = p_src(kk+1,i) + enddo + enddo + + end subroutine regrid_plevel_jslice + + subroutine regrid_cntiso_hybrid_direct_jslice(p_src, p_dst, & + ilb, iub, j, js, nn) + ! --------------------------------------------------------------------------- + ! For vcoord == 'cntiso_hybrid' and regrid_method = 'direct', regrid + ! interface pressures so interface potential densities match target values + ! except where minimum layer thickness towards the surface must be + ! maintained. + ! --------------------------------------------------------------------------- + + real(r8), dimension(:,1-nbdy:), intent(in) :: p_src + real(r8), dimension(:,1-nbdy:), intent(out) :: p_dst + integer, intent(in) :: ilb, iub, j, js, nn + + real(r8), dimension(kdm+1) :: sig_trg + real(r8), dimension(kdm) :: sig_src + real(r8) :: beta, sdpsum, smean, dpmin_int, pku, pku_test, pmin, dpt, & + pt, ptu1, ptl1, ptu2, ptl2, w1, x + integer :: l, i, k, kn, ks, ke, kl, ku, errstat + logical :: thin_layers, layer_added + + ! Minimum potential density difference with respect to pressure for + ! potential density to be used in regridding. + beta = bfsq_min/(g*g) + + do l = 1, isp(j) + do i = max(ilb, ifp(j,l)), min(iub, ilp(j,l)) + + ! Copy source and target potential densities into 1D arrays. + do k = 1, kk + kn = k + nn + sig_src(k) = sigma(i,j,kn) + sig_trg(k) = sigmar(i,j,k) + enddo + sig_trg(kk+1) = sig_trg(kk) + + ! Make sure potential density to be used in regridding is + ! monotonically increasing with depth. + kl = kk + ku = kl - 1 + do while (ku > 0) + thin_layers = p_src(kl+1,i) - p_src(ku,i) < epsilp + if (thin_layers .or. & + sig_src(kl) - sig_src(ku) & + < .5_r8*beta*(p_src(kl+1,i) - p_src(ku,i))) then + sdpsum = sig_src(ku)*(p_src(ku+1,i) - p_src(ku,i)) & + + sig_src(kl)*(p_src(kl+1,i) - p_src(kl,i)) + if (.not. thin_layers) & + smean = sdpsum/(p_src(kl+1,i) - p_src(ku,i)) + do + layer_added = .false. + if (ku > 1) then + if (thin_layers) then + ku = ku - 1 + sdpsum = sdpsum & + + sig_src(ku)*(p_src(ku+1,i) - p_src(ku,i)) + thin_layers = p_src(kl+1,i) - p_src(ku,i) < epsilp + if (.not. thin_layers) & + smean = sdpsum/(p_src(kl+1,i) - p_src(ku,i)) + layer_added = .true. + else + if (smean - sig_src(ku-1) & + < .5_r8*beta*(p_src(kl+1,i) - p_src(ku-1,i))) then + ku = ku - 1 + sdpsum = sdpsum & + + sig_src(ku)*(p_src(ku+1,i) - p_src(ku,i)) + smean = sdpsum/(p_src(kl+1,i) - p_src(ku,i)) + layer_added = .true. + endif + endif + endif + if (kl < kk) then + if (thin_layers) then + kl = kl + 1 + sdpsum = sdpsum & + + sig_src(kl)*(p_src(kl+1,i) - p_src(kl,i)) + thin_layers = p_src(kl+1,i) - p_src(ku,i) < epsilp + if (.not. thin_layers) & + smean = sdpsum/(p_src(kl+1,i) - p_src(ku,i)) + layer_added = .true. + else + if (sig_src(kl+1) - smean & + < .5_r8*beta*(p_src(kl+2,i) - p_src(ku,i))) then + kl = kl + 1 + sdpsum = sdpsum & + + sig_src(kl)*(p_src(kl+1,i) - p_src(kl,i)) + smean = sdpsum/(p_src(kl+1,i) - p_src(ku,i)) + layer_added = .true. + endif + endif + endif + if (.not. layer_added) exit + enddo + do k = ku, kl + sig_src(k) = smean & + + .5_r8*beta*( p_src(k ,i) + p_src(k +1,i) & + - p_src(ku,i) - p_src(kl+1,i)) + enddo + endif + kl = ku + ku = kl - 1 + enddo + + ! Monotonically reconstruct potential density. + errstat = reconstruct(rcgs, d_rcss, sig_src, i, js) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(cntiso_regrid_direct_jslice)') + stop '(cntiso_regrid_direct_jslice)' + endif + + ! On the basis of the reconstructed potential density, regrid + ! interface pressures so interface potential densities match target + ! values. + errstat = regrid(d_rcss, sig_trg, p_dst(:,i), regrid_mval, i, js) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(cntiso_regrid_direct_jslice)') + stop '(cntiso_regrid_direct_jslice)' + endif + + ! Modify regridded interface pressures to ensure the water column is + ! properly bounded. + k = 1 + do + ks = k + if (p_dst(k,i) /= regrid_mval) exit + p_dst(k,i) = p_src(1,i) + if (k > kk) exit + k = k + 1 + enddo + k = kk + 1 + do + ke = k + if (p_dst(k,i) /= regrid_mval) exit + p_dst(k,i) = p_src(kk+1,i) + if (k == 1) exit + k = k - 1 + enddo + p_dst(1,i) = p_src(1,i) + p_dst(kk+1,i) = p_src(kk+1,i) + + ! If no regrid interface is found in the water column, try to place + ! all water in the layer with potential density bounds that include + ! the column mean potential density. + if (ks == ke) then + sdpsum = 0._r8 + do k = 1, kk + sdpsum = sdpsum + sig_src(k)*(p_src(k+1,i) - p_src(k,i)) + enddo + smean = sdpsum/(p_src(kk+1,i) - p_src(1,i)) + ks = 2 + do while (ks <= kk) + if (smean < sig_trg(ks)) exit + ks = ks + 1 + enddo + do k = ks, kk + p_dst(k,i) = p_src(kk+1,i) + enddo + ke = ks - 1 + endif + + ! Modify interface pressures so that layer thicknesses are + ! above a specified threshold. + dpmin_int = min(plevel(2) - plevel(1), dpmin_interior) + ks = max(2, ks) + ke = min(kk, ke) + k = ks + do while (k <= ke) + if (p_dst(k+1,i) - p_dst(k,i) < dpmin_int) then + if (k == ke) then + p_dst(k,i) = p_dst(ke+1,i) + else + ku = k + kl = k + 1 + pku = .5_r8*(p_dst(kl,i) + p_dst(ku,i) - dpmin_int) + do + layer_added = .false. + kl = kl + 1 + pku_test = ((pku - dpmin_int)*(kl - ku) + p_dst(kl,i)) & + /(kl - ku + 1) + if (pku_test + (kl - ku)*dpmin_int > p_dst(kl,i)) then + if (kl == ke + 1) exit + pku = pku_test + layer_added = .true. + else + kl = kl - 1 + endif + ku = ku - 1 + pku_test = ((pku - dpmin_int)*(kl - ku) + p_dst(ku,i)) & + /(kl - ku + 1) + if (pku_test < p_dst(ku,i)) then + if (ku == 1) exit + pku = pku_test + layer_added = .true. + else + ku = ku + 1 + endif + if (.not. layer_added) exit + enddo + if (ku == 1) then + do k = 2, kl + p_dst(k,i) = min(p_dst(ke+1,i), & + p_dst(k -1,i) + dpmin_int) + enddo + do k = kl+1, ke + p_dst(k,i) = & + min(p_dst(ke+1,i), & + max(p_dst(k,i), p_dst(1,i) + dpmin_int*(k - 1))) + enddo + elseif (kl == ke + 1) then + do k = ku, kl + p_dst(k,i) = p_dst(ke+1,i) + enddo + else + p_dst(ku,i) = pku + do k = ku+1, kl + p_dst(k,i) = p_dst(k-1,i) + dpmin_int + enddo + endif + k = kl + endif + endif + k = k + 1 + enddo + + ! Modify regridded interface pressures to ensure that a minimum + ! layer thickness towards the surface is maintained. A smooth + ! transition between modified and unmodified interfaces is sought. + dpt = plevel(2) - plevel(1) + do k = 2, ke + pmin = plevel(k) + p_src(1,i) + dpt = max(p_dst(k+1,i) - p_dst(k,i), dpt, & + plevel(min(k,kk-1)+1) - plevel(min(k,kk-1))) + pt = max(p_dst(k,i), pmin) + ptu1 = pmin - dpt + ptl1 = pmin + dpt + ptu2 = pmin + ptl2 = pmin + 2._r8*dpt + w1 = min(1._r8,(p_dst(k,i) - p_src(1,i))/(pmin - p_src(1,i))) + if (p_dst(k,i) > ptu1 .and. p_dst(k,i) < ptl1) then + x = .5_r8*(p_dst(k,i) - ptu1)/dpt + pt = pmin + dpt*x*x + endif + if (p_dst(k+1,i) > ptu2 .and. p_dst(k+1,i) < ptl2) then + x = .5_r8*(p_dst(k+1,i) - ptu2)/dpt + pt = w1*pt + (1._r8 - w1)*(pmin + dpt*x*x) + endif + p_dst(k,i) = min(p_dst(ke+1,i), & + max(p_dst(k-1,i) + dpmin_int, pt)) + enddo + + enddo + enddo + + end subroutine regrid_cntiso_hybrid_direct_jslice + + subroutine regrid_cntiso_hybrid_nudge_jslice( & + p_src, ksmx, tpc_src, t_srcdi, p_dst, stab_fac, ilb, iub, j) + ! --------------------------------------------------------------------------- + ! For vcoord == 'cntiso_hybrid' and regrid_method = 'nudge', nudge the + ! interface pressures to reduce the deviation from interface target potential + ! densities, while maintaining minimum layer thicknesses towards the surface. + ! --------------------------------------------------------------------------- + + real(r8), dimension(:,1-nbdy:), intent(in) :: p_src + integer, dimension(1-nbdy:), intent(in) :: ksmx + real(r8), dimension(:,:,:,1-nbdy:), intent(in) :: tpc_src, t_srcdi + real(r8), dimension(:,1-nbdy:), intent(out) :: p_dst, stab_fac + integer, intent(in) :: ilb, iub, j + + integer, parameter :: & + it = 1, & + is = 2 + + real(r8), dimension(2,kdm) :: sig_srcdi + integer, dimension(1-nbdy:idm+nbdy) :: kdmx + + real(r8), dimension(kdm+1) :: sig_trg, sig_pmin + real(r8), dimension(kdm) :: dsig_trg, pmin + real(r8) :: sig_max, ckt, sig_up, sig_lo, dk, dki, & + dsigdx_up, dsigdx_lo, x, xi, si, t, nudge_fac, & + dsig, dsigdx, dp_up, dp_lo, sig_intrp + integer :: l, i, k, kt, kl, ktzmin, ktzmax + + do l = 1, isp(j) + do i = max(ilb, ifp(j,l)), min(iub, ilp(j,l)) + + ! Store density in a dual interface array with with values + ! corresponding to upper and lower interface of each layer. Also + ! find the maximum lower interface potential density of the + ! reconstructed column. + sig_max = 0._r8 + do k = 1, ksmx(i) + sig_srcdi(1,k) = sig(t_srcdi(1,k,it,i), t_srcdi(1,k,is,i)) + sig_srcdi(2,k) = sig(t_srcdi(2,k,it,i), t_srcdi(2,k,is,i)) + sig_max = max(sig_max, sig_srcdi(2,k)) + enddo + + ! Copy variables into 1D arrays. + do k = 1, kk + sig_trg(k) = sigmar(i,j,k) + enddo + sig_trg(kk+1) = sig_trg(kk) + do k = 1, kk-1 + dsig_trg(k) = sig_trg(k+1) - sigmar(i,j,k) + enddo + dsig_trg(kk) = dsig_trg(kk-1) + + ! Find the index of the first layer which lower interface reference + ! potential density is denser than the maximum lower interface + ! potential density of the reconstructed column. + do k = kk, 1, -1 + if (sig_trg(k) < sig_max) exit + enddo + kdmx(i) = max(1, k) + + ! Set minimum interface pressure. + do k = 1, kk + pmin(k) = min(plevel(k) + p_src(1,i), p_src(kk+1,i)) + enddo + p_dst(1,i) = pmin(1) + + stab_fac(1,i) = 0._r8 + nudge_fac = delt1/regrid_nudge_ts + + ! Find the index of the first interface with potential density at + ! minimum interface pressure smaller than the reference potential + ! density of this transition interface. A layer range above and + ! below the transition interface may be specified, making a + ! transition zone where interface reference potential densities are + ! adjusted to achieve a more gradual change from pressure level to + ! isopycnic interfaces. + sig_pmin(1) = sig_srcdi(1,1) + kt = 2 + kl = 1 + do while (kt <= kdmx(i)) + do while (p_src(kl+1,i) < pmin(kt)) + kl = kl + 1 + enddo + sig_pmin(kt) = ( (p_src(kl+1,i) - pmin(kt))*sig_srcdi(1,kl) & + + (pmin(kt) - p_src(kl,i))*sig_srcdi(2,kl)) & + /(p_src(kl+1,i) - p_src(kl,i)) + if (sig_trg(kt) > sig_pmin(kt)) then + ktzmin = max(3, kt - dktzu) + ktzmax = min(kk - 1, kt + dktzl) + if (ktzmin < kt .and. ktzmax - ktzmin > 1) then + ! For a smooth transition in layer reference potential + ! densities, try to construct a quadratic Bezier curve + ! specified by the density and density gradients at the + ! boundary of the transition zone. If construction of a + ! Bezier curve fails, use a linear change of reference + ! potential densities in the transition zone. + ckt = (sig_trg(kt) - sig_pmin(kt)) & + /( sig_trg(kt) - sig_trg(kt-1) & + - sig_pmin (kt) + sig_pmin (kt-1)) + sig_up = sig_pmin (ktzmin-1)*ckt & + + sig_pmin (ktzmin )*(1._r8 - ckt) + sig_lo = sig_trg(ktzmax-1)*ckt & + + sig_trg(ktzmax )*(1._r8 - ckt) + dk = real(ktzmax - ktzmin, r8) + dki = 1._r8/dk + dsigdx_up = .5*( ( sig_pmin (ktzmin ) & + - sig_pmin (ktzmin-2))*ckt & + + ( sig_pmin (ktzmin+1) & + - sig_pmin (ktzmin-1))*(1. - ckt))*dk + dsigdx_lo = .5*( ( sig_trg(ktzmax ) & + - sig_trg(ktzmax-2))*ckt & + + ( sig_trg(ktzmax+1) & + - sig_trg(ktzmax-1))*(1. - ckt))*dk + dsigdx_up = max(0._r8, dsigdx_up) + if (dsigdx_lo <= dsigdx_up .or. & + sig_up - sig_lo <= - dsigdx_lo .or. & + sig_up - sig_lo >= - dsigdx_up) then + do k = ktzmin, ktzmax - 1 + x = (k - ktzmin + ckt)*dki + sig_trg(k) = sig_up*(1._r8 - x) + sig_lo*x + enddo + else + xi = (sig_up - sig_lo + dsigdx_lo) & + /(dsigdx_lo - dsigdx_up) + si = ( dsigdx_lo*(sig_up + dsigdx_up) & + - dsigdx_up*sig_lo)/(dsigdx_lo - dsigdx_up) + if (abs(xi - .5_r8) < x_eps) then + do k = ktzmin, ktzmax-1 + t = (k - ktzmin + ckt)*dki + sig_trg(k) = & + (1._r8 - t)*((1._r8 - t)*sig_up + 2._r8*t*si) & + + t*t*sig_lo + enddo + else + do k = ktzmin, ktzmax-1 + x = (k - ktzmin + ckt)*dki + t = (sqrt(xi*(xi - 2_r8*x) + x) - xi) & + /(1._r8 - 2_r8*xi) + sig_trg(k) = & + (1._r8 - t)*((1._r8 - t)*sig_up + 2._r8*t*si) & + + t*t*sig_lo + enddo + endif + endif + kt = ktzmin + endif + exit + endif + p_dst(kt,i) = p_src(kt,i) + nudge_fac*(pmin(kt) - p_src(kt,i)) + p_dst(kt,i) = min(max(p_dst(kt,i), pmin(kt), & + p_dst(kt-1,i) + dpmin_interior), & + p_src(kk+1,i)) + stab_fac(kt,i) = 0._r8 + kt = kt + 1 + enddo + + ! Starting at the transition interface, nudge the interface + ! pressures to reduce the deviation from the interface reference + ! potential density. + + do k = kt, kk+1 + p_dst(k,i) = p_src(kk+1,i) + stab_fac(k,i) = 1._r8 + enddo + + do k = kt, min(ksmx(i), kdmx(i)) + if (sig_trg(k) < sig_srcdi(2,k-1) .and. & + sig_trg(k) < sig_srcdi(1,k )) then + dsig = sig_trg(k) - sig_srcdi(2,k-1) + dsigdx = dsigdt(t_srcdi(2,k-1,it,i), t_srcdi(2,k-1,is,i)) & + *dpeval1(tpc_src(:,k-1,it,i)) & + + dsigds(t_srcdi(2,k-1,it,i), t_srcdi(2,k-1,is,i)) & + *dpeval1(tpc_src(:,k-1,is,i)) + stab_fac(k,i) = dsigdx/dsig_trg(k-1) + dsigdx = dsig_trg(k-1)*max(stab_fac(k,i), stab_fac_limit) + p_dst(k,i) = p_src(k,i) & + + max(- .5_r8, dsig*nudge_fac/dsigdx) & + *(p_src(k,i) - p_src(k-1,i)) + elseif (sig_trg(k) > sig_srcdi(2,k-1) .and. & + sig_trg(k) > sig_srcdi(1,k )) then + dsig = sig_trg(k) - sig_srcdi(1,k) + dsigdx = dsigdt(t_srcdi(1,k,it,i), t_srcdi(1,k,is,i)) & + *dpeval0(tpc_src(:,k,it,i)) & + + dsigds(t_srcdi(1,k,it,i), t_srcdi(1,k,is,i)) & + *dpeval0(tpc_src(:,k,is,i)) + stab_fac(k,i) = dsigdx/dsig_trg(k) + dsigdx = dsig_trg(k)*max(stab_fac(k,i), stab_fac_limit) + p_dst(k,i) = p_src(k,i) & + + min(.5_r8, dsig*nudge_fac/dsigdx) & + *(p_src(k+1,i) - p_src(k,i)) + else + dsigdx_up = dsigdt(t_srcdi(2,k-1,it,i), t_srcdi(2,k-1,is,i)) & + *dpeval1(tpc_src(:,k-1,it,i)) & + + dsigds(t_srcdi(2,k-1,it,i), t_srcdi(2,k-1,is,i)) & + *dpeval1(tpc_src(:,k-1,is,i)) + dsigdx_lo = dsigdt(t_srcdi(1,k,it,i), t_srcdi(1,k,is,i)) & + *dpeval0(tpc_src(:,k,it,i)) & + + dsigds(t_srcdi(1,k,it,i), t_srcdi(1,k,is,i)) & + *dpeval0(tpc_src(:,k,is,i)) + dp_up = max(p_src(k ,i) - p_src(k-1,i), epsilp) + dp_lo = max(p_src(k+1,i) - p_src(k ,i), epsilp) + sig_intrp = ( (sig_srcdi(1,k ) + .5_r8*dsigdx_lo)*dp_up & + + (sig_srcdi(2,k-1) - .5_r8*dsigdx_up)*dp_lo) & + /(dp_up + dp_lo) + sig_intrp = max(min(sig_srcdi(2,k-1),sig_srcdi(1,k)), & + min(max(sig_srcdi(2,k-1),sig_srcdi(1,k)), & + sig_intrp)) + dsig = sig_trg(k) - sig_intrp + if (dsig < 0._r8) then + dsigdx = dsigdx_up + 2._r8*(sig_intrp - sig_srcdi(2,k-1)) + stab_fac(k,i) = dsigdx/dsig_trg(k-1) + dsigdx = dsig_trg(k-1)*max(stab_fac(k,i), stab_fac_limit) + p_dst(k,i) = p_src(k,i) & + + max(- .5_r8, dsig*nudge_fac/dsigdx) & + *(p_src(k,i) - p_src(k-1,i)) + else + dsigdx = dsigdx_lo + 2._r8*(sig_srcdi(1,k ) - sig_intrp) + stab_fac(k,i) = dsigdx/dsig_trg(k) + dsigdx = dsig_trg(k)*max(stab_fac(k,i), stab_fac_limit) + p_dst(k,i) = p_src(k,i) & + + min(.5_r8, dsig*nudge_fac/dsigdx) & + *(p_src(k+1,i) - p_src(k,i)) + endif + endif + p_dst(k,i) = min(max(p_dst(k,i), pmin(k), & + p_dst(k-1,i) + dpmin_interior), & + p_src(kk+1,i)) + enddo + + do k = max(kt, min(ksmx(i), kdmx(i))) + 1, kdmx(i) + if (sig_trg(k) < sig_srcdi(2,ksmx(i))) then + dsig = sig_trg(k) - sig_srcdi(2,ksmx(i)) + dsigdx = dsigdt(t_srcdi(2,ksmx(i),it,i), & + t_srcdi(2,ksmx(i),is,i)) & + *dpeval1(tpc_src(:,ksmx(i),it,i)) & + + dsigds(t_srcdi(2,ksmx(i),it,i), & + t_srcdi(2,ksmx(i),is,i)) & + *dpeval1(tpc_src(:,ksmx(i),is,i)) + stab_fac(k,i) = dsigdx/dsig_trg(ksmx(i)-1) + dsigdx = dsig_trg(ksmx(i)-1) & + *max(stab_fac(k,i), stab_fac_limit) + p_dst(k,i) = p_src(kk+1,i) & + + max(- .5_r8, dsig*nudge_fac/dsigdx) & + *(p_src(kk+1,i) - p_src(ksmx(i),i)) + p_dst(k,i) = min(max(p_dst(k,i), pmin(k), & + p_dst(k-1,i) + dpmin_interior), & + p_src(kk+1,i)) + endif + enddo + + enddo + enddo + + end subroutine regrid_cntiso_hybrid_nudge_jslice + + subroutine regrid_jslice(p_src, ksmx, tpc_src, t_srcdi, p_dst, stab_fac, & + ilb, iub, j, js, nn) + ! --------------------------------------------------------------------------- + ! Carry out regridding layer interfaces. + ! --------------------------------------------------------------------------- + + real(r8), dimension(:,1-nbdy:), intent(in) :: p_src + integer, dimension(1-nbdy:), intent(in) :: ksmx + real(r8), dimension(:,:,:,1-nbdy:), intent(in) :: tpc_src, t_srcdi + real(r8), dimension(:,1-nbdy:), intent(out) :: p_dst, stab_fac + integer, intent(in) :: ilb, iub, j, js, nn + + if (vcoord_tag == vcoord_plevel) then + call regrid_plevel_jslice(p_src, p_dst, ilb, iub, j) + else + if (regrid_method_tag == regrid_method_direct) then + call regrid_cntiso_hybrid_direct_jslice(p_src, p_dst, & + ilb, iub, j, js, nn) + else + call regrid_cntiso_hybrid_nudge_jslice(p_src, ksmx, tpc_src, & + t_srcdi, p_dst, stab_fac, & + ilb, iub, j) + endif + endif + + end subroutine regrid_jslice + + subroutine regrid_smooth_jslice(p_dst_js, stab_fac_js, smtflxconv_js, & + ilb, iub, j, js2, js3) + ! --------------------------------------------------------------------------- + ! For vcoord == 'cntiso_hybrid' and regrid_method == 'nudge', apply lateral + ! smoothing of the regridded interfaces when a vertical stability factor is + ! below a specified threshold. + ! --------------------------------------------------------------------------- + + real(r8), dimension(:,1-nbdy:,:), intent(inout) :: & + p_dst_js, stab_fac_js, smtflxconv_js + integer, intent(in) :: ilb, iub, j, js2, js3 + + real(r8) :: cdiff, difmx, flxhi, flxlo, flx, q, sdiff + integer :: l, i, k + + smtflxconv_js(:,:,js3) = 0._r8 + + do l = 1, isu(j+1) + do i = max(ilb, ifu(j+1,l)), min(iub+1, ilu(j+1,l)) + cdiff = delt1*scuy(i,j+1)*scuxi(i,j+1) + difmx = .5_r8*(difmxp(i-1,j+1) + difmxp(i,j+1)) + do k = 2, kk + flxhi = .125_r8*min(( p_dst_js(k, i-1,js3) & + - p_dst_js(k-1,i-1,js3))*scp2(i-1,j+1), & + ( p_dst_js(k+1,i ,js3) & + - p_dst_js(k ,i ,js3))*scp2(i ,j+1)) + flxlo = - .125_r8*min(( p_dst_js(k ,i ,js3) & + - p_dst_js(k-1,i ,js3))*scp2(i ,j+1), & + ( p_dst_js(k+1,i-1,js3) & + - p_dst_js(k ,i-1,js3))*scp2(i-1,j+1)) + q = .5_r8*( max(0._r8, min(stab_fac_limit, & + stab_fac_js(k,i-1,js3))) & + + max(0._r8, min(stab_fac_limit, & + stab_fac_js(k,i ,js3)))) + sdiff = min((stab_fac_limit - q)*smooth_diff_max & + /stab_fac_limit, difmx) + flx = min(flxhi, max(flxlo, cdiff*sdiff*( p_dst_js(k,i-1,js3) & + - p_dst_js(k,i ,js3)))) + smtflxconv_js(k,i-1,js3) = smtflxconv_js(k,i-1,js3) + flx + smtflxconv_js(k,i ,js3) = smtflxconv_js(k,i ,js3) - flx + enddo + enddo + enddo + + do l = 1, isv(j+1) + do i = max(ilb, ifv(j+1,l)), min(iub, ilv(j+1,l)) + cdiff = delt1*scvx(i,j+1)*scvyi(i,j+1) + difmx = .5_r8*(difmxp(i,j) + difmxp(i,j+1)) + do k = 2, kk + flxhi = .125_r8*min(( p_dst_js(k, i,js2) & + - p_dst_js(k-1,i,js2))*scp2(i,j ), & + ( p_dst_js(k+1,i,js3) & + - p_dst_js(k ,i,js3))*scp2(i,j+1)) + flxlo = - .125_r8*min(( p_dst_js(k ,i,js3) & + - p_dst_js(k-1,i,js3))*scp2(i,j+1), & + ( p_dst_js(k+1,i,js2) & + - p_dst_js(k ,i,js2))*scp2(i,j )) + q = .5_r8*( max(0._r8, min(stab_fac_limit, & + stab_fac_js(k,i,js2))) & + + max(0._r8, min(stab_fac_limit, & + stab_fac_js(k,i,js3)))) + sdiff = min((stab_fac_limit - q)*smooth_diff_max & + /stab_fac_limit, difmx) + flx = min(flxhi, max(flxlo, cdiff*sdiff*( p_dst_js(k,i,js2) & + - p_dst_js(k,i,js3)))) + smtflxconv_js(k,i,js2) = smtflxconv_js(k,i,js2) + flx + smtflxconv_js(k,i,js3) = smtflxconv_js(k,i,js3) - flx + enddo + enddo + enddo + + do l = 1, isp(j) + do i = max(ilb, ifp(j,l)), min(iub, ilp(j,l)) + do k = 2, kk + p_dst_js(k,i,js2) = p_dst_js(k,i,js2) & + - smtflxconv_js(k,i,js2)*scp2i(i,j) + enddo + enddo + enddo + + end subroutine regrid_smooth_jslice + + subroutine remap_trc_jslice(p_dst, trc_rm, ilb, iub, j, js) + ! --------------------------------------------------------------------------- + ! Remap tracers from source to destination layer structure. + ! --------------------------------------------------------------------------- + + real(r8), dimension(:,1-nbdy:), intent(in) :: p_dst + real(r8), dimension(:,:,1-nbdy:), intent(out) :: trc_rm + integer, intent(in) :: ilb, iub, j, js + + integer :: l, i, nt, errstat + + do l = 1, isp(j) + do i = max(ilb, ifp(j,l)), min(iub, ilp(j,l)) + + ! Prepare remapping to destination layers. + errstat = prepare_remapping(rcgs, rms, p_dst(:,i), i, js) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(remap_trc_jslice)') + stop '(remap_trc_jslice)' + endif + + ! Remap tracers. + do nt = 1, ntr_loc + errstat = remap(trc_rcss(nt), rms, trc_rm(:,nt,i), i, js) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(remap_trc_jslice)') + stop '(remap_trc_jslice)' + endif + enddo + + enddo + enddo + + end subroutine remap_trc_jslice + + subroutine copy_jslice_to_3d(p_dst, trc_rm, ilb, iub, j, nn) + + real(r8), dimension(:,1-nbdy:), intent(in) :: p_dst + real(r8), dimension(:,:,1-nbdy:), intent(in) :: trc_rm + + integer, intent(in) :: ilb, iub, j, nn + + integer :: l, i, k, kn, nt + + do l = 1, isp(j) + do i = max(ilb, ifp(j,l)), min(iub, ilp(j,l)) + + do k = 1, kk + kn = k + nn + temp(i,j,kn) = trc_rm(k,1,i) + saln(i,j,kn) = trc_rm(k,2,i) + dp(i,j,kn) = p_dst(k+1,i) - p_dst(k,i) + sigma(i,j,kn) = sig(trc_rm(k,1,i), trc_rm(k,2,i)) + do nt = 1, ntr + trc(i,j,kn,nt) = trc_rm(k,nt+2,i) + enddo + enddo + + enddo + enddo + + end subroutine copy_jslice_to_3d + + ! --------------------------------------------------------------------------- + ! Public procedures. + ! --------------------------------------------------------------------------- + + subroutine readnml_ale_regrid_remap + ! --------------------------------------------------------------------------- + ! Read variables in the namelist group 'ale_regrid_remap' and resolve + ! options. + ! --------------------------------------------------------------------------- + + character(len = 80) :: nml_fname + integer :: nfu, ios + logical :: fexist + + namelist /ale_regrid_remap/ & + reconstruction_method, upper_bndr_ord, lower_bndr_ord, & + density_limiting, tracer_limiting, velocity_limiting, & + density_pc_upper_bndr, density_pc_lower_bndr, & + tracer_pc_upper_bndr, tracer_pc_lower_bndr, & + velocity_pc_upper_bndr, velocity_pc_lower_bndr, dpmin_interior, & + regrid_method, regrid_nudge_ts, stab_fac_limit, smooth_diff_max, & + dktzu, dktzl + + ! Return if ALE method is not required. + if (vcoord_tag == vcoord_isopyc_bulkml) return + + ! Read variables in the namelist group 'ale_regrid_remap'. + if (mnproc == 1) then + nml_fname = 'ocn_in'//trim(inst_suffix) + inquire(file = nml_fname, exist = fexist) + if (fexist) then + open (newunit = nfu, file = nml_fname, status = 'old', & + action = 'read') + else + nml_fname = 'limits'//trim(inst_suffix) + inquire(file = nml_fname, exist = fexist) + if (fexist) then + open (newunit = nfu, file = nml_fname, status = 'old', & + action = 'read') + else + write (lp,*) & + 'readnml_ale_regrid_remap: could not find namelist file!' + call xchalt('(readnml_ale_regrid_remap)') + stop '(readnml_ale_regrid_remap)' + endif + endif + read (unit = nfu, nml = ale_regrid_remap, iostat = ios) + close (unit = nfu) + endif + call xcbcst(ios) + if (ios /= 0) then + if (mnproc == 1) & + write (lp,*) & + 'readnml_ale_regrid_remap: No vertical coordinate variable group found in namelist. Using defaults.' + else + call xcbcst(reconstruction_method) + call xcbcst(upper_bndr_ord) + call xcbcst(lower_bndr_ord) + call xcbcst(density_limiting) + call xcbcst(tracer_limiting) + call xcbcst(velocity_limiting) + call xcbcst(density_pc_upper_bndr) + call xcbcst(density_pc_lower_bndr) + call xcbcst(tracer_pc_upper_bndr) + call xcbcst(tracer_pc_lower_bndr) + call xcbcst(velocity_pc_upper_bndr) + call xcbcst(velocity_pc_lower_bndr) + call xcbcst(dpmin_interior) + call xcbcst(regrid_method) + call xcbcst(regrid_nudge_ts) + call xcbcst(stab_fac_limit) + call xcbcst(smooth_diff_max) + call xcbcst(dktzu) + call xcbcst(dktzl) + endif + if (mnproc == 1) then + write (lp,*) 'readnml_ale_regrid_remap: ALE regrid-remap variables:' + write (lp,*) ' reconstruction_method = ', trim(reconstruction_method) + write (lp,*) ' upper_bndr_ord = ', upper_bndr_ord + write (lp,*) ' lower_bndr_ord = ', lower_bndr_ord + write (lp,*) ' density_limiting = ', trim(density_limiting) + write (lp,*) ' tracer_limiting = ', trim(tracer_limiting) + write (lp,*) ' velocity_limiting = ', trim(velocity_limiting) + write (lp,*) ' density_pc_upper_bndr = ', density_pc_upper_bndr + write (lp,*) ' density_pc_lower_bndr = ', density_pc_lower_bndr + write (lp,*) ' tracer_pc_upper_bndr = ', tracer_pc_upper_bndr + write (lp,*) ' tracer_pc_lower_bndr = ', tracer_pc_lower_bndr + write (lp,*) ' velocity_pc_upper_bndr = ', velocity_pc_upper_bndr + write (lp,*) ' velocity_pc_lower_bndr = ', velocity_pc_lower_bndr + write (lp,*) ' dpmin_interior = ', dpmin_interior + write (lp,*) ' regrid_method = ', trim(regrid_method) + write (lp,*) ' regrid_nudge_ts = ', regrid_nudge_ts + write (lp,*) ' stab_fac_limit = ', stab_fac_limit + write (lp,*) ' smooth_diff_max = ', smooth_diff_max + write (lp,*) ' dktzu = ', dktzu + write (lp,*) ' dktzl = ', dktzl + endif + + ! Resolve options. + select case (trim(reconstruction_method)) + case ('plm') + reconstruction_method_tag = hor3map_plm + case ('ppm') + reconstruction_method_tag = hor3map_ppm + case ('pqm') + reconstruction_method_tag = hor3map_pqm + case default + if (mnproc == 1) & + write (lp,'(3a)') & + ' readnml_ale_regrid_remap: reconstruction_method = ', & + trim(reconstruction_method), ' is unsupported!' + call xcstop('(readnml_ale_regrid_remap)') + stop '(readnml_ale_regrid_remap)' + end select + select case (trim(density_limiting)) + case ('monotonic') + density_limiting_tag = hor3map_monotonic + case default + if (mnproc == 1) & + write (lp,'(3a)') & + ' readnml_ale_regrid_remap: density_limiting = ', & + trim(density_limiting), ' is unsupported!' + call xcstop('(readnml_ale_regrid_remap)') + stop '(readnml_ale_regrid_remap)' + end select + select case (trim(tracer_limiting)) + case ('monotonic') + tracer_limiting_tag = hor3map_monotonic + case ('non_oscillatory') + tracer_limiting_tag = hor3map_non_oscillatory + case default + if (mnproc == 1) & + write (lp,'(3a)') & + ' readnml_ale_regrid_remap: tracer_limiting = ', & + trim(tracer_limiting), ' is unsupported!' + call xcstop('(readnml_ale_regrid_remap)') + stop '(readnml_ale_regrid_remap)' + end select + select case (trim(velocity_limiting)) + case ('monotonic') + velocity_limiting_tag = hor3map_monotonic + case ('non_oscillatory') + velocity_limiting_tag = hor3map_non_oscillatory + case default + if (mnproc == 1) & + write (lp,'(3a)') & + ' readnml_ale_regrid_remap: velocity_limiting = ', & + trim(velocity_limiting), ' is unsupported!' + call xcstop('(readnml_ale_regrid_remap)') + stop '(readnml_ale_regrid_remap)' + end select + if (vcoord_tag == vcoord_cntiso_hybrid) then + select case (trim(regrid_method)) + case ('direct') + regrid_method_tag = regrid_method_direct + case ('nudge') + regrid_method_tag = regrid_method_nudge + case default + if (mnproc == 1) & + write (lp,'(3a)') & + ' readnml_ale_regrid_remap: regrid_method = ', & + trim(regrid_method), ' is unsupported!' + call xcstop('(readnml_ale_regrid_remap)') + stop '(readnml_ale_regrid_remap)' + end select + endif + + ! Change units from [m] to [g cm-1 s-2] of depth interval variables. + dpmin_interior = dpmin_interior*onem + + end subroutine readnml_ale_regrid_remap + + subroutine init_ale_regrid_remap + ! --------------------------------------------------------------------------- + ! Initialize arrays and data structures. + ! --------------------------------------------------------------------------- + + integer :: i, j, k, nt, errstat + + ! Only do the initialization if the vertical coordinate require the ALE + ! approach. + if (vcoord_tag == vcoord_isopyc_bulkml) return + + ! Local number of tracers where temperature and salinity is added to the + ! ntr parameter. + ntr_loc = ntr + 2 + + ! Allocate reconstruction data structures for tracer source data. + allocate(trc_rcss(ntr_loc), stat = errstat) + if (errstat /= 0) then + write(lp,*) 'Failed to allocate trc_rcss!' + call xchalt('(init_ale_regrid_remap)') + stop '(init_ale_regrid_remap)' + endif + + ! Configuration of the reconstruction data structure that only depends on + ! the source grid. + rcgs%n_src = kk + rcgs%i_ubound = ii + if (ltedtp_opt == ltedtp_neutral) then + ! Neutral diffusion is requested so increase the index range of the + ! reconstruction data structure. + rcgs%i_lbound = rcgs%i_lbound - 1 + rcgs%i_ubound = rcgs%i_ubound + 1 + rcgs%j_ubound = rcgs%j_ubound + 1 + endif + if (vcoord_tag == vcoord_cntiso_hybrid .and. & + regrid_method_tag == regrid_method_nudge .and. & + smooth_diff_max > 0._r8) then + ! Lateral smoothing of interfaces after regridding is requested so + ! increase the index range of the reconstruction data structure. + rcgs%i_lbound = rcgs%i_lbound - 1 + rcgs%i_ubound = rcgs%i_ubound + 1 + rcgs%j_ubound = rcgs%j_ubound + 1 + endif + rcgs%method = reconstruction_method_tag + rcgs%left_bndr_ord = upper_bndr_ord + rcgs%right_bndr_ord = lower_bndr_ord + + ! Configuration of reconstruction data structures that is specific to + ! various source data. + + d_rcss%limiting = density_limiting_tag + d_rcss%pc_left_bndr = density_pc_upper_bndr + d_rcss%pc_right_bndr = density_pc_lower_bndr + + trc_rcss(1)%limiting = tracer_limiting_tag + trc_rcss(1)%pc_left_bndr = tracer_pc_upper_bndr + trc_rcss(1)%pc_right_bndr = tracer_pc_lower_bndr + if (tracer_limiting_tag == hor3map_non_oscillatory) then + do nt = 2, ntr_loc + trc_rcss(nt)%limiting = hor3map_non_oscillatory_posdef + trc_rcss(nt)%pc_left_bndr = tracer_pc_upper_bndr + trc_rcss(nt)%pc_right_bndr = tracer_pc_lower_bndr + enddo + else + do nt = 2, ntr_loc + trc_rcss(nt)%limiting = tracer_limiting_tag + trc_rcss(nt)%pc_left_bndr = tracer_pc_upper_bndr + trc_rcss(nt)%pc_right_bndr = tracer_pc_lower_bndr + enddo + endif + + v_rcss%limiting = velocity_limiting_tag + v_rcss%pc_left_bndr = velocity_pc_upper_bndr + v_rcss%pc_right_bndr = velocity_pc_lower_bndr + + ! Configuration of remapping data structure. + rms%n_dst = kk + + ! Initialize reconstruction and remapping data structures. + + errstat = initialize_rcgs(rcgs) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(init_ale_regrid_remap)') + stop '(init_ale_regrid_remap)' + endif + + errstat = initialize_rcss(rcgs, d_rcss) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(init_ale_regrid_remap)') + stop '(init_ale_regrid_remap)' + endif + + do nt = 1, ntr_loc + errstat = initialize_rcss(rcgs, trc_rcss(nt)) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(init_ale_regrid_remap)') + stop '(init_ale_regrid_remap)' + endif + enddo + + errstat = initialize_rcss(rcgs, v_rcss) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(init_ale_regrid_remap)') + stop '(init_ale_regrid_remap)' + endif + + errstat = initialize_rms(rcgs, rms) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(init_ale_regrid_remap)') + stop '(init_ale_regrid_remap)' + endif + + end subroutine init_ale_regrid_remap + + subroutine ale_regrid_remap(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Regrid, remap and carry out additional operations that makes use of the + ! reconstructed vertical profiles, such as neutral diffusion. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + integer, parameter :: p_ord = 4 + + real(r8), dimension(kdm+1,1-nbdy:idm+nbdy,3) :: & + p_src_js, p_dst_js, stab_fac_js, smtflxconv_js + real(r8), dimension(p_ord+1,kdm,ntr_loc,1-nbdy:idm+nbdy,3) :: tpc_src_js + real(r8), dimension(2,kdm,ntr_loc,1-nbdy:idm+nbdy,3) :: t_srcdi_js + real(r8), dimension(2,kdm,1-nbdy:idm+nbdy,3) :: & + p_srcdi_js, drhodt_srcdi_js, drhods_srcdi_js + real(r8), dimension(kdm,ntr_loc,1-nbdy:idm+nbdy,3) :: flxconv_js + real(r8), dimension(kdm,ntr_loc,1-nbdy:idm+nbdy) :: trc_rm + real(r8), dimension(kdm+1) :: p_1d, p_dst_1d + real(r8), dimension(kdm) :: u_1d, v_1d + real(r8) :: q + integer, dimension(1-nbdy:idm+nbdy,3) :: ksmx_js, kdmx_js + integer :: ilb1, ilb2, ilb3, iub1, iub2, iub3, jofs2, jofs3, & + jlb_regrid_smooth, jlb_ndiff_prep, jlb_ndiff_uflx, & + jlb_ndiff_vflx, jlb_ndiff_update_trc, & + js1, js2, js3, j, nt, i, k, l, kn, errstat + logical :: do_regrid_smooth, do_ndiff + + ! ------------------------------------------------------------------------ + ! Regrid and remap tracers. Also carry out neutral diffusion if requested. + ! The operations are carried out on temporary arrays with minimal j-index + ! range, j-slices, to minimize the memory needed to hold the + ! reconstruction data structures. + ! ------------------------------------------------------------------------ + + ! Check if lateral smoothing of interfaces after regridding should be + ! applied. + if (vcoord_tag == vcoord_cntiso_hybrid .and. & + regrid_method_tag == regrid_method_nudge .and. & + smooth_diff_max > 0._r8) then + do_regrid_smooth = .true. + smtflxconv_js(:,:,:) = 0._r8 + else + do_regrid_smooth = .false. + endif + + ! Check if neutral diffusion is requested. + if (ltedtp_opt == ltedtp_neutral) then + do_ndiff = .true. + else + do_ndiff = .false. + endif + + ! Set j-slice offsets. + if (do_ndiff) then + jofs2 = 1 + else + jofs2 = 0 + endif + if (do_regrid_smooth) then + jofs3 = jofs2 + 1 + else + jofs3 = jofs2 + endif + + ! Set lower j-index bound of the various operations. If an operation is + ! not requested, the bound is set so the operation is never called. + jlb_regrid_smooth = jj + 1 + jlb_ndiff_prep = jj + 1 + jlb_ndiff_uflx = jj + 1 + jlb_ndiff_vflx = jj + 1 + jlb_ndiff_update_trc = jj + 1 + if (do_regrid_smooth) then + jlb_regrid_smooth = 1 - 2*jofs3 + 1 + endif + if (do_ndiff) then + jlb_ndiff_prep = - 1 + jlb_ndiff_uflx = 1 + jlb_ndiff_vflx = 0 + jlb_ndiff_update_trc = 1 + endif + + ! Set lower and upper bounds of i-indices corresponding to j-slice + ! offsets. + ilb1 = 1 + ilb2 = 1 - jofs2 + ilb3 = 1 - jofs3 + iub1 = ii + iub2 = ii + jofs2 + iub3 = ii + jofs3 + + ! Update halos as needed. + if (jofs3 > 0) then + call xctilr(dp (1-nbdy,1-nbdy,k1n), 1, kk, jofs3, jofs3, halo_ps) + call xctilr(temp (1-nbdy,1-nbdy,k1n), 1, kk, jofs3, jofs3, halo_ps) + call xctilr(saln (1-nbdy,1-nbdy,k1n), 1, kk, jofs3, jofs3, halo_ps) + call xctilr(sigma(1-nbdy,1-nbdy,k1n), 1, kk, jofs3, jofs3, halo_ps) + endif + if (do_ndiff) then + do nt = 1, ntr + call xctilr(trc(1-nbdy,1-nbdy,k1n,nt), 1, kk, 1, 1, halo_ps) + enddo + call xctilr(difiso, 1,kk, 1,1, halo_ps) + end if + + ! Inital j-slice indices. + js1 = 1 + js2 = js1 + jofs2 + js3 = js1 + jofs3 + + do j = 1 - 2*jofs3, jj + + ! Update j-slice indices. + js1 = mod(js1 , jofs3 + 1) + 1 + js2 = mod(js1 + jofs2 - 1, jofs3 + 1) + 1 + js3 = mod(js1 + jofs3 - 1, jofs3 + 1) + 1 + + ! Vertically reconstruct tracers. + call reconstruct_trc_jslice(p_src_js(:,:,js3), ksmx_js(:,js3), & + tpc_src_js(:,:,:,:,js3), & + t_srcdi_js(:,:,:,:,js3), & + ilb3, iub3, j+jofs3, js3, nn) + + ! Regrid. + call regrid_jslice (p_src_js(:,:,js3), ksmx_js(:,js3), & + tpc_src_js(:,:,:,:,js3), & + t_srcdi_js(:,:,:,:,js3), & + p_dst_js(:,:,js3), stab_fac_js(:,:,js3), & + ilb3, iub3, j+jofs3, js3, nn) + + ! If requested, apply lateral smoothing of the interfaces after + ! regridding. + if (j >= jlb_regrid_smooth) & + call regrid_smooth_jslice (p_dst_js, stab_fac_js, smtflxconv_js, & + ilb2, iub2, j+jofs2, js2, js3) + + ! If requested, prepare neutral diffusion. + if (j >= jlb_ndiff_prep) & + call ndiff_prep_jslice (p_src_js, ksmx_js, & + tpc_src_js, t_srcdi_js, & + p_dst_js, kdmx_js, p_srcdi_js, & + drhodt_srcdi_js, drhods_srcdi_js, & + flxconv_js, & + ilb2, iub2, j+jofs2, js2, mm) + + ! If requested, compute the contribution of u-component fluxes to the + ! flux convergence of neutral diffusion. + if (j >= jlb_ndiff_uflx) & + call ndiff_uflx_jslice (ksmx_js, tpc_src_js, t_srcdi_js, & + p_dst_js, kdmx_js, p_srcdi_js, & + drhodt_srcdi_js, drhods_srcdi_js, & + flxconv_js, & + ntr_loc, ilb1, iub2, j, js1, mm, nn) + + ! If requested, compute the contribution of v-component fluxes to the + ! flux convergence of neutral diffusion. + if (j >= jlb_ndiff_vflx) & + call ndiff_vflx_jslice (ksmx_js, tpc_src_js, t_srcdi_js, & + p_dst_js, kdmx_js, p_srcdi_js, & + drhodt_srcdi_js, drhods_srcdi_js, & + flxconv_js, & + ntr_loc, ilb1, iub1, j+jofs2, & + js1, js2, mm, nn) + + ! Remap tracers to the regridded layers. + if (j >= 1) & + call remap_trc_jslice (p_dst_js(:,:,js1), trc_rm, & + ilb1, iub1, j, js1) + + ! If requested, update the tracers by applying the neutral diffusion + ! flux convergence. + if (j >= jlb_ndiff_update_trc) & + call ndiff_update_trc_jslice(p_dst_js, flxconv_js, trc_rm, & + ntr_loc, ilb1, iub1, j, js1) + + ! Copy from the j-slice array to the full tracer array. + if (j >= 1) & + call copy_jslice_to_3d (p_dst_js(:,:,js1), trc_rm, & + ilb1, iub1, j, nn) + enddo + + ! ------------------------------------------------------------------------ + ! Remap velocity. + ! ------------------------------------------------------------------------ + + !$omp parallel do private(k, kn, l, i) + do j = 1, jj + do k = 1, kk + kn = k + nn + do l = 1, isu(j) + do i = max(1, ifu(j,l)), min(ii, ilu(j,l)) + pu(i,j,k+1) = pu(i,j,k) + dpu(i,j,kn) + enddo + enddo + do l = 1, isv(j) + do i = max(1, ifv(j,l)), min(ii, ilv(j,l)) + pv(i,j,k+1) = pv(i,j,k) + dpv(i,j,kn) + enddo + enddo + enddo + enddo + !$omp end parallel do + + call xctilr(dp(1-nbdy,1-nbdy,k1n), 1, kk, 3, 3, halo_ps) + + !$omp parallel do private(k, kn, l, i) + do j = -2, jj+3 + do k = 1, kk + kn = k + nn + do l = 1, isp(j) + do i = max(-2, ifp(j,l)), min(ii+3, ilp(j,l)) + p(i,j,k+1) = p(i,j,k) + dp(i,j,kn) + enddo + enddo + enddo + enddo + !$omp end parallel do + + !$omp parallel do private(k,kn,l,i,q) + do j = -1, jj+2 + do k = 1, kk + kn = k + nn + do l = 1, isu(j) + do i = max(-1, ifu(j,l)), min(ii+2, ilu(j,l)) + q = min(p(i,j,kk+1), p(i-1,j,kk+1)) + dpu(i,j,kn) = & + .5_r8*( (min(q, p(i-1,j,k+1)) - min(q, p(i-1,j,k))) & + + (min(q, p(i ,j,k+1)) - min(q, p(i ,j,k)))) + enddo + enddo + do l = 1, isv(j) + do i = max(-1, ifv(j,l)), min(ii+2, ilv(j,l)) + q = min(p(i,j,kk+1), p(i,j-1,kk+1)) + dpv(i,j,kn) = & + .5_r8*( (min(q, p(i,j-1,k+1)) - min(q, p(i,j-1,k))) & + + (min(q, p(i,j ,k+1)) - min(q, p(i,j ,k)))) + enddo + enddo + enddo + enddo + !$omp end parallel do + + do j = 1, jj + + do l = 1, isu(j) + do i = max(1, ifu(j,l)), min(ii, ilu(j,l)) + + ! Copy variables into 1D arrays. Rescale source interfaces so the + ! pressure range of source and destination columns match. + p_dst_1d(1) = pu(i,j,1) + do k = 1, kk + kn = k + nn + u_1d(k) = u(i,j,kn) + p_dst_1d(k+1) = p_dst_1d(k) + dpu(i,j,kn) + enddo + q = p_dst_1d(kk+1)/pu(i,j,kk+1) + do k = 1, kk+1 + p_1d(k) = pu(i,j,k)*q + enddo + + ! Prepare reconstruction with current interface pressures. + errstat = prepare_reconstruction(rcgs, p_1d, i, 1) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(ale_regrid_remap)') + stop '(ale_regrid_remap)' + endif + + ! Prepare remapping to layer structure with regridded interface + ! pressures. + errstat = prepare_remapping(rcgs, rms, p_dst_1d, i, 1) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(ale_regrid_remap)') + stop '(ale_regrid_remap)' + endif + + ! Reconstruct and remap u-component of velocity. + errstat = reconstruct(rcgs, v_rcss, u_1d, i, 1) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(ale_regrid_remap)') + stop '(ale_regrid_remap)' + endif + errstat = remap(v_rcss, rms, u_1d, i, 1) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(ale_regrid_remap)') + stop '(ale_regrid_remap)' + endif + + ! Update 3D arrays + do k = 1, kk + kn = k + nn + u(i,j,kn) = u_1d(k) + enddo + + enddo + enddo + + do l = 1, isv(j) + do i = max(1, ifv(j,l)), min(ii, ilv(j,l)) + + ! Copy variables into 1D arrays. Rescale source interfaces so the + ! pressure range of source and destination columns match. + p_dst_1d(1) = pv(i,j,1) + do k = 1, kk + kn = k + nn + v_1d(k) = v(i,j,kn) + p_dst_1d(k+1) = p_dst_1d(k) + dpv(i,j,kn) + enddo + q = p_dst_1d(kk+1)/pv(i,j,kk+1) + do k = 1, kk+1 + p_1d(k) = pv(i,j,k)*q + enddo + + ! Prepare reconstruction with current interface pressures. + errstat = prepare_reconstruction(rcgs, p_1d, i, 1) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(ale_regrid_remap)') + stop '(ale_regrid_remap)' + endif + + ! Prepare remapping to layer structure with regridded interface + ! pressures. + errstat = prepare_remapping(rcgs, rms, p_dst_1d, i, 1) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(ale_regrid_remap)') + stop '(ale_regrid_remap)' + endif + + ! Reconstruct and remap v-component of velocity. + errstat = reconstruct(rcgs, v_rcss, v_1d, i, 1) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(ale_regrid_remap)') + stop '(ale_regrid_remap)' + endif + errstat = remap(v_rcss, rms, v_1d, i, 1) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(ale_regrid_remap)') + stop '(ale_regrid_remap)' + endif + + ! Update 3D arrays + do k = 1, kk + kn = k + nn + v(i,j,kn) = v_1d(k) + enddo + + enddo + enddo + + enddo + + if (csdiag) then + if (mnproc == 1) then + write (lp,*) 'ale_regrid_remap:' + endif + call chksummsk(dp (1-nbdy,1-nbdy,k1n), ip, kk, 'dp') + call chksummsk(temp (1-nbdy,1-nbdy,k1n), ip, kk, 'temp') + call chksummsk(saln (1-nbdy,1-nbdy,k1n), ip, kk, 'saln') + call chksummsk(sigma(1-nbdy,1-nbdy,k1n), ip, kk, 'sigma') + do nt = 1, ntr + call chksummsk(trc(1-nbdy,1-nbdy,k1n,nt), ip, kk, 'trc') + enddo + call chksummsk(dpu(1-nbdy,1-nbdy,k1n), iu, kk, 'dpu') + call chksummsk(dpv(1-nbdy,1-nbdy,k1n), iv, kk, 'dpv') + call chksummsk(u (1-nbdy,1-nbdy,k1n), iu, kk, 'u') + call chksummsk(v (1-nbdy,1-nbdy,k1n), iv, kk, 'v') + endif + + end subroutine ale_regrid_remap + +end module mod_ale_regrid_remap diff --git a/phy/mod_vdiff.F90 b/phy/mod_ale_vdiff.F90 similarity index 95% rename from phy/mod_vdiff.F90 rename to phy/mod_ale_vdiff.F90 index 8664cda0..86bede95 100644 --- a/phy/mod_vdiff.F90 +++ b/phy/mod_ale_vdiff.F90 @@ -17,10 +17,11 @@ ! along with BLOM. If not, see . ! ------------------------------------------------------------------------------ -module mod_vdiff - ! ------------------------------------------------------------------------------ - ! This module contains procedures for solving vertical diffusion equations. - ! ------------------------------------------------------------------------------ +module mod_ale_vdiff +! ------------------------------------------------------------------------------ +! This module contains procedures for solving vertical diffusion equations with +! the ALE method. +! ------------------------------------------------------------------------------ use mod_types, only: r8 use mod_constants, only: g, spcifh, alpha0, onem @@ -41,11 +42,11 @@ module mod_vdiff real(r8), parameter :: & dpmin_vdiff = 0.1_r8*onem - public :: cntiso_hybrid_vdifft, cntiso_hybrid_vdiffm + public :: ale_vdifft, ale_vdiffm contains - subroutine cntiso_hybrid_vdifft(m, n, mm, nn, k1m, k1n) + subroutine ale_vdifft(m, n, mm, nn, k1m, k1n) integer, intent(in) :: m, n, mm, nn, k1m, k1n @@ -220,7 +221,7 @@ subroutine cntiso_hybrid_vdifft(m, n, mm, nn, k1m, k1n) if (csdiag) then if (mnproc == 1) then - write (lp,*) 'cntiso_hybrid_vdifft:' + write (lp,*) 'ale_vdifft:' endif call chksummsk(temp, ip, 2*kk, 'temp') call chksummsk(saln, ip, 2*kk, 'saln') @@ -232,9 +233,9 @@ subroutine cntiso_hybrid_vdifft(m, n, mm, nn, k1m, k1n) end if endif - end subroutine cntiso_hybrid_vdifft + end subroutine ale_vdifft - subroutine cntiso_hybrid_vdiffm(m, n, mm, nn, k1m, k1n) + subroutine ale_vdiffm(m, n, mm, nn, k1m, k1n) integer, intent(in) :: m, n, mm, nn, k1m, k1n @@ -357,12 +358,12 @@ subroutine cntiso_hybrid_vdiffm(m, n, mm, nn, k1m, k1n) if (csdiag) then if (mnproc == 1) then - write (lp,*) 'cntiso_hybrid_vdiffm:' + write (lp,*) 'ale_vdiffm:' endif call chksummsk(u, iu, 2*kk, 'u') call chksummsk(v, iv, 2*kk, 'v') endif - end subroutine cntiso_hybrid_vdiffm + end subroutine ale_vdiffm -end module mod_vdiff +end module mod_ale_vdiff diff --git a/phy/mod_blom_init.F90 b/phy/mod_blom_init.F90 index 1381a22d..ffdc43f3 100644 --- a/phy/mod_blom_init.F90 +++ b/phy/mod_blom_init.F90 @@ -19,13 +19,46 @@ module mod_blom_init + use dimensions, only: itdm, nreg + use mod_config, only: expcnf + use mod_time, only: date, nday1, nday2, nstep1, nstep2, nstep, delt1, & + time0, baclin + use mod_timing, only: init_timing, get_time + use mod_xc, only: xcspmd, xcbcst, xctilr, mnproc, nproc, & + lp, ii, jj, kk, isp, ifp, isu, ifu, ilp, isv, ifv, & + ilu, ilv, jpr, i0, nbdy, & + halo_ps, halo_us, halo_vs, halo_uv, halo_vv, halo_qs + use mod_pointtest, only: init_ptest + use mod_inicon, only: icfile + use mod_state, only: dp, dpu, dpv, uflx, vflx, p, pu, pv, phi + use mod_barotp, only: pvtrop + use mod_pgforc, only: pgfxm, pgfym, xixp, xixm, xiyp, xiym + use mod_niw, only: uml, vml, umlres, vmlres + use mod_eos, only: inieos + use mod_swabs, only: iniswa + use mod_tmsmt, only: initms + use mod_dia, only: diaini, diasg1 + use mod_inicon, only: inicon + use mod_budget, only: budget_init + use mod_cmnfld_routines, only: cmnfld1 + use mod_tke, only: initke + use mod_rdlim, only: rdlim + use mod_inifrc, only: inifrc + use mod_inivar, only: inivar + use mod_vcoord, only: vcoord_tag, vcoord_isopyc_bulkml, sigmar + use mod_ale_regrid_remap, only: init_ale_regrid_remap + use mod_inigeo, only: inigeo + use mod_iniphy, only: iniphy + use mod_restart, only: restart_read + use mod_ifdefs, only: use_TRC, use_TKE + use mod_tracers_update, only: initrc + use netcdf + implicit none private public :: blom_init - private :: numerical_bounds - contains subroutine blom_init() @@ -33,40 +66,6 @@ subroutine blom_init() ! initialize the model ! ------------------------------------------------------------------ - use dimensions, only: itdm, nreg - use mod_config, only: expcnf - use mod_time, only: date, nday1, nday2, nstep1, nstep2, nstep, delt1, & - time0, baclin - use mod_timing, only: init_timing, get_time - use mod_xc, only: xcspmd, xcbcst, xctilr, mnproc, nproc, & - lp, ii, jj, kk, isp, ifp, isu, ifu, ilp, isv, ifv, & - ilu, ilv, jpr, i0, nbdy, & - halo_ps, halo_us, halo_vs, halo_uv, halo_vv, halo_qs - use mod_pointtest, only: init_ptest - use mod_inicon, only: icfile - use mod_state, only: dp, dpu, dpv, uflx, vflx, p, pu, pv, phi - use mod_barotp, only: pvtrop - use mod_pgforc, only: pgfxm, pgfym, xixp, xixm, xiyp, xiym - use mod_niw, only: uml, vml, umlres, vmlres - use mod_eos, only: inieos - use mod_swabs, only: iniswa - use mod_tmsmt, only: initms - use mod_dia, only: diaini, diasg1 - use mod_inicon, only: inicon - use mod_budget, only: budget_init - use mod_cmnfld_routines, only: cmnfld1 - use mod_tke, only: initke - use mod_rdlim, only: rdlim - use mod_inifrc, only: inifrc - use mod_inivar, only: inivar - use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, sigmar - use mod_inigeo, only: inigeo - use mod_iniphy, only: iniphy - use mod_restart, only: restart_read - use mod_ifdefs, only: use_TRC, use_TKE - use mod_tracers_update, only: initrc - use netcdf - ! Local variables integer :: istat,ncid,varid,i,j,k,l,m,n,mm,nn,k1m,k1n,mt,mmt,kn,km real :: q @@ -122,6 +121,12 @@ subroutine blom_init() call inivar + ! ------------------------------------------------------------------ + ! Initialize ALE regridding and remapping + ! ------------------------------------------------------------------ + + call init_ale_regrid_remap + ! ------------------------------------------------------------------ ! Set various numerical bounds ! ------------------------------------------------------------------ @@ -242,7 +247,7 @@ subroutine blom_init() call xctilr(dp, 1,2*kk, 3,3, halo_ps) - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then do mt = n,3-n,3-2*n mmt = (mt-1)*kk @@ -344,7 +349,7 @@ subroutine blom_init() call xctilr(pgfym, 1,2, 1,2, halo_vv) call xctilr(xiyp, 1,2, 1,2, halo_vs) call xctilr(xiym, 1,2, 1,2, halo_vs) - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then call xctilr(uml, 1,4, 1,0, halo_uv) call xctilr(vml, 1,4, 0,1, halo_vv) call xctilr(umlres, 1,2, 1,0, halo_uv) diff --git a/phy/mod_blom_step.F90 b/phy/mod_blom_step.F90 index 1e3f19df..051f4f9b 100644 --- a/phy/mod_blom_step.F90 +++ b/phy/mod_blom_step.F90 @@ -35,10 +35,9 @@ module mod_blom_step diaacc_total_time, io_total_time, & get_time use mod_xc, only: lp, kk, mnproc, xctilr, xcsum - use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, & - cntiso_hybrid, cntiso_hybrid_regrid_remap, & - remap_velocity - use mod_vdiff, only: cntiso_hybrid_vdifft, cntiso_hybrid_vdiffm + use mod_vcoord, only: vcoord_tag, vcoord_isopyc_bulkml + use mod_ale_regrid_remap, only: ale_regrid_remap + use mod_ale_vdiff, only: ale_vdifft, ale_vdiffm use mod_swabs, only: updswa use mod_tmsmt, only: tmsmt1, tmsmt2 use mod_eddtra, only: eddtra @@ -48,8 +47,7 @@ module mod_blom_step use mod_momtum, only: momtum use mod_mxlayr, only: mxlayr use mod_barotp, only: barotp - use mod_cmnfld_routines, only: cmnfld_bfsqi_cntiso_hybrid, & - cmnfld1, cmnfld2 + use mod_cmnfld_routines, only: cmnfld_bfsqi_ale, cmnfld1, cmnfld2 use mod_forcing, only: fwbbal use mod_budget, only: budget_sums, budget_output use mod_eddtra, only: eddtra @@ -71,8 +69,7 @@ module mod_blom_step use mod_restart, only: restart_write use mod_tracers_update, only: updtrc use mod_ifdefs, only: use_TRC - - use mod_cntiso_hybrid_forcing, only: cntiso_hybrid_forcing + use mod_ale_forcing, only: ale_forcing implicit none private @@ -148,9 +145,8 @@ subroutine blom_step() getfrc_time = get_time() - if (vcoord_type_tag == cntiso_hybrid) then - call cntiso_hybrid_regrid_remap(m,n,mm,nn,k1m,k1n) - call remap_velocity(m,n,mm,nn,k1m,k1n) + if (vcoord_tag /= vcoord_isopyc_bulkml) then + call ale_regrid_remap(m,n,mm,nn,k1m,k1n) convec_time = get_time() call budget_sums(2,n,nn) end if @@ -162,7 +158,7 @@ subroutine blom_step() tmsmt1_time = get_time() !diag write (lp,*) 'advdif...' - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then call difest_isobml(m,n,mm,nn,k1m,k1n) else call difest_lateral_hybrid(m,n,mm,nn,k1m,k1n) @@ -173,7 +169,7 @@ subroutine blom_step() call diffus(m,n,mm,nn,k1m,k1n) advdif_time = get_time() - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then call budget_sums(2,n,nn) else call budget_sums(3,n,nn) @@ -192,7 +188,7 @@ subroutine blom_step() call momtum(m,n,mm,nn,k1m,k1n) momtum_time = get_time() - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then !diag write (lp,*) 'convec...' call convec(m,n,mm,nn,k1m,k1n) @@ -214,17 +210,17 @@ subroutine blom_step() call thermf(m,n,mm,nn,k1m,k1n) thermf_time = get_time() - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then !diag write (lp,*) 'mxlayr...' call mxlayr(m,n,mm,nn,k1m,k1n) mxlayr_time = get_time() else - call cmnfld_bfsqi_cntiso_hybrid(m,n,mm,nn,k1m,k1n) - call cntiso_hybrid_forcing(m,n,mm,nn,k1m,k1n) + call cmnfld_bfsqi_ale(m,n,mm,nn,k1m,k1n) + call ale_forcing(m,n,mm,nn,k1m,k1n) call difest_vertical_hybrid(m,n,mm,nn,k1m,k1n) mxlayr_time = get_time() - call cntiso_hybrid_vdifft(m,n,mm,nn,k1m,k1n) - call cntiso_hybrid_vdiffm(m,n,mm,nn,k1m,k1n) + call ale_vdifft(m,n,mm,nn,k1m,k1n) + call ale_vdiffm(m,n,mm,nn,k1m,k1n) call budget_sums(4,n,nn) diapfl_time = get_time() end if diff --git a/phy/mod_budget.F90 b/phy/mod_budget.F90 index 515adfdc..403b592a 100644 --- a/phy/mod_budget.F90 +++ b/phy/mod_budget.F90 @@ -26,7 +26,7 @@ module mod_budget use mod_constants, only: g, spcifh use mod_time, only: nstep, nstep1, delt1 use mod_xc - use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml + use mod_vcoord, only: vcoord_tag, vcoord_isopyc_bulkml use mod_grid, only: scp2 use mod_state, only: pb, dp, temp, saln use mod_forcing, only: surflx, surrlx, salflx, salrlx @@ -185,14 +185,13 @@ subroutine budget_output(m) integer, intent(in) :: m - integer :: i, j,l - integer :: nfu + integer :: nfu, i, j, l if (.not.cnsvdi) return if (mnproc == 1 .and. nstep > nstep1 + 1) then - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then open (newunit = nfu, file = 'salbud', position = 'append') write (nfu, '(i8,6e12.4)') nstep - 1, & diff --git a/phy/mod_cmnfld_routines.F90 b/phy/mod_cmnfld_routines.F90 index 1365d8a1..9591ec30 100644 --- a/phy/mod_cmnfld_routines.F90 +++ b/phy/mod_cmnfld_routines.F90 @@ -26,7 +26,7 @@ module mod_cmnfld_routines use mod_types, only: r8 use mod_constants, only: g, alpha0, rho0, epsilp, onem, onecm, onemm use mod_xc - use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid + use mod_vcoord, only: vcoord_tag, vcoord_isopyc_bulkml use mod_grid, only: scuxi, scvyi use mod_eos, only: rho, p_alpha use mod_state, only: dp, temp, saln, p, phi, kfpla @@ -45,7 +45,7 @@ module mod_cmnfld_routines private - public :: cmnfld_bfsqi_cntiso_hybrid, cmnfld1, cmnfld2 + public :: cmnfld_bfsqi_ale, cmnfld1, cmnfld2 contains @@ -228,7 +228,7 @@ subroutine cmnfld_bfsqf_isopyc_bulkml(m, n, mm, nn, k1m, k1n) end subroutine cmnfld_bfsqf_isopyc_bulkml - subroutine cmnfld_bfsqf_cntiso_hybrid(m, n, mm, nn, k1m, k1n) + subroutine cmnfld_bfsqf_ale(m, n, mm, nn, k1m, k1n) ! --------------------------------------------------------------------------- ! Compute buoyancy frequency squared (BFSQ) on layer interfaces and ! representative of the layer itself. Also compute a filtered BFSQ on @@ -346,16 +346,16 @@ subroutine cmnfld_bfsqf_cntiso_hybrid(m, n, mm, nn, k1m, k1n) if (csdiag) then if (mnproc == 1) then - write(lp,*) 'cmnfld_bfsqf_cntiso_hybrid:' + write(lp,*) 'cmnfld_bfsqf_ale:' endif call chksummsk(bfsqi, ip, kk + 1, 'bfsqi') call chksummsk(bfsql, ip, kk, 'bfsql') call chksummsk(bfsqf, ip, kk + 1, 'bfsqf') endif - end subroutine cmnfld_bfsqf_cntiso_hybrid + end subroutine cmnfld_bfsqf_ale - subroutine cmnfld_bfsqi_cntiso_hybrid(m, n, mm, nn, k1m, k1n) + subroutine cmnfld_bfsqi_ale(m, n, mm, nn, k1m, k1n) ! --------------------------------------------------------------------------- ! Compute buoyancy frequency squared (BFSQ) on layer interfaces. ! --------------------------------------------------------------------------- @@ -419,12 +419,12 @@ subroutine cmnfld_bfsqi_cntiso_hybrid(m, n, mm, nn, k1m, k1n) if (csdiag) then if (mnproc == 1) then - write(lp,*) 'cmnfld_bfsqi_cntiso_hybrid:' + write(lp,*) 'cmnfld_bfsqi_ale:' endif call chksummsk(bfsqi, ip, kk + 1, 'bfsqi') endif - end subroutine cmnfld_bfsqi_cntiso_hybrid + end subroutine cmnfld_bfsqi_ale subroutine cmnfld_nslope_isopyc_bulkml(m, n, mm, nn, k1m, k1n) ! --------------------------------------------------------------------------- @@ -657,7 +657,7 @@ subroutine cmnfld_nslope_isopyc_bulkml(m, n, mm, nn, k1m, k1n) end subroutine cmnfld_nslope_isopyc_bulkml - subroutine cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) + subroutine cmnfld_nslope_ale(m, n, mm, nn, k1m, k1n) ! --------------------------------------------------------------------------- ! Estimate slope of local neutral surface. ! --------------------------------------------------------------------------- @@ -806,7 +806,7 @@ subroutine cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) if (csdiag) then if (mnproc == 1) then - write (lp,*) 'cmnfld_nslope_cntiso_hybrid:' + write (lp,*) 'cmnfld_nslope_ale:' endif call chksummsk(nslpx, iu, kk, 'nslpx') call chksummsk(nslpy, iv, kk, 'nslpy') @@ -814,9 +814,9 @@ subroutine cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) call chksummsk(nnslpy, iv, kk, 'nnslpy') endif - end subroutine cmnfld_nslope_cntiso_hybrid + end subroutine cmnfld_nslope_ale - subroutine cmnfld_nnslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) + subroutine cmnfld_nnslope_ale(m, n, mm, nn, k1m, k1n) ! --------------------------------------------------------------------------- ! Compute neutral slope times buoyancy frequency, where the neutral slope is ! known. @@ -880,13 +880,13 @@ subroutine cmnfld_nnslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) if (csdiag) then if (mnproc == 1) then - write (lp,*) 'cmnfld_nnslope_cntiso_hybrid:' + write (lp,*) 'cmnfld_nnslope_ale:' endif call chksummsk(nnslpx, iu, kk, 'nnslpx') call chksummsk(nnslpy, iv, kk, 'nnslpy') endif - end subroutine cmnfld_nnslope_cntiso_hybrid + end subroutine cmnfld_nnslope_ale subroutine cmnfld_z(m, n, mm, nn, k1m, k1n) ! --------------------------------------------------------------------------- @@ -1008,7 +1008,7 @@ subroutine cmnfld1(m, n, mm, nn, k1m, k1n) ! Compute fields depending on selection of physics and diagnostics. ! ------------------------------------------------------------------------ -! if (vcoord_type_tag == cntiso_hybrid .or. & +! if (vcoord_tag /= vcoord_isopyc_bulkml .or. & ! sum( ACC_MLTS (1:nphy) + ACC_MLTSMN(1:nphy) & ! + ACC_MLTSMX(1:nphy) + ACC_MLTSSQ(1:nphy) & ! + ACC_T20D (1:nphy) + & @@ -1022,7 +1022,7 @@ subroutine cmnfld1(m, n, mm, nn, k1m, k1n) ! endif -! if (vcoord_type_tag == cntiso_hybrid .or. & +! if (vcoord_tag /= vcoord_isopyc_bulkml .or. & ! sum( ACC_MLTS (1:nphy) + ACC_MLTSMN(1:nphy) & ! + ACC_MLTSMX(1:nphy) + ACC_MLTSSQ(1:nphy)) /= 0) then @@ -1054,7 +1054,7 @@ subroutine cmnfld2(m, n, mm, nn, k1m, k1n) ! call xctilr(temp(1 - nbdy, 1 - nbdy, k1n), 1, kk, 3, 3, halo_ps) ! call xctilr(saln(1 - nbdy, 1 - nbdy, k1n), 1, kk, 3, 3, halo_ps) - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then !$omp parallel do private(l, i) do j = 1, jj do l = 1, isp(j) @@ -1080,20 +1080,20 @@ subroutine cmnfld2(m, n, mm, nn, k1m, k1n) ! Compute fields depending on selection of physics and diagnostics. ! ------------------------------------------------------------------------ - ! if (vcoord_type_tag == cntiso_hybrid .or. & + ! if (vcoord_tag /= vcoord_isopyc_bulkml .or. & ! edritp == 'large scale' .or. eitmth == 'gm' .or. & ! sum(ACC_BFSQ(1:nphy)) /= 0) then - if (vcoord_type_tag == cntiso_hybrid .or. & + if (vcoord_tag /= vcoord_isopyc_bulkml .or. & edritp_opt == edritp_large_scale .or. eitmth_opt == eitmth_gm) then ! --------------------------------------------------------------------- ! Compute filtered buoyancy frequency squared. ! --------------------------------------------------------------------- - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then call cmnfld_bfsqf_isopyc_bulkml(m, n, mm, nn, k1m, k1n) else - call cmnfld_bfsqf_cntiso_hybrid(m, n, mm, nn, k1m, k1n) + call cmnfld_bfsqf_ale(m, n, mm, nn, k1m, k1n) endif endif @@ -1104,13 +1104,13 @@ subroutine cmnfld2(m, n, mm, nn, k1m, k1n) ! Estimate slope of local neutral surface. ! --------------------------------------------------------------------- - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then call cmnfld_nslope_isopyc_bulkml(m, n, mm, nn, k1m, k1n) else if (ltedtp_opt == ltedtp_neutral) then - call cmnfld_nnslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) + call cmnfld_nnslope_ale(m, n, mm, nn, k1m, k1n) else - call cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) + call cmnfld_nslope_ale(m, n, mm, nn, k1m, k1n) endif endif diff --git a/phy/mod_dia.F90 b/phy/mod_dia.F90 index d6eaac3a..ccd19142 100644 --- a/phy/mod_dia.F90 +++ b/phy/mod_dia.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2010-2023 Ingo Bethke, Mats Bentsen, Mehmet Ilicak, +! Copyright (C) 2010-2024 Ingo Bethke, Mats Bentsen, Mehmet Ilicak, ! Alok Kumar Gupta, Jörg Schwinger, Ping-Gin Chi, ! Mariana Vertenstein ! @@ -38,8 +38,7 @@ module mod_dia iu, iv, ips, halo_qs, halo_uv, halo_vv use mod_nctools use netcdf, only: nf90_fill_double - use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, & - cntiso_hybrid, sigmar + use mod_vcoord, only: vcoord_tag, vcoord_isopyc_bulkml, sigmar use mod_grid, only: scp2, depths, area use mod_eos, only: rho, p_alpha use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma, & @@ -1154,8 +1153,8 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) end if if (sum(acc_mld(1:nphy)+acc_maxmld(1:nphy)) /= 0) then - select case (vcoord_type_tag) - case (isopyc_bulkml) + select case (vcoord_tag) + case (vcoord_isopyc_bulkml) !$omp parallel do private(l,i) do j = 1,jj do l = 1,isp(j) @@ -1165,7 +1164,7 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) end do end do !$omp end parallel do - case (cntiso_hybrid) + case default !$omp parallel do private(l,i) do j = 1,jj do l = 1,isp(j) @@ -1175,10 +1174,6 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) end do end do !$omp end parallel do - case default - write (lp,*) 'diaacc: unsupported vertical coordinate!' - call xcstop('(diaacc)') - stop '(diaacc)' end select end if @@ -1649,16 +1644,20 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) ! isopycnal diffusivity [cm^2/s*g/cm/s^2] call acclyr(ACC_DIFISO,difiso,dp(1-nbdy,1-nbdy,k1m),1,'p') - ! vertical diffusivity (vcoord_type_tag == isopyc_bulkml) [cm^2/s*g/cm/s^2] + ! vertical diffusivity (vcoord == 'isopyc_bulkml') + ! [cm^2/s*g/cm/s^2] call acclyr(ACC_DIFDIA,difdia,dp(1-nbdy,1-nbdy,k1m),1,'p') - ! vertical momentum diffusivity (vcoord_type_tag == cntiso_hybrid) [cm^2/s*g/cm/s^2] + ! vertical momentum diffusivity (vcoord /= 'isopyc_bulkml') + ! [cm^2/s*g/cm/s^2] call accily(ACC_DIFVMO,Kvisc_m,dp(1-nbdy,1-nbdy,k1m),1,'p') - ! vertical heat diffusivity (vcoord_type_tag == cntiso_hybrid) [cm^2/s*g/cm/s^2] + ! vertical heat diffusivity (vcoord /= 'isopyc_bulkml') + ! [cm^2/s*g/cm/s^2] call accily(ACC_DIFVHO,Kdiff_t,dp(1-nbdy,1-nbdy,k1m),1,'p') - ! vertical salt diffusivity (vcoord_type_tag == cntiso_hybrid) [cm^2/s*g/cm/s^2] + ! vertical salt diffusivity (vcoord /= 'isopyc_bulkml') + ! [cm^2/s*g/cm/s^2] call accily(ACC_DIFVSO,Kdiff_s,dp(1-nbdy,1-nbdy,k1m),1,'p') ! absolute vorticity multiplied with potential density difference @@ -1846,17 +1845,19 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) ! isopycnal diffusivity [cm^2/s] call acclvl(ACC_DIFISOLVL,difiso,'p',k,ind1,ind2,wghts) - ! vertical diffusivity (vcoord_type_tag == isopyc_bulkml) [cm^2/s] + ! vertical diffusivity (vcoord == 'isopyc_bulkml') [cm^2/s] call acclvl(ACC_DIFDIALVL,difdia,'p',k,ind1,ind2,wghts) - ! vertical momentum diffusivity (vcoord_type_tag == cntiso_hybrid) + ! vertical momentum diffusivity (vcoord /= 'isopyc_bulkml') ! [cm^2/s] call accilv(ACC_DIFVMOLVL,Kvisc_m,'p',k,ind1,ind2,wghts) - ! vertical heat diffusivity (vcoord_type_tag == cntiso_hybrid) [cm^2/s] + ! vertical heat diffusivity (vcoord /= 'isopyc_bulkml') + ! [cm^2/s] call accilv(ACC_DIFVHOLVL,Kdiff_t,'p',k,ind1,ind2,wghts) - ! vertical salt diffusivity (vcoord_type_tag == cntiso_hybrid) [cm^2/s] + ! vertical salt diffusivity (vcoord /= 'isopyc_bulkml') + ! [cm^2/s] call accilv(ACC_DIFVSOLVL,Kdiff_s,'p',k,ind1,ind2,wghts) ! potential vorticity [s m-2] @@ -3354,8 +3355,7 @@ subroutine diasec(iogrp) integer :: iogrp ! Local variables - integer :: n,i,j,k,s,l - integer :: iostatus + integer :: nfu,iostatus,n,i,j,k,s,l integer, save :: nsi(max_sec) integer, save :: isi(max_sec,sdm) integer, save :: jsi(max_sec,sdm) @@ -3369,7 +3369,6 @@ subroutine diasec(iogrp) real, dimension(itdm,jtdm) :: & uflx_cumt,vflx_cumt,uflx_cum350t,vflx_cum350t real(8) :: volu,volv - integer :: nfu !--------------------------------------------------------------- ! read section information @@ -3504,7 +3503,7 @@ subroutine diamer(iogrp) integer, intent(in) :: iogrp ! Local variables - integer :: ncid,dimid,varid,i,j,k,l,m,n,o,s,ocn_nreg,iostatus + integer :: ncid,dimid,varid,i,j,k,l,m,n,o,s,ocn_nreg,nfu,iostatus integer :: istat,iind1,jind1,uflg1,vflg1,nind1 integer :: nfld,ACC_UIND,ACC_VIND,nind(ldm),iind(sdm,ldm),jind(sdm,ldm) integer :: kmxl(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) @@ -3516,7 +3515,6 @@ subroutine diamer(iogrp) real :: r character :: c20*20 logical :: iniflg = .true. - integer :: nfu save nind,iind,jind,oflg,uflg,vflg,depthst,iniflg,ocn_nreg diff --git a/phy/mod_difest.F90 b/phy/mod_difest.F90 index 4fef4334..5a04fd22 100644 --- a/phy/mod_difest.F90 +++ b/phy/mod_difest.F90 @@ -25,8 +25,7 @@ module mod_difest onecm, L_mks2cgs, M_mks2cgs, R_mks2cgs use mod_time, only: delt1, dlt use mod_xc - use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, & - cntiso_hybrid, sigmar + use mod_vcoord, only: sigmar use mod_grid, only: scpx, scpy, scp2, scuyi, scvxi, plat, & coriop, betafp, betatp, cosang, sinang, hangle use mod_eos, only: rho @@ -386,8 +385,7 @@ subroutine difest_common_iso(m,n,mm,nn,k1m,k1n) !----------------------------------------------------------- ! Obtain common fields for the estimation of lateral and vertical - ! diffusivities diapycnal diffusivities when vcoord_type_tag == - ! isopyc_bulkml. + ! diffusivities diapycnal diffusivities when vcoord == 'isopyc_bulkml'. !----------------------------------------------------------- integer :: m,n,mm,nn,k1m,k1n @@ -622,8 +620,7 @@ subroutine difest_common_hyb(m,n,mm,nn,k1m,k1n) !----------------------------------------------------------- ! Obtain common fields for the estimation of lateral and vertical - ! diffusivities diapycnal diffusivities when vcoord_type_tag == - ! isopyc_bulkml. + ! diffusivities diapycnal diffusivities when vcoord == 'isopyc_bulkml'. !----------------------------------------------------------- integer :: m,n,mm,nn,k1m,k1n diff --git a/phy/mod_diffusion.F90 b/phy/mod_diffusion.F90 index a43cdd9c..ba8de59f 100644 --- a/phy/mod_diffusion.F90 +++ b/phy/mod_diffusion.F90 @@ -195,9 +195,8 @@ subroutine readnml_diffusion ! Local variables character(len = 80) :: nml_fname - integer :: ios + integer :: nfu, ios logical :: fexist - integer :: nfu namelist /diffusion/ & egc, eggam, eglsmn, egmndf, egmxdf, egidfq, rhiscf, ri0, & diff --git a/phy/mod_eddtra.F90 b/phy/mod_eddtra.F90 index 9d2055ac..9550f05a 100644 --- a/phy/mod_eddtra.F90 +++ b/phy/mod_eddtra.F90 @@ -29,7 +29,7 @@ module mod_eddtra L_mks2cgs use mod_time, only: delt1 use mod_xc - use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid + use mod_vcoord, only: vcoord_tag, vcoord_isopyc_bulkml use mod_grid, only: scuy, scvx, scp2, scu2, scv2, scuxi, scvyi, coriop use mod_eos, only: rho, sig0 use mod_state, only: dp, dpu, dpv, temp, saln, p, pbu, pbv, kfpla @@ -1018,7 +1018,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) end subroutine eddtra_gm_isopyc_bulkml - subroutine eddtra_cntiso_hybrid(m, n, mm, nn, k1m, k1n) + subroutine eddtra_ale(m, n, mm, nn, k1m, k1n) ! --------------------------------------------------------------------------- ! Estimate eddy-induced transport following the Gent-McWilliams ! parameterization. @@ -1361,8 +1361,8 @@ subroutine eddtra_cntiso_hybrid(m, n, mm, nn, k1m, k1n) /(max(onemm, dpu(i,j,kn))*delt1*scuy(i,j)) enddo write(lp,*) 'no convergence u', i+i0, j+j0 - call xchalt('(eddtra_cntiso_hybrid)') - stop '(eddtra_cntiso_hybrid)' + call xchalt('(eddtra_ale)') + stop '(eddtra_ale)' endif changed = .false. @@ -1485,19 +1485,19 @@ subroutine eddtra_cntiso_hybrid(m, n, mm, nn, k1m, k1n) endif if (umfltd(i,j,km) + umflsm(i,j,km) > & ffac*max(epsilp, dlm(k))*scp2(i-1,j)) then - write(lp,*) 'eddtra_cntiso_hybrid u >', & + write(lp,*) 'eddtra_ale u >', & i+i0, j+j0, k, umfltd(i,j,km) + umflsm(i,j,km), & ffac*max(epsilp, dlm(k))*scp2(i-1,j) - call xchalt('(eddtra_cntiso_hybrid)') - stop '(eddtra_cntiso_hybrid)' + call xchalt('(eddtra_ale)') + stop '(eddtra_ale)' endif if (umfltd(i,j,km) + umflsm(i,j,km) < & - ffac*max(epsilp, dlp(k))*scp2(i ,j)) then - write(lp,*) 'eddtra_cntiso_hybrid u <', & + write(lp,*) 'eddtra_ale u <', & i+i0, j+j0, k, umfltd(i,j,km) + umflsm(i,j,km), & - ffac*max(epsilp, dlp(k))*scp2(i ,j) - call xchalt('(eddtra_cntiso_hybrid)') - stop '(eddtra_cntiso_hybrid)' + call xchalt('(eddtra_ale)') + stop '(eddtra_ale)' endif enddo @@ -1631,8 +1631,8 @@ subroutine eddtra_cntiso_hybrid(m, n, mm, nn, k1m, k1n) /(max(onemm, dpv(i,j,kn))*delt1*scvx(i,j)) enddo write(lp,*) 'no convergence v', i+i0, j+j0 - call xchalt('(eddtra_cntiso_hybrid)') - stop '(eddtra_cntiso_hybrid)' + call xchalt('(eddtra_ale)') + stop '(eddtra_ale)' endif changed = .false. @@ -1755,19 +1755,19 @@ subroutine eddtra_cntiso_hybrid(m, n, mm, nn, k1m, k1n) endif if (vmfltd(i,j,km) + vmflsm(i,j,km) > & ffac*max(epsilp, dlm(k))*scp2(i,j-1)) then - write(lp,*) 'eddtra_cntiso_hybrid v >', & + write(lp,*) 'eddtra_ale v >', & i+i0, j+j0, k, vmfltd(i,j,km) + vmflsm(i,j,km), & ffac*max(epsilp, dlm(k))*scp2(i,j-1) - call xchalt('(eddtra_cntiso_hybrid)') - stop '(eddtra_cntiso_hybrid)' + call xchalt('(eddtra_ale)') + stop '(eddtra_ale)' endif if (vmfltd(i,j,km) + vmflsm(i,j,km) < & - ffac*max(epsilp, dlp(k))*scp2(i,j )) then - write(lp,*) 'eddtra_cntiso_hybrid v <', & + write(lp,*) 'eddtra_ale v <', & i+i0, j+j0, k, vmfltd(i,j,km) + vmflsm(i,j,km), & - ffac*max(epsilp, dlp(k))*scp2(i,j ) - call xchalt('(eddtra_cntiso_hybrid)') - stop '(eddtra_cntiso_hybrid)' + call xchalt('(eddtra_ale)') + stop '(eddtra_ale)' endif enddo @@ -1776,7 +1776,7 @@ subroutine eddtra_cntiso_hybrid(m, n, mm, nn, k1m, k1n) enddo !$omp end parallel do - end subroutine eddtra_cntiso_hybrid + end subroutine eddtra_ale ! --------------------------------------------------------------------------- ! Public procedures. @@ -1824,17 +1824,17 @@ subroutine init_eddtra select case (trim(mlrmth)) case ('none') mlrmth_opt = mlrmth_none - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then ce = 0._r8 endif case ('fox08') mlrmth_opt = mlrmth_fox08 case ('bod23') - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then if (mnproc == 1) & write (lp,'(3a)') & ' init_eddtra: mlrmth = ', trim(mlrmth), & - ' is unsupported with vcoord_type = isopyc_bulkml!' + ' is unsupported with vcoord = ''isopyc_bulkml''!' call xcstop('(init_eddtra)') stop '(init_eddtra)' endif @@ -1860,7 +1860,7 @@ subroutine eddtra(m, n, mm, nn, k1m, k1n) real(r8) :: q integer :: i, j, k, l, km - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then ! Compute eddy-induced transport of mass. if (eitmth_opt == eitmth_intdif) then @@ -1871,7 +1871,7 @@ subroutine eddtra(m, n, mm, nn, k1m, k1n) if (mnproc == 1) then write(lp,'(a,i1,2a)') & ' eitmth_opt = ', eitmth_opt, ' is unsupported ', & - 'for vcoord_type = ''isopyc_bulkml''!' + 'for vcoord = ''isopyc_bulkml''!' endif call xcstop('(eddtra)') stop '(eddtra)' @@ -1906,12 +1906,12 @@ subroutine eddtra(m, n, mm, nn, k1m, k1n) ! Compute eddy-induced transport of mass. if (eitmth_opt == eitmth_gm) then - call eddtra_cntiso_hybrid(m, n, mm, nn, k1m, k1n) + call eddtra_ale(m, n, mm, nn, k1m, k1n) else if (mnproc == 1) then write(lp,'(a,i1,2a)') & ' eitmth_opt = ', eitmth_opt, ' is unsupported ', & - 'for vcoord_type = ''cntiso_hybrid''!' + 'for vcoord = ''cntiso_hybrid''!' endif call xcstop('(eddtra)') stop '(eddtra)' diff --git a/phy/mod_geoenv.F90 b/phy/mod_geoenv.F90 index 40c77898..08984186 100644 --- a/phy/mod_geoenv.F90 +++ b/phy/mod_geoenv.F90 @@ -57,9 +57,8 @@ subroutine geoenv_file real, dimension(cwmlen) :: cwmwth integer, dimension(cwmlen) :: cwmi,cwmj integer, dimension(3) :: start,count - integer :: i,j,k,status,ncid,dimid,varid,ios,ncwm,l + integer :: i,j,k,status,ncid,dimid,varid,nfu,ios,ncwm,l logical :: fexist - integer :: nfu real, parameter :: iL_mks2cgs = 1./L_mks2cgs namelist /cwmod/ cwmtag,cwmedg,cwmi,cwmj,cwmwth diff --git a/phy/mod_hor3map.F90 b/phy/mod_hor3map.F90 index f8d9bfca..bab39e12 100644 --- a/phy/mod_hor3map.F90 +++ b/phy/mod_hor3map.F90 @@ -52,12 +52,14 @@ module mod_hor3map hor3map_no_limiting = 200, & ! Limiting methods hor3map_monotonic = 201, & hor3map_non_oscillatory = 203, & - hor3map_non_oscillatory_posdef = 204 + hor3map_non_oscillatory_posdef = 204, & + hor3map_regrid_method_1 = 301, & ! Regrid methods + hor3map_regrid_method_2 = 302 ! Error parameters. integer, parameter :: & hor3map_noerr = 0, & - hor3map_invalid_method = 1, & + hor3map_invalid_recon_method = 1, & hor3map_resizing_initialized_rcgs = 2, & hor3map_nonmonotonic_src_edges = 3, & hor3map_src_extent_too_small = 4, & @@ -73,12 +75,13 @@ module mod_hor3map hor3map_invalid_ppm_limiting = 14, & hor3map_invalid_pqm_limiting = 15, & hor3map_recon_not_available = 16, & - hor3map_grd_size_mismatch = 17, & - hor3map_remap_not_prepared = 18, & - hor3map_dst_size_mismatch = 19, & - hor3map_index_out_of_bounds = 20, & - hor3map_inconsistent_rcgs = 21, & - hor3map_errmsg_num = 21 + hor3map_invalid_regrid_method = 17, & + hor3map_grd_size_mismatch = 18, & + hor3map_remap_not_prepared = 19, & + hor3map_dst_size_mismatch = 20, & + hor3map_index_out_of_bounds = 21, & + hor3map_inconsistent_rcgs = 22, & + hor3map_errmsg_num = 22 character(len = 80), dimension(hor3map_errmsg_num), parameter :: errmsg = & ["Invalid reconstruction method! ", & "Cannot resize initialized reconstruction grid data structure! ", & @@ -96,6 +99,7 @@ module mod_hor3map "Invalid limiting method for PPM! ", & "Invalid limiting method for PQM! ", & "Call 'reconstruct' first! ", & + "Invalid regrid method! ", & "Size mismatch between grid edge values and locations! ", & "Call 'prepare_remapping' first! ", & "Size mismatch between destination grid edges and data array! ", & @@ -144,7 +148,10 @@ module mod_hor3map c5_2 = 5._r8/2._r8, c8_3 = 8._r8/3._r8, c10_3 = 10._r8/3._r8, & c9_2 = 9._r8/2._r8 + ! Derived data types. + type :: recon_grd_struct + ! Reconstruction grid data structure. integer :: & i_lbound = 1, & @@ -198,6 +205,7 @@ module mod_hor3map end type recon_grd_struct type :: recon_src_struct + ! Reconstruction source data structure. integer :: & limiting = hor3map_monotonic, & @@ -232,6 +240,7 @@ module mod_hor3map end type recon_src_struct type :: remap_struct + ! Remapping data structure. integer :: & i_index_curr = 0, & @@ -259,7 +268,7 @@ module mod_hor3map public :: recon_grd_struct, recon_src_struct, remap_struct, & initialize_rcgs, initialize_rcss, initialize_rms, & prepare_reconstruction, prepare_remapping, & - reconstruct, extract_polycoeff, regrid, regrid2, remap, & + reconstruct, extract_polycoeff, regrid, remap, & free_rcgs, free_rcss, free_rms, & hor3map_pcm, hor3map_plm, hor3map_ppm, hor3map_pqm, & hor3map_no_limiting, hor3map_monotonic, hor3map_non_oscillatory, & @@ -300,7 +309,7 @@ function assign_ptr_rcgs(rcgs) result(errstat) ij_index = rcgs%i_index - rcgs%i_lbound + 1 & + (rcgs%j_index - rcgs%j_lbound) & - *(rcgs%i_ubound - rcgs%i_lbound + 1) + *(rcgs%i_ubound - rcgs%i_lbound + 1) rcgs%x_eps => rcgs%x_eps_data(ij_index) rcgs%x_edge_src => rcgs%x_edge_src_data(:,ij_index) @@ -640,7 +649,7 @@ end subroutine edge_ih4_coeff pure subroutine slope_ih3_coeff(h, tdscoeff) ! --------------------------------------------------------------------------- ! Compute row coefficients for the tridiagonal system of equations to be - ! solved for 3th order accurate slope estimates. + ! solved for 3rd order accurate slope estimates. ! --------------------------------------------------------------------------- real(r8), dimension(:), intent(in) :: h @@ -3016,7 +3025,187 @@ pure function quartic_intersection(pc, u, u_eps, xil, xir) result(xi) end function quartic_intersection - pure subroutine regrid_plm_intersections(rcss, u_sgn, u_edge_grd, x_edge_grd) + pure subroutine regrid_plm_method_1(rcss, u_sgn, u_edge_grd, x_edge_grd) + + type(recon_src_struct), intent(in) :: rcss + real(r8), dimension(:), intent(in) :: u_edge_grd + real(r8), dimension(:), intent(inout) :: x_edge_grd + real(r8), intent(in) :: u_sgn + + real(r8) :: ue_min, ue_max, xi + integer :: ns, ng, jg, js + + ! Number of source grid cells. + ns = rcss%rcgs%n_src_actual + + ! Number of grid edges. + ng = size(u_edge_grd) + + jg = 1 + do + if ((u_edge_grd(jg) - rcss%uel(1))*u_sgn >= c0) exit + jg = jg + 1 + if (jg > ng) return + enddo + + js = 1 + do + if (js + 1 > ns) exit + ue_min = min(rcss%uer(js)*u_sgn, rcss%uel(js+1)*u_sgn) + do + if (u_edge_grd(jg)*u_sgn >= ue_min) exit + xi = line_intersection(rcss%polycoeff(:,js), u_edge_grd(jg), & + rcss%u_eps, c0, c1) + x_edge_grd(jg) = rcss%rcgs%x_edge_src(js) & + + ( rcss%rcgs%x_edge_src(js+1) & + - rcss%rcgs%x_edge_src(js ))*xi + jg = jg + 1 + if (jg > ng) return + enddo + ue_max = max(rcss%uer(js)*u_sgn, rcss%uel(js+1)*u_sgn) + do + if (u_edge_grd(jg)*u_sgn > ue_max) exit + x_edge_grd(jg) = rcss%rcgs%x_edge_src(js+1) + jg = jg + 1 + if (jg > ng) return + enddo + js = js + 1 + enddo + + do + if ((u_edge_grd(jg) - rcss%uer(js))*u_sgn > c0) return + xi = line_intersection(rcss%polycoeff(:,js), u_edge_grd(jg), & + rcss%u_eps, c0, c1) + x_edge_grd(jg) = rcss%rcgs%x_edge_src(js) & + + ( rcss%rcgs%x_edge_src(js+1) & + - rcss%rcgs%x_edge_src(js ))*xi + jg = jg + 1 + if (jg > ng) return + enddo + + end subroutine regrid_plm_method_1 + + pure subroutine regrid_ppm_method_1(rcss, u_sgn, u_edge_grd, x_edge_grd) + + type(recon_src_struct), intent(in) :: rcss + real(r8), dimension(:), intent(in) :: u_edge_grd + real(r8), dimension(:), intent(inout) :: x_edge_grd + real(r8), intent(in) :: u_sgn + + real(r8) :: ue_min, ue_max, xi + integer :: ns, ng, jg, js + + ! Number of source grid cells. + ns = rcss%rcgs%n_src_actual + + ! Number of grid edges. + ng = size(u_edge_grd) + + jg = 1 + do + if ((u_edge_grd(jg) - rcss%uel(1))*u_sgn >= c0) exit + jg = jg + 1 + if (jg > ng) return + enddo + + js = 1 + do + if (js + 1 > ns) exit + ue_min = min(rcss%uer(js)*u_sgn, rcss%uel(js+1)*u_sgn) + do + if (u_edge_grd(jg)*u_sgn >= ue_min) exit + xi = parabola_intersection(rcss%polycoeff(:,js), u_edge_grd(jg), & + rcss%u_eps, c0, c1) + x_edge_grd(jg) = rcss%rcgs%x_edge_src(js) & + + ( rcss%rcgs%x_edge_src(js+1) & + - rcss%rcgs%x_edge_src(js ))*xi + jg = jg + 1 + if (jg > ng) return + enddo + ue_max = max(rcss%uer(js)*u_sgn, rcss%uel(js+1)*u_sgn) + do + if (u_edge_grd(jg)*u_sgn > ue_max) exit + x_edge_grd(jg) = rcss%rcgs%x_edge_src(js+1) + jg = jg + 1 + if (jg > ng) return + enddo + js = js + 1 + enddo + + do + if ((u_edge_grd(jg) - rcss%uer(js))*u_sgn > c0) return + xi = parabola_intersection(rcss%polycoeff(:,js), u_edge_grd(jg), & + rcss%u_eps, c0, c1) + x_edge_grd(jg) = rcss%rcgs%x_edge_src(js) & + + ( rcss%rcgs%x_edge_src(js+1) & + - rcss%rcgs%x_edge_src(js ))*xi + jg = jg + 1 + if (jg > ng) return + enddo + + end subroutine regrid_ppm_method_1 + + pure subroutine regrid_pqm_method_1(rcss, u_sgn, u_edge_grd, x_edge_grd) + + type(recon_src_struct), intent(in) :: rcss + real(r8), dimension(:), intent(in) :: u_edge_grd + real(r8), dimension(:), intent(inout) :: x_edge_grd + real(r8), intent(in) :: u_sgn + + real(r8) :: ue_min, ue_max, xi + integer :: ns, ng, jg, js + + ! Number of source grid cells. + ns = rcss%rcgs%n_src_actual + + ! Number of grid edges. + ng = size(u_edge_grd) + + jg = 1 + do + if ((u_edge_grd(jg) - rcss%uel(1))*u_sgn >= c0) exit + jg = jg + 1 + if (jg > ng) return + enddo + + js = 1 + do + if (js + 1 > ns) exit + ue_min = min(rcss%uer(js)*u_sgn, rcss%uel(js+1)*u_sgn) + do + if (u_edge_grd(jg)*u_sgn >= ue_min) exit + xi = quartic_intersection(rcss%polycoeff(:,js), u_edge_grd(jg), & + rcss%u_eps, c0, c1) + x_edge_grd(jg) = rcss%rcgs%x_edge_src(js) & + + ( rcss%rcgs%x_edge_src(js+1) & + - rcss%rcgs%x_edge_src(js ))*xi + jg = jg + 1 + if (jg > ng) return + enddo + ue_max = max(rcss%uer(js)*u_sgn, rcss%uel(js+1)*u_sgn) + do + if (u_edge_grd(jg)*u_sgn > ue_max) exit + x_edge_grd(jg) = rcss%rcgs%x_edge_src(js+1) + jg = jg + 1 + if (jg > ng) return + enddo + js = js + 1 + enddo + + do + if ((u_edge_grd(jg) - rcss%uer(js))*u_sgn > c0) return + xi = quartic_intersection(rcss%polycoeff(:,js), u_edge_grd(jg), & + rcss%u_eps, c0, c1) + x_edge_grd(jg) = rcss%rcgs%x_edge_src(js) & + + ( rcss%rcgs%x_edge_src(js+1) & + - rcss%rcgs%x_edge_src(js ))*xi + jg = jg + 1 + if (jg > ng) return + enddo + + end subroutine regrid_pqm_method_1 + + pure subroutine regrid_plm_method_2(rcss, u_sgn, u_edge_grd, x_edge_grd) type(recon_src_struct), intent(in) :: rcss real(r8), dimension(:), intent(in) :: u_edge_grd @@ -3071,7 +3260,7 @@ pure subroutine regrid_plm_intersections(rcss, u_sgn, u_edge_grd, x_edge_grd) ! Construct new parabolas left and right of the edge that are ! continuous and smooth across the edge and with the original piecewise - ! parabolas left and right of the edge at the mid points of their + ! lines left and right of the edge at the mid points of their ! respective grid cells. duml = rcss%polycoeff(2,js-1) dumr = rcss%polycoeff(2,js ) @@ -3082,8 +3271,8 @@ pure subroutine regrid_plm_intersections(rcss, u_sgn, u_edge_grd, x_edge_grd) ! If the slope of the new parabolas are non-monotonic at the ! edge, set the edge slope to zero and enforce that the new ! parabolas cross the edge within the interval spanned by the - ! edge values of the original piecewise parabolas. Smoothness - ! with the original piecewise parabolas at grid cell mid points + ! edge values of the original piecewise lines. Smoothness + ! with the original piecewise lines at grid cell mid points ! is then not guaranteed. pcr(2) = c0 uerl = rcss%uer(js-1) @@ -3142,9 +3331,9 @@ pure subroutine regrid_plm_intersections(rcss, u_sgn, u_edge_grd, x_edge_grd) if (jg > ng) return enddo - end subroutine regrid_plm_intersections + end subroutine regrid_plm_method_2 - pure subroutine regrid_ppm_intersections(rcss, u_sgn, u_edge_grd, x_edge_grd) + pure subroutine regrid_ppm_method_2(rcss, u_sgn, u_edge_grd, x_edge_grd) type(recon_src_struct), intent(in) :: rcss real(r8), dimension(:), intent(in) :: u_edge_grd @@ -3272,9 +3461,9 @@ pure subroutine regrid_ppm_intersections(rcss, u_sgn, u_edge_grd, x_edge_grd) if (jg > ng) return enddo - end subroutine regrid_ppm_intersections + end subroutine regrid_ppm_method_2 - pure subroutine regrid_pqm_intersections(rcss, u_sgn, u_edge_grd, x_edge_grd) + pure subroutine regrid_pqm_method_2(rcss, u_sgn, u_edge_grd, x_edge_grd) type(recon_src_struct), intent(in) :: rcss real(r8), dimension(:), intent(in) :: u_edge_grd @@ -3335,7 +3524,7 @@ pure subroutine regrid_pqm_intersections(rcss, u_sgn, u_edge_grd, x_edge_grd) ! Construct new parabolas left and right of the edge that are ! continuous and smooth across the edge and with the original piecewise - ! parabolas left and right of the edge at the mid points of their + ! quartics left and right of the edge at the mid points of their ! respective grid cells. duml = rcss%polycoeff(2,js-1) + rcss%polycoeff(3,js-1) & + c3_4*rcss%polycoeff(4,js-1) + c1_2*rcss%polycoeff(5,js-1) @@ -3348,8 +3537,8 @@ pure subroutine regrid_pqm_intersections(rcss, u_sgn, u_edge_grd, x_edge_grd) ! If the slope of the new parabolas are non-monotonic at the ! edge, set the edge slope to zero and enforce that the new ! parabolas cross the edge within the interval spanned by the - ! edge values of the original piecewise parabolas. Smoothness - ! with the original piecewise parabolas at grid cell mid points + ! edge values of the original piecewise quartics. Smoothness + ! with the original piecewise quartics at grid cell mid points ! is then not guaranteed. pcr(2) = c0 uerl = rcss%uer(js-1) @@ -3408,187 +3597,7 @@ pure subroutine regrid_pqm_intersections(rcss, u_sgn, u_edge_grd, x_edge_grd) if (jg > ng) return enddo - end subroutine regrid_pqm_intersections - - pure subroutine regrid2_plm_intersections(rcss, u_sgn, u_edge_grd, x_edge_grd) - - type(recon_src_struct), intent(in) :: rcss - real(r8), dimension(:), intent(in) :: u_edge_grd - real(r8), dimension(:), intent(inout) :: x_edge_grd - real(r8), intent(in) :: u_sgn - - real(r8) :: ue_min, ue_max, xi - integer :: ns, ng, jg, js - - ! Number of source grid cells. - ns = rcss%rcgs%n_src_actual - - ! Number of grid edges. - ng = size(u_edge_grd) - - jg = 1 - do - if ((u_edge_grd(jg) - rcss%uel(1))*u_sgn >= c0) exit - jg = jg + 1 - if (jg > ng) return - enddo - - js = 1 - do - if (js + 1 > ns) exit - ue_min = min(rcss%uer(js)*u_sgn, rcss%uel(js+1)*u_sgn) - do - if (u_edge_grd(jg)*u_sgn >= ue_min) exit - xi = line_intersection(rcss%polycoeff(:,js), u_edge_grd(jg), & - rcss%u_eps, c0, c1) - x_edge_grd(jg) = rcss%rcgs%x_edge_src(js) & - + ( rcss%rcgs%x_edge_src(js+1) & - - rcss%rcgs%x_edge_src(js ))*xi - jg = jg + 1 - if (jg > ng) return - enddo - ue_max = max(rcss%uer(js)*u_sgn, rcss%uel(js+1)*u_sgn) - do - if (u_edge_grd(jg)*u_sgn > ue_max) exit - x_edge_grd(jg) = rcss%rcgs%x_edge_src(js+1) - jg = jg + 1 - if (jg > ng) return - enddo - js = js + 1 - enddo - - do - if ((u_edge_grd(jg) - rcss%uer(js))*u_sgn > c0) return - xi = line_intersection(rcss%polycoeff(:,js), u_edge_grd(jg), & - rcss%u_eps, c0, c1) - x_edge_grd(jg) = rcss%rcgs%x_edge_src(js) & - + ( rcss%rcgs%x_edge_src(js+1) & - - rcss%rcgs%x_edge_src(js ))*xi - jg = jg + 1 - if (jg > ng) return - enddo - - end subroutine regrid2_plm_intersections - - pure subroutine regrid2_ppm_intersections(rcss, u_sgn, u_edge_grd, x_edge_grd) - - type(recon_src_struct), intent(in) :: rcss - real(r8), dimension(:), intent(in) :: u_edge_grd - real(r8), dimension(:), intent(inout) :: x_edge_grd - real(r8), intent(in) :: u_sgn - - real(r8) :: ue_min, ue_max, xi - integer :: ns, ng, jg, js - - ! Number of source grid cells. - ns = rcss%rcgs%n_src_actual - - ! Number of grid edges. - ng = size(u_edge_grd) - - jg = 1 - do - if ((u_edge_grd(jg) - rcss%uel(1))*u_sgn >= c0) exit - jg = jg + 1 - if (jg > ng) return - enddo - - js = 1 - do - if (js + 1 > ns) exit - ue_min = min(rcss%uer(js)*u_sgn, rcss%uel(js+1)*u_sgn) - do - if (u_edge_grd(jg)*u_sgn >= ue_min) exit - xi = parabola_intersection(rcss%polycoeff(:,js), u_edge_grd(jg), & - rcss%u_eps, c0, c1) - x_edge_grd(jg) = rcss%rcgs%x_edge_src(js) & - + ( rcss%rcgs%x_edge_src(js+1) & - - rcss%rcgs%x_edge_src(js ))*xi - jg = jg + 1 - if (jg > ng) return - enddo - ue_max = max(rcss%uer(js)*u_sgn, rcss%uel(js+1)*u_sgn) - do - if (u_edge_grd(jg)*u_sgn > ue_max) exit - x_edge_grd(jg) = rcss%rcgs%x_edge_src(js+1) - jg = jg + 1 - if (jg > ng) return - enddo - js = js + 1 - enddo - - do - if ((u_edge_grd(jg) - rcss%uer(js))*u_sgn > c0) return - xi = parabola_intersection(rcss%polycoeff(:,js), u_edge_grd(jg), & - rcss%u_eps, c0, c1) - x_edge_grd(jg) = rcss%rcgs%x_edge_src(js) & - + ( rcss%rcgs%x_edge_src(js+1) & - - rcss%rcgs%x_edge_src(js ))*xi - jg = jg + 1 - if (jg > ng) return - enddo - - end subroutine regrid2_ppm_intersections - - pure subroutine regrid2_pqm_intersections(rcss, u_sgn, u_edge_grd, x_edge_grd) - - type(recon_src_struct), intent(in) :: rcss - real(r8), dimension(:), intent(in) :: u_edge_grd - real(r8), dimension(:), intent(inout) :: x_edge_grd - real(r8), intent(in) :: u_sgn - - real(r8) :: ue_min, ue_max, xi - integer :: ns, ng, jg, js - - ! Number of source grid cells. - ns = rcss%rcgs%n_src_actual - - ! Number of grid edges. - ng = size(u_edge_grd) - - jg = 1 - do - if ((u_edge_grd(jg) - rcss%uel(1))*u_sgn >= c0) exit - jg = jg + 1 - if (jg > ng) return - enddo - - js = 1 - do - if (js + 1 > ns) exit - ue_min = min(rcss%uer(js)*u_sgn, rcss%uel(js+1)*u_sgn) - do - if (u_edge_grd(jg)*u_sgn >= ue_min) exit - xi = quartic_intersection(rcss%polycoeff(:,js), u_edge_grd(jg), & - rcss%u_eps, c0, c1) - x_edge_grd(jg) = rcss%rcgs%x_edge_src(js) & - + ( rcss%rcgs%x_edge_src(js+1) & - - rcss%rcgs%x_edge_src(js ))*xi - jg = jg + 1 - if (jg > ng) return - enddo - ue_max = max(rcss%uer(js)*u_sgn, rcss%uel(js+1)*u_sgn) - do - if (u_edge_grd(jg)*u_sgn > ue_max) exit - x_edge_grd(jg) = rcss%rcgs%x_edge_src(js+1) - jg = jg + 1 - if (jg > ng) return - enddo - js = js + 1 - enddo - - do - if ((u_edge_grd(jg) - rcss%uer(js))*u_sgn > c0) return - xi = quartic_intersection(rcss%polycoeff(:,js), u_edge_grd(jg), & - rcss%u_eps, c0, c1) - x_edge_grd(jg) = rcss%rcgs%x_edge_src(js) & - + ( rcss%rcgs%x_edge_src(js+1) & - - rcss%rcgs%x_edge_src(js ))*xi - jg = jg + 1 - if (jg > ng) return - enddo - - end subroutine regrid2_pqm_intersections + end subroutine regrid_pqm_method_2 ! --------------------------------------------------------------------------- ! Public procedures. @@ -3641,7 +3650,7 @@ function initialize_rcgs(rcgs) result(errstat) max(1, min(eb_ord_max_pqm, rcgs%right_bndr_ord)) endif case default - errstat = hor3map_invalid_method + errstat = hor3map_invalid_recon_method return end select @@ -4449,20 +4458,25 @@ function extract_polycoeff(rcss, polycoeff, i_index, j_index) result(errstat) end function extract_polycoeff function regrid(rcss, u_edge_grd, x_edge_grd, missing_value, & - i_index, j_index) & - result(errstat) + i_index, j_index, regrid_method) result(errstat) ! --------------------------------------------------------------------------- ! Find grid locations where desired grid cell edge data values intersect with - ! a reconstruction of the source data. + ! a reconstruction of the source data. The following methods are supported: + ! - Method 1: Find intersections with the piecewise polynomial reconstruction + ! provided in rcss. + ! - Method 2: Find intersections with parabolas constructed to be continuous + ! and smooth across a grid cell edge and with the original + ! piecewise polynomials adjacent of the edge at the mid points of + ! their respective grid cells. ! --------------------------------------------------------------------------- type(recon_src_struct), intent(inout) :: rcss real(r8), dimension(:), intent(in) :: u_edge_grd real(r8), dimension(:), intent(out) :: x_edge_grd real(r8), intent(in) :: missing_value - integer, optional, intent(in) :: i_index, j_index + integer, optional, intent(in) :: i_index, j_index, regrid_method - integer :: errstat + integer :: errstat, regrid_method_resolved real(r8) :: u_sgn @@ -4477,79 +4491,17 @@ function regrid(rcss, u_edge_grd, x_edge_grd, missing_value, & ! Check optional arguments. if (present(i_index)) rcss%rcgs%i_index = i_index if (present(j_index)) rcss%rcgs%j_index = j_index - - ! Assign array pointers within data structures. - errstat = assign_ptr_rcgs(rcss%rcgs) - if (errstat /= hor3map_noerr) return - errstat = assign_ptr_rcss(rcss) - if (errstat /= hor3map_noerr) return - - ! Check that the reconstruction is available. - if (.not. rcss%reconstructed) then - errstat = hor3map_recon_not_available - return - endif - - ! Check grid array size consistency. - if (size(x_edge_grd) /= size(u_edge_grd)) then - errstat = hor3map_grd_size_mismatch - return - endif - - ! Initialize grid intersections as missing value. - x_edge_grd(:) = missing_value - - ! Return in case PCM method is used. - if (rcss%rcgs%method_actual == hor3map_pcm) return - - ! Return in case the source data range is small. - if (rcss%u_range < eps) return - - ! To indicate monotonically increasing or decreasing source values, use - ! the sign of the difference of the source boundary values. - u_sgn = sign(c1, rcss%u_src(rcss%rcgs%n_src_actual) - rcss%u_src(1)) - - select case (rcss%rcgs%method_actual) - case (hor3map_plm) - call regrid_plm_intersections(rcss, u_sgn, u_edge_grd, x_edge_grd) - case (hor3map_ppm) - call regrid_ppm_intersections(rcss, u_sgn, u_edge_grd, x_edge_grd) - case (hor3map_pqm) - call regrid_pqm_intersections(rcss, u_sgn, u_edge_grd, x_edge_grd) - end select - - end function regrid - - function regrid2(rcss, u_edge_grd, x_edge_grd, missing_value, & - i_index, j_index) & - result(errstat) - ! --------------------------------------------------------------------------- - ! Find grid locations where desired grid cell edge data values intersect with - ! a reconstruction of the source data. - ! --------------------------------------------------------------------------- - - type(recon_src_struct), intent(inout) :: rcss - real(r8), dimension(:), intent(in) :: u_edge_grd - real(r8), dimension(:), intent(out) :: x_edge_grd - real(r8), intent(in) :: missing_value - integer, optional, intent(in) :: i_index, j_index - - integer :: errstat - - real(r8) :: u_sgn - - errstat = hor3map_noerr - - ! Check that reconstruction source data structure has been initialized. - if (.not. rcss%initialized) then - errstat = hor3map_recon_not_available - return + if (present(regrid_method)) then + if (regrid_method /= hor3map_regrid_method_1 .and. & + regrid_method /= hor3map_regrid_method_2) then + errstat = hor3map_invalid_regrid_method + return + endif + regrid_method_resolved = regrid_method + else + regrid_method_resolved = hor3map_regrid_method_1 endif - ! Check optional arguments. - if (present(i_index)) rcss%rcgs%i_index = i_index - if (present(j_index)) rcss%rcgs%j_index = j_index - ! Assign array pointers within data structures. errstat = assign_ptr_rcgs(rcss%rcgs) if (errstat /= hor3map_noerr) return @@ -4581,16 +4533,27 @@ function regrid2(rcss, u_edge_grd, x_edge_grd, missing_value, & ! the sign of the difference of the source boundary values. u_sgn = sign(c1, rcss%u_src(rcss%rcgs%n_src_actual) - rcss%u_src(1)) - select case (rcss%rcgs%method_actual) - case (hor3map_plm) - call regrid2_plm_intersections(rcss, u_sgn, u_edge_grd, x_edge_grd) - case (hor3map_ppm) - call regrid2_ppm_intersections(rcss, u_sgn, u_edge_grd, x_edge_grd) - case (hor3map_pqm) - call regrid2_pqm_intersections(rcss, u_sgn, u_edge_grd, x_edge_grd) - end select + if (regrid_method_resolved == hor3map_regrid_method_1) then + select case (rcss%rcgs%method_actual) + case (hor3map_plm) + call regrid_plm_method_1(rcss, u_sgn, u_edge_grd, x_edge_grd) + case (hor3map_ppm) + call regrid_ppm_method_1(rcss, u_sgn, u_edge_grd, x_edge_grd) + case (hor3map_pqm) + call regrid_pqm_method_1(rcss, u_sgn, u_edge_grd, x_edge_grd) + end select + else + select case (rcss%rcgs%method_actual) + case (hor3map_plm) + call regrid_plm_method_2(rcss, u_sgn, u_edge_grd, x_edge_grd) + case (hor3map_ppm) + call regrid_ppm_method_2(rcss, u_sgn, u_edge_grd, x_edge_grd) + case (hor3map_pqm) + call regrid_pqm_method_2(rcss, u_sgn, u_edge_grd, x_edge_grd) + end select + endif - end function regrid2 + end function regrid function remap(rcss, rms, u_dst, i_index, j_index) result(errstat) ! --------------------------------------------------------------------------- diff --git a/phy/mod_idarlx.F90 b/phy/mod_idarlx.F90 index aa50f3c6..0ffc1828 100644 --- a/phy/mod_idarlx.F90 +++ b/phy/mod_idarlx.F90 @@ -40,8 +40,7 @@ subroutine idarlx() ! Local varaibles real, dimension(itdm,jtdm) :: tmp2d - integer :: i,j,k - integer :: nfu + integer :: nfu,i,j,k if (aptflx) then if (mnproc == 1) then diff --git a/phy/mod_inicon.F90 b/phy/mod_inicon.F90 index a01ab796..712f9442 100644 --- a/phy/mod_inicon.F90 +++ b/phy/mod_inicon.F90 @@ -36,10 +36,10 @@ module mod_inicon mnproc, lp, ii, jj, kk, isp, ifp, ilp, & isu, ifu, ilu, isv, ifv, ilv, isq, ifq, ilq, & i0, j0, ip, iu, iv, iq, halo_ps, nbdy - use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, & - cntiso_hybrid, sigmar, & - cntiso_hybrid_regrid_direct_remap, & - remap_velocity + use mod_vcoord, only: vcoord_tag, vcoord_isopyc_bulkml, & + vcoord_cntiso_hybrid, sigref_spec, sigmar + use mod_ale_regrid_remap, only: regrid_method_tag, regrid_method_direct, & + ale_regrid_remap use mod_grid, only: scuy, scvx, scuyi, scvxi, depths, & corioq use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma, p, pu, & @@ -74,9 +74,6 @@ module mod_inicon ! Public routines public :: inicon - ! Private routines - private :: getpl, ictsz_file - contains ! ------------------------------------------------------------------ @@ -139,7 +136,7 @@ subroutine ictsz_file real :: dsig,a0,a1,a2 integer, dimension(3) :: start,count integer :: i,j,kdmic,k,l,status,ncid,dimid,varid,kb - real :: im_mks2cgs + real :: iM_mks2cgs iM_mks2cgs = 1.0 / M_mks2cgs @@ -197,9 +194,10 @@ subroutine ictsz_file call xchalt('(ictsz_file)') stop '(ictsz_file)' end if - if (i /= itdm.or.j /= jtdm.or. & - (kdmic /= kdm.and.vcoord_type_tag /= cntiso_hybrid).or. & - (kdmic > kdm.and.vcoord_type_tag == cntiso_hybrid)) then + if (i /= itdm .or. j /= jtdm .or. & + (kdmic /= kdm .and. vcoord_tag == vcoord_isopyc_bulkml) .or. & + (kdmic > kdm .and. vcoord_tag == vcoord_cntiso_hybrid .and. & + trim(sigref_spec) == 'inicon')) then write (lp,*) 'wrong dimensions in '//trim(icfile) call xchalt('(ictsz_file)') stop '(ictsz_file)' @@ -216,28 +214,32 @@ subroutine ictsz_file count(3) = 1 ! Read reference potential density - if (mnproc == 1) then - status = nf90_inq_varid(ncid,'sigma',varid) - if (status /= nf90_noerr) then - write(lp,'(2a)') ' nf90_inq_varid: sigma: ', & - nf90_strerror(status) - call xchalt('(ictsz_file)') - stop '(ictsz_file)' - end if - end if - do k = 1,kdmic + if ( vcoord_tag == vcoord_isopyc_bulkml .or. & + (vcoord_tag == vcoord_cntiso_hybrid .and. & + trim(sigref_spec) == 'inicon')) then if (mnproc == 1) then - start(3) = k - status = nf90_get_var(ncid,varid,tmp2d,start,count) + status = nf90_inq_varid(ncid,'sigma',varid) if (status /= nf90_noerr) then - write(lp,'(2a)') ' nf90_get_var: sigma: ', & + write(lp,'(2a)') ' nf90_inq_varid: sigma: ', & nf90_strerror(status) call xchalt('(ictsz_file)') stop '(ictsz_file)' end if end if - call xcaput(tmp2d,sigmar(1-nbdy,1-nbdy,k),1) - end do + do k = 1,kdmic + if (mnproc == 1) then + start(3) = k + status = nf90_get_var(ncid,varid,tmp2d,start,count) + if (status /= nf90_noerr) then + write(lp,'(2a)') ' nf90_get_var: sigma: ', & + nf90_strerror(status) + call xchalt('(ictsz_file)') + stop '(ictsz_file)' + end if + end if + call xcaput(tmp2d,sigmar(1-nbdy,1-nbdy,k),1) + end do + end if ! Read potential temperature if (mnproc == 1) then @@ -319,7 +321,8 @@ subroutine ictsz_file end if end if - if (vcoord_type_tag == cntiso_hybrid) then + if (vcoord_tag == vcoord_cntiso_hybrid .and. & + trim(sigref_spec) == 'inicon') then !$omp parallel do private(l,i,k,kb,dsig,a0,a1,a2) do j = 1,jj do l = 1,isp(j) @@ -402,15 +405,23 @@ subroutine ictsz_file z(i,j,kk+1) = depths(i,j)*L_mks2cgs end do end do - do k = 1,kk - do l = 1,isp(j) - do i = max(1,ifp(j,l)),min(ii,ilp(j,l)) - sigmar(i,j,k) = sigmar(i,j,k)*iM_mks2cgs + end do + !$omp end parallel do + if ( vcoord_tag == vcoord_isopyc_bulkml .or. & + (vcoord_tag == vcoord_cntiso_hybrid .and. & + trim(sigref_spec) == 'inicon')) then + !$omp parallel do private(k,l,i) + do j = 1,jj + do k = 1,kk + do l = 1,isp(j) + do i = max(1,ifp(j,l)),min(ii,ilp(j,l)) + sigmar(i,j,k) = sigmar(i,j,k)*iM_mks2cgs + end do end do end do end do - end do - !$omp end parallel do + !$omp end parallel do + end if ! compute layer interface geopotential !$omp parallel do private(k,l,i) @@ -438,7 +449,7 @@ subroutine inicon() ! Local variables real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: tfrz - integer :: i,j,k,l + integer :: i,j,k,l,regrid_method_tag_orig real :: q,tsfac,dps ! ------------------------------------------------------------------ @@ -488,61 +499,53 @@ subroutine inicon() ! variables consistent. ! ------------------------------------------------------------------ - select case (vcoord_type_tag) + select case (vcoord_tag) - case (isopyc_bulkml) + case (vcoord_isopyc_bulkml) - do k = 1,2 - tfrz(1:ii,1:jj) = swtfrz(p(1:ii,1:jj,1),saln(1:ii,1:jj,k)) - !$omp parallel do private(l,i) - do j = 1,jj - do l = 1,isp(j) - do i = max(1,ifp(j,l)),min(ii,ilp(j,l)) - temp(i,j,k) = max(tfrz(i,j),temp(i,j,k)) - sigma(i,j,k) = sig(temp(i,j,k),saln(i,j,k)) + do k = 1,2 + tfrz(1:ii,1:jj) = swtfrz(p(1:ii,1:jj,1),saln(1:ii,1:jj,k)) + !$omp parallel do private(l,i) + do j = 1,jj + do l = 1,isp(j) + do i = max(1,ifp(j,l)),min(ii,ilp(j,l)) + temp(i,j,k) = max(tfrz(i,j),temp(i,j,k)) + sigma(i,j,k) = sig(temp(i,j,k),saln(i,j,k)) + end do end do end do - end do - !$omp end parallel do - end do - do k = 3,kk - tfrz(1:ii,1:jj) = swtfrz(p(1:ii,1:jj,1),saln(1:ii,1:jj,k)) - !$omp parallel do private(l,i) - do j = 1,jj - do l = 1,isp(j) - do i = max(1,ifp(j,l)),min(ii,ilp(j,l)) - temp(i,j,k) = max(tfrz(i,j),temp(i,j,k)) - saln(i,j,k) = sofsig(sigmar(i,j,k),temp(i,j,k)) - sigma(i,j,k) = sig(temp(i,j,k),saln(i,j,k)) + !$omp end parallel do + end do + do k = 3,kk + tfrz(1:ii,1:jj) = swtfrz(p(1:ii,1:jj,1),saln(1:ii,1:jj,k)) + !$omp parallel do private(l,i) + do j = 1,jj + do l = 1,isp(j) + do i = max(1,ifp(j,l)),min(ii,ilp(j,l)) + temp(i,j,k) = max(tfrz(i,j),temp(i,j,k)) + saln(i,j,k) = sofsig(sigmar(i,j,k),temp(i,j,k)) + sigma(i,j,k) = sig(temp(i,j,k),saln(i,j,k)) + end do end do end do + !$omp end parallel do end do - !$omp end parallel do - end do - case (cntiso_hybrid) + case default - do k = 1,kk - tfrz(1:ii,1:jj) = swtfrz(p(1:ii,1:jj,1),saln(1:ii,1:jj,k)) - !$omp parallel do private(l,i) - do j = 1,jj - do l = 1,isp(j) - do i = max(1,ifp(j,l)),min(ii,ilp(j,l)) - temp(i,j,k) = max(tfrz(i,j),temp(i,j,k)) - sigma(i,j,k) = sig(temp(i,j,k),saln(i,j,k)) + do k = 1,kk + tfrz(1:ii,1:jj) = swtfrz(p(1:ii,1:jj,1),saln(1:ii,1:jj,k)) + !$omp parallel do private(l,i) + do j = 1,jj + do l = 1,isp(j) + do i = max(1,ifp(j,l)),min(ii,ilp(j,l)) + temp(i,j,k) = max(tfrz(i,j),temp(i,j,k)) + sigma(i,j,k) = sig(temp(i,j,k),saln(i,j,k)) + end do end do end do + !$omp end parallel do end do - !$omp end parallel do - end do - - case default - - if (mnproc == 1) then - write (lp,*) 'inicon: unsupported vertical coordinate!' - end if - call xcstop('(inicon)') - stop '(inicon)' end select @@ -662,9 +665,11 @@ subroutine inicon() end do !$omp end parallel do - if (vcoord_type_tag == cntiso_hybrid) then - call cntiso_hybrid_regrid_direct_remap(2,1,kk,0,kk+1,1) - call remap_velocity(2,1,kk,0,kk+1,1) + if (vcoord_tag /= vcoord_isopyc_bulkml) then + regrid_method_tag_orig = regrid_method_tag + regrid_method_tag = regrid_method_direct + call ale_regrid_remap(2,1,kk,0,kk+1,1) + regrid_method_tag = regrid_method_tag_orig end if call xctilr(temp, 1,kk, 1,1, halo_ps) call xctilr(saln, 1,kk, 1,1, halo_ps) diff --git a/phy/mod_iniphy.F90 b/phy/mod_iniphy.F90 index 37c36578..31baac22 100644 --- a/phy/mod_iniphy.F90 +++ b/phy/mod_iniphy.F90 @@ -22,7 +22,7 @@ module mod_iniphy use mod_config, only: expcnf use mod_xc, only: lp, mnproc, xcstop - use mod_vcoord, only: vcoord_type_tag, cntiso_hybrid + use mod_vcoord, only: vcoord_tag, vcoord_isopyc_bulkml use mod_tidaldissip, only: read_tidaldissip use mod_difest, only: init_difest use mod_eddtra, only: init_eddtra @@ -55,7 +55,7 @@ subroutine iniphy stop '(iniphy)' end if - if (vcoord_type_tag == cntiso_hybrid) then + if (vcoord_tag /= vcoord_isopyc_bulkml) then call init_difest end if diff --git a/phy/mod_momtum.F90 b/phy/mod_momtum.F90 index 541c3bf1..62e9f219 100644 --- a/phy/mod_momtum.F90 +++ b/phy/mod_momtum.F90 @@ -30,7 +30,7 @@ module mod_momtum onem, onemm use mod_time, only: delt1, dlt use mod_xc - use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml + use mod_vcoord, only: vcoord_tag, vcoord_isopyc_bulkml use mod_grid, only: scqx, scqy, scpx, scpy, scux, scuy, & scvx, scvy, scp2, scu2, scv2, scq2i, scp2i, & scuxi, scvyi, corioq @@ -936,7 +936,7 @@ subroutine momtum(m,n,mm,nn,k1m,k1n) ! store wind forcing in -stress- - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then if (k == 1) then do j = 1,jj do l = 1,isu(j) @@ -1099,7 +1099,7 @@ subroutine momtum(m,n,mm,nn,k1m,k1n) ! store wind forcing in -stress- - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then if (k == 1) then do j = 1,jj do l = 1,isv(j) diff --git a/phy/mod_ndiff.F90 b/phy/mod_ndiff.F90 index 6da01e96..1f5298d5 100644 --- a/phy/mod_ndiff.F90 +++ b/phy/mod_ndiff.F90 @@ -18,9 +18,9 @@ ! ------------------------------------------------------------------------------ module mod_ndiff - ! ------------------------------------------------------------------------------ - ! This module contains procedures for solving vertical diffusion equations. - ! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ +! This module contains procedures for solving vertical diffusion equations. +! ------------------------------------------------------------------------------ use mod_types, only: r8 use mod_constants, only: g, alpha0, epsilp, onemm, P_mks2cgs, R_mks2cgs @@ -32,7 +32,6 @@ module mod_ndiff use mod_diffusion, only: difiso, utflld, vtflld, usflld, vsflld use mod_cmnfld, only: nslpx, nslpy use mod_tracers, only: trc - use mod_ifdefs, only: use_TRC implicit none private @@ -55,9 +54,9 @@ module mod_ndiff contains - ! --------------------------------------------------------------------------- + ! ---------------------------------------------------------------------------- ! Private procedures. - ! --------------------------------------------------------------------------- + ! ---------------------------------------------------------------------------- pure function peval(pc, x) result(f) ! ---------------------------------------------------------------------------- @@ -163,9 +162,9 @@ pure subroutine ndiff_flx(p_srcdi_m, t_srcdi_m, tpc_src_m, & p_srcdi_p, t_srcdi_p, tpc_src_p, & drhodt_srcdi_p, drhods_srcdi_p, & p_dst_p, ksmx_p, kdmx_p, & - cdiff, cnslp, puv, flxconv_rs, & + cdiff, cnslp, puv, flxconv_js, & uvtflld, uvsflld, uvtflx, uvsflx, nslpxy, & - ntr_loc, i_m, j_m, i_p, j_p, j_rs_m, j_rs_p, mm, nn) + ntr_loc, i_m, j_m, i_p, j_p, js_m, js_p, mm, nn) real(r8), dimension(:,:), intent(in) :: & p_srcdi_m, drhodt_srcdi_m, drhods_srcdi_m, & @@ -177,7 +176,7 @@ pure subroutine ndiff_flx(p_srcdi_m, t_srcdi_m, tpc_src_m, & real(r8), dimension(1-nbdy:,1-nbdy:,:), intent(in) :: & puv real(r8), dimension(:,:,1-nbdy:,:), intent(inout) :: & - flxconv_rs + flxconv_js real(r8), dimension(1-nbdy:,1-nbdy:,:), intent(inout) :: & uvtflld, uvsflld, uvtflx, uvsflx real(r8), dimension(1-nbdy:,1-nbdy:,:), intent(out) :: & @@ -185,7 +184,7 @@ pure subroutine ndiff_flx(p_srcdi_m, t_srcdi_m, tpc_src_m, & real(r8), intent(in) :: cdiff, cnslp integer, intent(in) :: & ksmx_m, ksmx_p, kdmx_m, kdmx_p, ntr_loc, i_m, j_m, i_p, j_p, & - j_rs_m, j_rs_p, mm, nn + js_m, js_p, mm, nn real(r8), dimension(4*(kk+1)) :: nslp_src, p_nslp_src real(r8), dimension(2,kk) :: p_ni_srcdi_m, p_ni_srcdi_p @@ -764,15 +763,11 @@ pure subroutine ndiff_flx(p_srcdi_m, t_srcdi_m, tpc_src_m, & ds*( t_ni_m(is,nip) - t_ni_p(is,nip)) >= 0._r8 .and. & ds*( t_ni_m(is,nic) - t_ni_p(is,nic)) >= 0._r8) then tflx = q*dt - flxconv_rs(kd_m,it,i_m,j_rs_m) = flxconv_rs(kd_m,it,i_m,j_rs_m) & - + tflx - flxconv_rs(kd_p,it,i_p,j_rs_p) = flxconv_rs(kd_p,it,i_p,j_rs_p) & - - tflx + flxconv_js(kd_m,it,i_m,js_m) = flxconv_js(kd_m,it,i_m,js_m) + tflx + flxconv_js(kd_p,it,i_p,js_p) = flxconv_js(kd_p,it,i_p,js_p) - tflx sflx = q*ds - flxconv_rs(kd_m,is,i_m,j_rs_m) = flxconv_rs(kd_m,is,i_m,j_rs_m) & - + sflx - flxconv_rs(kd_p,is,i_p,j_rs_p) = flxconv_rs(kd_p,is,i_p,j_rs_p) & - - sflx + flxconv_js(kd_m,is,i_m,js_m) = flxconv_js(kd_m,is,i_m,js_m) + sflx + flxconv_js(kd_p,is,i_p,js_p) = flxconv_js(kd_p,is,i_p,js_p) - sflx p_ni_up = .5_r8*(p_ni_m(nip) + p_ni_p(nip)) p_ni_lo = .5_r8*(p_ni_m(nic) + p_ni_p(nic)) dp_ni_i = 1._r8/max(epsilp, p_ni_lo - p_ni_up) @@ -797,21 +792,17 @@ pure subroutine ndiff_flx(p_srcdi_m, t_srcdi_m, tpc_src_m, & enddo endif - if (use_TRC) then - do nt = 3, ntr_loc - dt = t_nl_m(nt) - t_nl_p(nt) - if (dt*( trc(i_m,j_m,ks_m+nn,nt-2) & - - trc(i_p,j_p,ks_p+nn,nt-2)) >= 0._r8 .and. & - dt*( t_ni_m(nt,nip) - t_ni_p(nt,nip)) >= 0._r8 .and. & - dt*( t_ni_m(nt,nic) - t_ni_p(nt,nic)) >= 0._r8) then - tflx = q*dt - flxconv_rs(kd_m,nt,i_m,j_rs_m) = & - flxconv_rs(kd_m,nt,i_m,j_rs_m) + tflx - flxconv_rs(kd_p,nt,i_p,j_rs_p) = & - flxconv_rs(kd_p,nt,i_p,j_rs_p) - tflx - endif - enddo - end if + do nt = 3, ntr_loc + dt = t_nl_m(nt) - t_nl_p(nt) + if (dt*( trc(i_m,j_m,ks_m+nn,nt-2) & + - trc(i_p,j_p,ks_p+nn,nt-2)) >= 0._r8 .and. & + dt*( t_ni_m(nt,nip) - t_ni_p(nt,nip)) >= 0._r8 .and. & + dt*( t_ni_m(nt,nic) - t_ni_p(nt,nic)) >= 0._r8) then + tflx = q*dt + flxconv_js(kd_m,nt,i_m,js_m) = flxconv_js(kd_m,nt,i_m,js_m) + tflx + flxconv_js(kd_p,nt,i_p,js_p) = flxconv_js(kd_p,nt,i_p,js_p) - tflx + endif + enddo endif @@ -854,57 +845,57 @@ pure subroutine ndiff_flx(p_srcdi_m, t_srcdi_m, tpc_src_m, & end subroutine ndiff_flx - ! --------------------------------------------------------------------------- + ! ---------------------------------------------------------------------------- ! Public procedures. - ! --------------------------------------------------------------------------- - - subroutine ndiff_prep_jslice(p_src_rs, ksmx_rs, & - tpc_src_rs, t_srcdi_rs, & - p_dst_rs, kdmx_rs, p_srcdi_rs, & - drhodt_srcdi_rs, drhods_srcdi_rs, & - flxconv_rs, & - i_lb, i_ub, j, j_rs, mm) - - real(r8), dimension(:,1-nbdy:,:), intent(in) :: p_src_rs, p_dst_rs - integer, dimension(1-nbdy:,:), intent(in) :: ksmx_rs - integer, dimension(1-nbdy:,:), intent(out) :: kdmx_rs - real(r8), dimension(:,:,:,1-nbdy:,:), intent(in) :: tpc_src_rs, t_srcdi_rs + ! ---------------------------------------------------------------------------- + + subroutine ndiff_prep_jslice(p_src_js, ksmx_js, & + tpc_src_js, t_srcdi_js, & + p_dst_js, kdmx_js, p_srcdi_js, & + drhodt_srcdi_js, drhods_srcdi_js, & + flxconv_js, & + ilb, iub, j, js, mm) + + real(r8), dimension(:,1-nbdy:,:), intent(in) :: p_src_js, p_dst_js + integer, dimension(1-nbdy:,:), intent(in) :: ksmx_js + integer, dimension(1-nbdy:,:), intent(out) :: kdmx_js + real(r8), dimension(:,:,:,1-nbdy:,:), intent(in) :: tpc_src_js, t_srcdi_js real(r8), dimension(:,:,1-nbdy:,:), intent(out) :: & - p_srcdi_rs, drhodt_srcdi_rs, drhods_srcdi_rs, flxconv_rs - integer, intent(in) :: i_lb, i_ub, j, j_rs, mm + p_srcdi_js, drhodt_srcdi_js, drhods_srcdi_js, flxconv_js + integer, intent(in) :: ilb, iub, j, js, mm integer :: l, i, nt, k, km, errstat do l = 1, isp(j) - do i = max(i_lb, ifp(j, l)), min(i_ub, ilp(j, l)) + do i = max(ilb, ifp(j, l)), min(iub, ilp(j, l)) ! Find index of deepest destination layer with non-zero thickness. - kdmx_rs(i,j_rs) = kk + kdmx_js(i,js) = kk do k = kk, 1, -1 - if (p_dst_rs(k,i,j_rs) == p_dst_rs(kk+1,i,j_rs)) & - kdmx_rs(i,j_rs) = k - 1 + if (p_dst_js(k,i,js) == p_dst_js(kk+1,i,js)) & + kdmx_js(i,js) = k - 1 enddo ! Store variables in dual interface arrays with with values ! corresponding to upper and lower interface of each layer. - do k = 1, ksmx_rs(i,j_rs) - p_srcdi_rs(1,k,i,j_rs) = p_src_rs(k ,i,j_rs) - p_srcdi_rs(2,k,i,j_rs) = p_src_rs(k+1,i,j_rs) - drhodt_srcdi_rs(1,k,i,j_rs) = drhodt(p_srcdi_rs(1,k ,i,j_rs), & - t_srcdi_rs(1,k,it,i,j_rs), & - t_srcdi_rs(1,k,is,i,j_rs)) - drhodt_srcdi_rs(2,k,i,j_rs) = drhodt(p_srcdi_rs(2,k ,i,j_rs), & - t_srcdi_rs(2,k,it,i,j_rs), & - t_srcdi_rs(2,k,is,i,j_rs)) - drhods_srcdi_rs(1,k,i,j_rs) = drhods(p_srcdi_rs(1,k ,i,j_rs), & - t_srcdi_rs(1,k,it,i,j_rs), & - t_srcdi_rs(1,k,is,i,j_rs)) - drhods_srcdi_rs(2,k,i,j_rs) = drhods(p_srcdi_rs(2,k ,i,j_rs), & - t_srcdi_rs(2,k,it,i,j_rs), & - t_srcdi_rs(2,k,is,i,j_rs)) + do k = 1, ksmx_js(i,js) + p_srcdi_js(1,k,i,js) = p_src_js(k ,i,js) + p_srcdi_js(2,k,i,js) = p_src_js(k+1,i,js) + drhodt_srcdi_js(1,k,i,js) = drhodt(p_srcdi_js(1,k ,i,js), & + t_srcdi_js(1,k,it,i,js), & + t_srcdi_js(1,k,is,i,js)) + drhodt_srcdi_js(2,k,i,js) = drhodt(p_srcdi_js(2,k ,i,js), & + t_srcdi_js(2,k,it,i,js), & + t_srcdi_js(2,k,is,i,js)) + drhods_srcdi_js(1,k,i,js) = drhods(p_srcdi_js(1,k ,i,js), & + t_srcdi_js(1,k,it,i,js), & + t_srcdi_js(1,k,is,i,js)) + drhods_srcdi_js(2,k,i,js) = drhods(p_srcdi_js(2,k ,i,js), & + t_srcdi_js(2,k,it,i,js), & + t_srcdi_js(2,k,is,i,js)) enddo - flxconv_rs(:,:,i,j_rs) = 0._r8 + flxconv_js(:,:,i,js) = 0._r8 enddo enddo @@ -912,13 +903,13 @@ subroutine ndiff_prep_jslice(p_src_rs, ksmx_rs, & do k = 1, kk km = k + mm do l = 1, isu(j) - do i = max(i_lb, ifu(j, l)), min(i_ub, ilu(j, l)) + do i = max(ilb, ifu(j, l)), min(iub, ilu(j, l)) utflld(i,j,km) = 0._r8 usflld(i,j,km) = 0._r8 enddo enddo do l = 1, isv(j) - do i = max(i_lb, ifv(j, l)), min(i_ub, ilv(j, l)) + do i = max(ilb, ifv(j, l)), min(iub, ilv(j, l)) vtflld(i,j,km) = 0._r8 vsflld(i,j,km) = 0._r8 enddo @@ -927,20 +918,20 @@ subroutine ndiff_prep_jslice(p_src_rs, ksmx_rs, & end subroutine ndiff_prep_jslice - subroutine ndiff_uflx_jslice(ksmx_rs, tpc_src_rs, t_srcdi_rs, & - p_dst_rs, kdmx_rs, p_srcdi_rs, & - drhodt_srcdi_rs, drhods_srcdi_rs, & - flxconv_rs, & - ntr_loc, i_lb, i_ub, j, j_rs, mm, nn) + subroutine ndiff_uflx_jslice(ksmx_js, tpc_src_js, t_srcdi_js, & + p_dst_js, kdmx_js, p_srcdi_js, & + drhodt_srcdi_js, drhods_srcdi_js, & + flxconv_js, & + ntr_loc, ilb, iub, j, js, mm, nn) - integer, dimension(1-nbdy:,:), intent(in) :: ksmx_rs, kdmx_rs + integer, dimension(1-nbdy:,:), intent(in) :: ksmx_js, kdmx_js real(r8), dimension(:,:,:,1-nbdy:,:), target, intent(in) :: & - tpc_src_rs, t_srcdi_rs - real(r8), dimension(:,1-nbdy:,:), target, intent(in) :: p_dst_rs + tpc_src_js, t_srcdi_js + real(r8), dimension(:,1-nbdy:,:), target, intent(in) :: p_dst_js real(r8), dimension(:,:,1-nbdy:,:), target, intent(in) :: & - p_srcdi_rs, drhodt_srcdi_rs, drhods_srcdi_rs - real(r8), dimension(:,:,1-nbdy:,:), intent(inout) :: flxconv_rs - integer, intent(in) :: ntr_loc, i_lb, i_ub, j, j_rs, mm, nn + p_srcdi_js, drhodt_srcdi_js, drhods_srcdi_js + real(r8), dimension(:,:,1-nbdy:,:), intent(inout) :: flxconv_js + integer, intent(in) :: ntr_loc, ilb, iub, j, js, mm, nn real(r8), dimension(:,:,:), pointer :: & t_srcdi_m, tpc_src_m, t_srcdi_p, tpc_src_p @@ -953,24 +944,24 @@ subroutine ndiff_uflx_jslice(ksmx_rs, tpc_src_rs, t_srcdi_rs, & integer :: l, i, ksmx_m, ksmx_p, kdmx_m, kdmx_p do l = 1, isu(j) - do i = max(i_lb, ifu(j, l)), min(i_ub, ilu(j, l)) - - p_srcdi_m => p_srcdi_rs(:,:,i-1,j_rs) - p_srcdi_p => p_srcdi_rs(:,:,i ,j_rs) - t_srcdi_m => t_srcdi_rs(:,:,:,i-1,j_rs) - t_srcdi_p => t_srcdi_rs(:,:,:,i ,j_rs) - tpc_src_m => tpc_src_rs(:,:,:,i-1,j_rs) - tpc_src_p => tpc_src_rs(:,:,:,i ,j_rs) - drhodt_srcdi_m => drhodt_srcdi_rs(:,:,i-1,j_rs) - drhodt_srcdi_p => drhodt_srcdi_rs(:,:,i ,j_rs) - drhods_srcdi_m => drhods_srcdi_rs(:,:,i-1,j_rs) - drhods_srcdi_p => drhods_srcdi_rs(:,:,i ,j_rs) - p_dst_m => p_dst_rs(:,i-1,j_rs) - p_dst_p => p_dst_rs(:,i ,j_rs) - ksmx_m = ksmx_rs(i-1,j_rs) - ksmx_p = ksmx_rs(i ,j_rs) - kdmx_m = kdmx_rs(i-1,j_rs) - kdmx_p = kdmx_rs(i ,j_rs) + do i = max(ilb, ifu(j, l)), min(iub, ilu(j, l)) + + p_srcdi_m => p_srcdi_js(:,:,i-1,js) + p_srcdi_p => p_srcdi_js(:,:,i ,js) + t_srcdi_m => t_srcdi_js(:,:,:,i-1,js) + t_srcdi_p => t_srcdi_js(:,:,:,i ,js) + tpc_src_m => tpc_src_js(:,:,:,i-1,js) + tpc_src_p => tpc_src_js(:,:,:,i ,js) + drhodt_srcdi_m => drhodt_srcdi_js(:,:,i-1,js) + drhodt_srcdi_p => drhodt_srcdi_js(:,:,i ,js) + drhods_srcdi_m => drhods_srcdi_js(:,:,i-1,js) + drhods_srcdi_p => drhods_srcdi_js(:,:,i ,js) + p_dst_m => p_dst_js(:,i-1,js) + p_dst_p => p_dst_js(:,i ,js) + ksmx_m = ksmx_js(i-1,js) + ksmx_p = ksmx_js(i ,js) + kdmx_m = kdmx_js(i-1,js) + kdmx_p = kdmx_js(i ,js) cdiff = delt1*scuy(i,j)*scuxi(i,j) cnslp = alpha0*scuxi(i,j)/g @@ -980,29 +971,29 @@ subroutine ndiff_uflx_jslice(ksmx_rs, tpc_src_rs, t_srcdi_rs, & p_srcdi_p, t_srcdi_p, tpc_src_p, & drhodt_srcdi_p, drhods_srcdi_p, & p_dst_p, ksmx_p, kdmx_p, & - cdiff, cnslp, pu, flxconv_rs, & + cdiff, cnslp, pu, flxconv_js, & utflld, usflld, utflx, usflx, nslpx, & - ntr_loc, i-1, j, i, j, j_rs, j_rs, mm, nn) + ntr_loc, i-1, j, i, j, js, js, mm, nn) enddo enddo end subroutine ndiff_uflx_jslice - subroutine ndiff_vflx_jslice(ksmx_rs, tpc_src_rs, t_srcdi_rs, & - p_dst_rs, kdmx_rs, p_srcdi_rs, & - drhodt_srcdi_rs, drhods_srcdi_rs, & - flxconv_rs, & - ntr_loc, i_lb, i_ub, j, j_rs_m, j_rs_p, mm, nn) + subroutine ndiff_vflx_jslice(ksmx_js, tpc_src_js, t_srcdi_js, & + p_dst_js, kdmx_js, p_srcdi_js, & + drhodt_srcdi_js, drhods_srcdi_js, & + flxconv_js, & + ntr_loc, ilb, iub, j, js_m, js_p, mm, nn) - integer, dimension(1-nbdy:,:), intent(in) :: ksmx_rs, kdmx_rs + integer, dimension(1-nbdy:,:), intent(in) :: ksmx_js, kdmx_js real(r8), dimension(:,:,:,1-nbdy:,:), target, intent(in) :: & - tpc_src_rs, t_srcdi_rs - real(r8), dimension(:,1-nbdy:,:), target, intent(in) :: p_dst_rs + tpc_src_js, t_srcdi_js + real(r8), dimension(:,1-nbdy:,:), target, intent(in) :: p_dst_js real(r8), dimension(:,:,1-nbdy:,:), target, intent(in) :: & - p_srcdi_rs, drhodt_srcdi_rs, drhods_srcdi_rs - real(r8), dimension(:,:,1-nbdy:,:), intent(inout) :: flxconv_rs - integer, intent(in) :: ntr_loc, i_lb, i_ub, j, j_rs_m, j_rs_p, mm, nn + p_srcdi_js, drhodt_srcdi_js, drhods_srcdi_js + real(r8), dimension(:,:,1-nbdy:,:), intent(inout) :: flxconv_js + integer, intent(in) :: ntr_loc, ilb, iub, j, js_m, js_p, mm, nn real(r8), dimension(:,:,:), pointer :: & t_srcdi_m, tpc_src_m, t_srcdi_p, tpc_src_p @@ -1015,24 +1006,24 @@ subroutine ndiff_vflx_jslice(ksmx_rs, tpc_src_rs, t_srcdi_rs, & integer :: l, i, ksmx_m, ksmx_p, kdmx_m, kdmx_p do l = 1, isv(j) - do i = max(i_lb, ifv(j, l)), min(i_ub, ilv(j, l)) - - p_srcdi_m => p_srcdi_rs(:,:,i,j_rs_m) - p_srcdi_p => p_srcdi_rs(:,:,i,j_rs_p) - t_srcdi_m => t_srcdi_rs(:,:,:,i,j_rs_m) - t_srcdi_p => t_srcdi_rs(:,:,:,i,j_rs_p) - tpc_src_m => tpc_src_rs(:,:,:,i,j_rs_m) - tpc_src_p => tpc_src_rs(:,:,:,i,j_rs_p) - drhodt_srcdi_m => drhodt_srcdi_rs(:,:,i,j_rs_m) - drhodt_srcdi_p => drhodt_srcdi_rs(:,:,i,j_rs_p) - drhods_srcdi_m => drhods_srcdi_rs(:,:,i,j_rs_m) - drhods_srcdi_p => drhods_srcdi_rs(:,:,i,j_rs_p) - p_dst_m => p_dst_rs(:,i,j_rs_m) - p_dst_p => p_dst_rs(:,i,j_rs_p) - ksmx_m = ksmx_rs(i,j_rs_m) - ksmx_p = ksmx_rs(i,j_rs_p) - kdmx_m = kdmx_rs(i,j_rs_m) - kdmx_p = kdmx_rs(i,j_rs_p) + do i = max(ilb, ifv(j, l)), min(iub, ilv(j, l)) + + p_srcdi_m => p_srcdi_js(:,:,i,js_m) + p_srcdi_p => p_srcdi_js(:,:,i,js_p) + t_srcdi_m => t_srcdi_js(:,:,:,i,js_m) + t_srcdi_p => t_srcdi_js(:,:,:,i,js_p) + tpc_src_m => tpc_src_js(:,:,:,i,js_m) + tpc_src_p => tpc_src_js(:,:,:,i,js_p) + drhodt_srcdi_m => drhodt_srcdi_js(:,:,i,js_m) + drhodt_srcdi_p => drhodt_srcdi_js(:,:,i,js_p) + drhods_srcdi_m => drhods_srcdi_js(:,:,i,js_m) + drhods_srcdi_p => drhods_srcdi_js(:,:,i,js_p) + p_dst_m => p_dst_js(:,i,js_m) + p_dst_p => p_dst_js(:,i,js_p) + ksmx_m = ksmx_js(i,js_m) + ksmx_p = ksmx_js(i,js_p) + kdmx_m = kdmx_js(i,js_m) + kdmx_p = kdmx_js(i,js_p) cdiff = delt1*scvx(i,j)*scvyi(i,j) cnslp = alpha0*scvyi(i,j)/g @@ -1042,33 +1033,33 @@ subroutine ndiff_vflx_jslice(ksmx_rs, tpc_src_rs, t_srcdi_rs, & p_srcdi_p, t_srcdi_p, tpc_src_p, & drhodt_srcdi_p, drhods_srcdi_p, & p_dst_p, ksmx_p, kdmx_p, & - cdiff, cnslp, pv, flxconv_rs, & + cdiff, cnslp, pv, flxconv_js, & vtflld, vsflld, vtflx, vsflx, nslpy, & - ntr_loc, i, j-1, i, j, j_rs_m, j_rs_p, mm, nn) + ntr_loc, i, j-1, i, j, js_m, js_p, mm, nn) enddo enddo end subroutine ndiff_vflx_jslice - pure subroutine ndiff_update_trc_jslice(p_dst_rs, flxconv_rs, trc_rm, & - ntr_loc, i_lb, i_ub, j, j_rs) + pure subroutine ndiff_update_trc_jslice(p_dst_js, flxconv_js, trc_rm, & + ntr_loc, ilb, iub, j, js) - real(r8), dimension(:,1-nbdy:,:), intent(in) :: p_dst_rs - real(r8), dimension(:,:,1-nbdy:,:), intent(in) :: flxconv_rs + real(r8), dimension(:,1-nbdy:,:), intent(in) :: p_dst_js + real(r8), dimension(:,:,1-nbdy:,:), intent(in) :: flxconv_js real(r8), dimension(:,:,1-nbdy:), intent(inout) :: trc_rm - integer, intent(in) :: ntr_loc, i_lb, i_ub, j, j_rs + integer, intent(in) :: ntr_loc, ilb, iub, j, js real(r8) :: q integer :: k, l, i, nt do l = 1, isp(j) - do i = max(i_lb, ifp(j, l)), min(i_ub, ilp(j, l)) + do i = max(ilb, ifp(j, l)), min(iub, ilp(j, l)) do k = 1, kk - q = 1._r8/(scp2(i,j)*max( p_dst_rs(k+1,i,j_rs) & - - p_dst_rs(k ,i,j_rs), dp_eps)) + q = 1._r8/(scp2(i,j)*max( p_dst_js(k+1,i,js) & + - p_dst_js(k ,i,js), dp_eps)) do nt = 1, ntr_loc - trc_rm(k,nt,i) = trc_rm(k,nt,i) - q*flxconv_rs(k,nt,i,j_rs) + trc_rm(k,nt,i) = trc_rm(k,nt,i) - q*flxconv_js(k,nt,i,js) enddo enddo enddo diff --git a/phy/mod_rdlim.F90 b/phy/mod_rdlim.F90 index 15134883..c3424a51 100644 --- a/phy/mod_rdlim.F90 +++ b/phy/mod_rdlim.F90 @@ -99,8 +99,8 @@ module mod_rdlim diagfq_phy, diagmon_phy, diagann_phy, secdia, & filefq_phy, filemon_phy, fileann_phy use mod_ben02, only: atm_path, atm_path_len - use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, & - cntiso_hybrid, readnml_vcoord + use mod_vcoord, only: vcoord_tag, vcoord_isopyc_bulkml, readnml_vcoord + use mod_ale_regrid_remap, only: readnml_ale_regrid_remap use mod_cesm, only: runid_cesm, ocn_cpl_dt_cesm, nstep_in_cpl, & smtfrc use mod_pointtest, only: itest, jtest @@ -124,8 +124,7 @@ subroutine rdlim() type(date_type) :: date0_rest character(len = 256) :: nlfnm,runtyp,rstfnm logical :: fexist - integer :: m,n,idate,idate0,ios - integer :: nfu + integer :: m,n,idate,idate0,nfu,ios namelist /limits/ nday1,nday2,idate,idate0,runid,expcnf,runtyp, & grfile,icfile,pref,baclin,batrop, & @@ -360,6 +359,9 @@ subroutine rdlim() ! read vertical coordinate namelist variables call readnml_vcoord + ! read namelist variables associated with ALE regridding-remapping. + call readnml_ale_regrid_remap + ! read diffusion namelist variables call readnml_diffusion @@ -380,8 +382,8 @@ subroutine rdlim() ! modify diaphy namelist variables based on dependency with other ! variables set in namelists - select case (vcoord_type_tag) - case (isopyc_bulkml) + select case (vcoord_tag) + case (vcoord_isopyc_bulkml) LYR_DIFVMO(1:nphy) = 0 LYR_DIFVHO(1:nphy) = 0 LYR_DIFVSO(1:nphy) = 0 @@ -404,7 +406,7 @@ subroutine rdlim() LVL_DIFVMO(1:nphy) = 0 LVL_DIFVHO(1:nphy) = 0 LVL_DIFVSO(1:nphy) = 0 - case (cntiso_hybrid) + case default H2D_IDKEDT(1:nphy) = 0 H2D_MTKEUS(1:nphy) = 0 H2D_MTKENI(1:nphy) = 0 @@ -414,10 +416,6 @@ subroutine rdlim() H2D_MTKEKE(1:nphy) = 0 LYR_DIFDIA(1:nphy) = 0 LVL_DIFDIA(1:nphy) = 0 - case default - write (lp,*) 'rdlim: unsupported vertical coordinate!' - call xcstop('(rdlim)') - stop '(rdlim)' end select if (trxday == 0.) then @@ -434,7 +432,7 @@ subroutine rdlim() H2D_USTOKES(1:nphy) = 0 H2D_VSTOKES(1:nphy) = 0 case (wavsrc_param) - if (vcoord_type_tag /= cntiso_hybrid) then + if (vcoord_tag == vcoord_isopyc_bulkml) then H2D_LAMULT(1:nphy) = 0 end if H2D_LASL(1:nphy) = 0 diff --git a/phy/mod_remap.F90 b/phy/mod_remap.F90 index 1bc02f5c..d34a728a 100644 --- a/phy/mod_remap.F90 +++ b/phy/mod_remap.F90 @@ -30,7 +30,7 @@ module mod_remap use mod_types, only: r8 use mod_xc use mod_constants, only: P_mks2cgs - use mod_tracers, only: ntr, itrtke, itrgls, natr ! TRC + use mod_tracers, only: ntr, itrtke, itrgls, natr, trc ! TRC use mod_ifdefs, only: use_TRC, use_ATRC, use_TKE, use_TKEADV implicit none @@ -206,9 +206,8 @@ end subroutine penint !--------------------------------------------------------------- subroutine remap_eitvel(scuy,scvx,scp2i,scp2,pbmin,pbu,pbv,plo, & - u,v,dt,mrg,dp,temp,saln,uflx,vflx, & - utflx,vtflx,usflx,vsflx, & - k,trc) + u,v,dt,mrg,dp,temp,saln,uflx,vflx, & + utflx,vtflx,usflx,vsflx,k) !--------------------------------------------------------------- ! Advection of layer pressure thickness and tracers by incremental @@ -264,7 +263,6 @@ subroutine remap_eitvel(scuy,scvx,scp2i,scp2,pbmin,pbu,pbv,plo, & real, intent(out), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: vtflx real, intent(out), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: usflx real, intent(out), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: vsflx - real, intent(inout), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,2*kdm,ntr) :: trc ! Local variables. real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: & @@ -1536,9 +1534,8 @@ end subroutine remap_eitvel !--------------------------------------------------------------- subroutine remap_eitflx(scuy,scvx,scp2i,scp2,pbmin,pbu,pbv,plo, & - u,v,umfl,vmfl,dt,mrg,dp,temp,saln, & - uflx,vflx,utflx,vtflx,usflx,vsflx, & - k,trc) + u,v,umfl,vmfl,dt,mrg,dp,temp,saln, & + uflx,vflx,utflx,vtflx,usflx,vsflx,k) !--------------------------------------------------------------- ! Advection of layer pressure thickness and tracers by incremental @@ -1599,7 +1596,6 @@ subroutine remap_eitflx(scuy,scvx,scp2i,scp2,pbmin,pbu,pbv,plo, & real, intent(out), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: vtflx real, intent(out), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: usflx real, intent(out), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: vsflx - real, intent(inout), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,2*kdm,ntr) :: trc ! Local variables. real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: & diff --git a/phy/mod_restart.F90 b/phy/mod_restart.F90 index 4665ea1b..5db92863 100644 --- a/phy/mod_restart.F90 +++ b/phy/mod_restart.F90 @@ -28,7 +28,7 @@ module mod_restart use mod_time, only: date0, date, nday1, nstep0, nstep1, nstep, time, time0, & nstep_in_day, nday_of_year, calendar use mod_xc - use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid, sigmar + use mod_vcoord, only: vcoord_tag, vcoord_isopyc_bulkml, sigmar use mod_inicon, only: icfile use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma, uflx, vflx, & utflx, vtflx, usflx, vsflx, phi, ubflxs, vbflxs, & @@ -340,7 +340,7 @@ subroutine defwrtflds(defmode) call defwrtfld('ficem', trim(c5p)//' time', & ficem, ip, defmode) - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then call defwrtfld('buoyfl', trim(c5p)//' time', & buoyfl, ip, defmode) call defwrtfld('uml', trim(c5u)//' k4 time', & @@ -353,7 +353,7 @@ subroutine defwrtflds(defmode) vmlres, ivv, defmode) endif - if (vcoord_type_tag == cntiso_hybrid) then + if (vcoord_tag /= vcoord_isopyc_bulkml) then call defwrtfld('dpu', trim(c5u)//' kk2 time', & dpu, iu, defmode) call defwrtfld('dpv', trim(c5v)//' kk2 time', & @@ -1037,11 +1037,10 @@ subroutine restart_write ! Write model state to restart files. ! --------------------------------------------------------------------------- - integer :: i, j, n + integer :: nfu, i, j, n character(len = 256), dimension(4) :: rstdate_str character(len = 256) :: rstfnm, fnm character(len = 2) :: c2 - integer :: nfu ! Formulate restart filename. if (expcnf == 'cesm') then @@ -1280,12 +1279,11 @@ subroutine restart_read ! --------------------------------------------------------------------------- type(date_type) :: date_rest - integer errstat, dndiff, i, j, l, n + integer :: nfu, errstat, dndiff, i, j, l, n character(len = 256) :: rstfnm, fnm character(len = 2) :: c2 real(r8) :: pb_max, phi_min, rho_restart logical :: file_exist, fld_read - integer :: nfu ! Open restart file and adjust time information if needed. if (nday1 + nint(time0) == 0 .and. (.not.resume_flag)) then @@ -1545,7 +1543,7 @@ subroutine restart_read call readfld('kfpla', no_unitconv, rkfpla, ip) call readfld('ficem', no_unitconv, ficem, ip) - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then call readfld('buoyfl', l2_unitconv, buoyfl, ip) call readfld('uml', l_unitconv, uml, iuu, required = .false.) call readfld('vml', l_unitconv, vml, ivv, required = .false.) @@ -1553,7 +1551,7 @@ subroutine restart_read call readfld('vmlres', l_unitconv, vmlres, ivv, required = .false.) endif - if (vcoord_type_tag == cntiso_hybrid) then + if (vcoord_tag /= vcoord_isopyc_bulkml) then call readfld('dpu', p_unitconv, dpu, iu) call readfld('dpv', p_unitconv, dpv, iv) call readfld('difiso', l2_unitconv, difiso, ip) diff --git a/phy/mod_temmin.F90 b/phy/mod_temmin.F90 index 951f2dce..ffbb2e13 100644 --- a/phy/mod_temmin.F90 +++ b/phy/mod_temmin.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2006-2021 Mats Bentsen, Mehmet Ilicak, Aleksi Nummelin +! Copyright (C) 2006-2024 Mats Bentsen, Mehmet Ilicak, Aleksi Nummelin ! This file is part of BLOM. @@ -28,7 +28,7 @@ module mod_temmin use dimensions, only: idm,jdm, kdm use mod_types, only: r8 use mod_config, only: expcnf - use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, sigmar + use mod_vcoord, only: vcoord_tag, vcoord_isopyc_bulkml, sigmar use mod_xc, only: xcstop, ii, jj, kk, isp, ifp, ilp, lp, & mnproc, nbdy use mod_eos, only: ap11, ap12, ap13, ap14, ap15, ap16, & @@ -57,7 +57,7 @@ subroutine settemmin() integer :: i,j,k,l real :: salfrz,a,b,c - if (vcoord_type_tag /= isopyc_bulkml .or. & + if (vcoord_tag /= vcoord_isopyc_bulkml .or. & expcnf == 'cesm' .or. expcnf == 'single_column') then ! Set temmin to a constant freezing temperature for all layers @@ -74,7 +74,7 @@ subroutine settemmin() !$omp end parallel do else if (expcnf == 'ben02clim'.or.expcnf == 'ben02syn'.or. & - expcnf == 'fuk95'.or.expcnf == 'channel') then + expcnf == 'fuk95'.or.expcnf == 'channel') then ! Let temmin be the freezing temperature of a given potential ! density. This can be achieved by using potential density given diff --git a/phy/mod_tmsmt.F90 b/phy/mod_tmsmt.F90 index 4799e96f..b2b11b6e 100644 --- a/phy/mod_tmsmt.F90 +++ b/phy/mod_tmsmt.F90 @@ -33,7 +33,7 @@ module mod_tmsmt lp, iu, iv, ip, isv, ifv, isv, ilv, nbdy use mod_types, only: r8 use mod_constants, only: epsilp, spval - use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml + use mod_vcoord, only: vcoord_tag, vcoord_isopyc_bulkml use mod_state, only: dp, dpu, dpv, temp, saln, p, pb use mod_checksum, only: csdiag, chksummsk use mod_tracers, only: ntr, trc, trcold @@ -332,7 +332,7 @@ subroutine tmsmt2(m,mm,nn,k1m) end do !$omp end parallel do - if (vcoord_type_tag == isopyc_bulkml) then + if (vcoord_tag == vcoord_isopyc_bulkml) then call xctilr(dp(1-nbdy,1-nbdy,k1m), 1,kk, 3,3, halo_ps) diff --git a/phy/mod_vcoord.F90 b/phy/mod_vcoord.F90 index f2d8acfb..7db1b85d 100644 --- a/phy/mod_vcoord.F90 +++ b/phy/mod_vcoord.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2021-2023 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2021-2024 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -25,921 +25,67 @@ module mod_vcoord use mod_types, only: r8 use mod_config, only: inst_suffix - use mod_constants, only: g, epsilp, spval, onem - use mod_time, only: delt1 + use mod_constants, only: spval, onem, M_mks2cgs use mod_xc - use mod_grid, only: scuy, scvx, scp2, scuxi, scvyi, scp2i - use mod_eos, only: sig, dsigdt, dsigds - use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma, p, pu, pv - use mod_hor3map, only: recon_grd_struct, recon_src_struct, remap_struct, & - hor3map_plm, hor3map_ppm, hor3map_pqm, & - hor3map_monotonic, hor3map_non_oscillatory, & - hor3map_non_oscillatory_posdef, & - initialize_rcgs, initialize_rcss, initialize_rms, & - prepare_reconstruction, reconstruct, & - extract_polycoeff, regrid2, & - prepare_remapping, remap, & - hor3map_noerr, hor3map_errstr - use mod_diffusion, only: ltedtp_opt, ltedtp_neutral, difiso, difmxp - use mod_ndiff, only: ndiff_prep_jslice, ndiff_uflx_jslice, & - ndiff_vflx_jslice, ndiff_update_trc_jslice - use mod_checksum, only: csdiag, chksummsk - use mod_tracers, only: ntr, trc - use mod_ifdefs, only: use_TRC implicit none private + ! Parameters: + integer, parameter :: & + vcoord_isopyc_bulkml = 1, & ! Vertical coordinate type: bulk surface + ! mixed layer with isopycnic layers below. + vcoord_cntiso_hybrid = 2, & ! Vertical coordinate type: Hybrid + ! coordinate with pressure coordinates towards + ! the surface and continuous isopycnal below. + vcoord_plevel = 3, & ! Vertical coordinate type: pressure + ! coordinate. + kdm_max = 1000 ! Maximum anticipated vertical dimension. + ! Options with default values, modifiable by namelist. character(len = 80) :: & - vcoord_type = 'isopyc_bulkml', & - reconstruction_method = 'ppm', & - density_limiting = 'monotonic', & - tracer_limiting = 'monotonic', & - velocity_limiting = 'monotonic' - logical :: & - density_pc_upper_bndr = .false., & - density_pc_lower_bndr = .false., & - tracer_pc_upper_bndr = .true., & - tracer_pc_lower_bndr = .false., & - velocity_pc_upper_bndr = .true., & - velocity_pc_lower_bndr = .false. + vcoord_type = 'isopyc_bulkml', & + sigref_spec = 'inicon', & + plevel_spec = 'inflation' real(r8) :: & - dpmin_surface = 1.5_r8, & - dpmin_inflation_factor = 1._r8, & - dpmin_interior = .1_r8, & - regrid_nudge_ts = 86400._r8, & - stab_fac_limit = .25_r8, & - smooth_diff_max = 50000.e4_r8 - integer :: & - upper_bndr_ord = 6, & - lower_bndr_ord = 4, & - dktzu = 4, & - dktzl = 1 + dpmin_surface = 1.5_r8, & + dpmin_inflation_factor = 1._r8 + real(r8), dimension(kdm_max) :: & + sigref = spval, & + plevel = spval ! Options derived from string options. integer :: & - vcoord_type_tag, & - reconstruction_method_tag, & - density_limiting_tag, & - tracer_limiting_tag, & - velocity_limiting_tag - - ! Parameters: - integer, parameter :: & - isopyc_bulkml = 1, & ! Vertical coordinate type: bulk surface - ! mixed layer with isopycnic layers below. - cntiso_hybrid = 2 ! Vertical coordinate type: Hybrid - ! coordinate with pressure coordinates - ! towards the surface and continuous - ! isopycnal below. - - real(r8), parameter :: & - bfsq_min = 1.e-7_r8, & ! Minimum buoyancy frequency squared in - ! monotonized potential density to be used - ! in regridding [s-2]. - regrid_mval = - 1.e33_r8, & ! Missing value for regridding. - x_eps = 1.e-14_r8 ! Small non-dimensional value used in the - ! construction of Bezier curves. - - - integer :: ntr_loc - - type(recon_grd_struct) :: rcgs - type(recon_src_struct) :: d_rcss, v_rcss - type(recon_src_struct), allocatable, dimension(:) :: trc_rcss - type(remap_struct) :: rms + vcoord_tag real(r8), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: & - sigmar ! Reference potential density [g cm-3]. + sigmar ! Reference potential density [g cm-3]. - public :: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid, sigmar, & - readnml_vcoord, inivar_vcoord, cntiso_hybrid_regrid_direct_remap, & - cntiso_hybrid_regrid_remap, remap_velocity + public :: vcoord_tag, vcoord_isopyc_bulkml, vcoord_cntiso_hybrid, & + vcoord_plevel, sigref_spec, sigmar, sigref, plevel, & + readnml_vcoord, inivar_vcoord contains - pure function peval0(pc) result(f) - - real(r8), dimension(:), intent(in) :: pc - - real(r8) :: f - - f = pc(1) - - end function peval0 - - pure function peval1(pc) result(f) - - real(r8), dimension(:), intent(in) :: pc - - real(r8) :: f - - f = pc(1) + pc(2) + pc(3) + pc(4) + pc(5) - - end function peval1 - - pure function dpeval0(pc) result(f) - - real(r8), dimension(:), intent(in) :: pc - - real(r8) :: f - - f = pc(2) - - end function dpeval0 - - pure function dpeval1(pc) result(f) - - real(r8), dimension(:), intent(in) :: pc - - real(r8) :: f - - real(r8), parameter :: & - c2 = 2._r8, & - c3 = 3._r8, & - c4 = 4._r8 - - f = pc(2) + c2*pc(3) + c3*pc(4) + c4*pc(5) - - end function dpeval1 - - subroutine prep_recon_jslice(p_src, ksmx, i_lb, i_ub, j, j_rs, nn) ! --------------------------------------------------------------------------- - ! Prepare vertical layer reconstruction along a j-slice of the model data. + ! Public procedures. ! --------------------------------------------------------------------------- - real(r8), dimension(:,1-nbdy:), intent(out) :: p_src - integer, dimension(1-nbdy:), intent(out) :: ksmx - integer, intent(in) :: i_lb, i_ub, j, j_rs, nn - - integer :: l, i, k, errstat - - do l = 1, isp(j) - do i = max(i_lb, ifp(j,l)), min(i_ub, ilp(j,l)) - - ! Compute source layer interface pressure. - p_src(1,i) = p(i,j,1) - do k = 1, kk - p_src(k+1,i) = p_src(k,i) + dp(i,j,k+nn) - enddo - - ! Find index of deepest source layer with non-zero thickness. - ksmx(i) = kk - do k = kk, 1, -1 - if (p_src(k,i) == p_src(kk+1,i)) ksmx(i) = k - 1 - enddo - - errstat = prepare_reconstruction(rcgs, p_src(:,i), i, j_rs) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(prep_recon_jslice)') - stop '(prep_recon_jslice)' - endif - - enddo - enddo - - end subroutine prep_recon_jslice - - subroutine recon_trc_jslice(ksmx, tpc_src, t_srcdi, i_lb, i_ub, j, j_rs, nn) + subroutine readnml_vcoord ! --------------------------------------------------------------------------- - ! Vertically reconstruct temperature, salinity and additional tracers along a - ! j-slice of the model data. + ! Read variables in the namelist group 'vcoord' and resolve options. ! --------------------------------------------------------------------------- - integer, dimension(1-nbdy:), intent(in) :: ksmx - real(r8), intent(out) :: tpc_src(:,:,:,1-nbdy:), t_srcdi(:,:,:,1-nbdy:) - integer, intent(in) :: i_lb, i_ub, j, j_rs, nn - - real(r8), dimension(kdm,ntr_loc) :: trc_1d - integer :: l, i, k, kn, nt, errstat - - do l = 1, isp(j) - do i = max(i_lb, ifp(j,l)), min(i_ub, ilp(j,l)) - - ! Copy variables into 1D arrays. - do k = 1, kk - kn = k + nn - trc_1d(k,1) = temp(i,j,kn) - trc_1d(k,2) = saln(i,j,kn) - if (use_TRC) then - do nt = 1, ntr - trc_1d(k,nt+2) = trc(i,j,kn,nt) - enddo - end if - enddo - - ! Reconstruct tracers. - do nt = 1, ntr_loc - errstat = reconstruct(rcgs, trc_rcss(nt), trc_1d(:,nt), i, j_rs) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(recon_trc_jslice)') - stop '(recon_trc_jslice)' - endif - enddo - - ! Extract polynomial coefficients of the reconstructions and store - ! tracer variables in dual interface arrays with with values - ! corresponding to upper and lower interface of each layer. - do nt = 1, ntr_loc - errstat = extract_polycoeff(trc_rcss(nt), tpc_src(:,:,nt,i), & - i, j_rs) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(recon_trc_jslice)') - stop '(recon_trc_jslice)' - endif - do k = 1, ksmx(i) - t_srcdi(1,k,nt,i) = peval0(tpc_src(:,k,nt,i)) - t_srcdi(2,k,nt,i) = peval1(tpc_src(:,k,nt,i)) - enddo - enddo - - enddo - enddo - - end subroutine recon_trc_jslice - - subroutine remap_trc_jslice(p_dst, trc_rm, i_lb, i_ub, j, j_rs) - - real(r8), dimension(:,1-nbdy:), intent(in) :: p_dst - real(r8), dimension(:,:,1-nbdy:), intent(out) :: trc_rm - integer, intent(in) :: i_lb, i_ub, j, j_rs - - integer :: l, i, nt, errstat - - do l = 1, isp(j) - do i = max(i_lb, ifp(j,l)), min(i_ub, ilp(j,l)) - - ! Prepare remapping to target layers. - errstat = prepare_remapping(rcgs, rms, p_dst(:,i), i, j_rs) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - write(lp,*) 'i, j:', i + i0, j + j0 - do nt = 1,kk - write(lp,*) nt, p_dst(nt+1,i), p_dst(nt+1,i) - p_dst(nt,i) - enddo - call xchalt('(remap_trc_jslice)') - stop '(remap_trc_jslice)' - endif - - ! Remap tracers. - do nt = 1, ntr_loc - errstat = remap(trc_rcss(nt), rms, trc_rm(:,nt,i), i, j_rs) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(remap_trc_jslice)') - stop '(remap_trc_jslice)' - endif - enddo - - enddo - enddo - - end subroutine remap_trc_jslice - - subroutine cntiso_regrid_direct_jslice(p_src, p_dst, i_lb, i_ub, j, j_rs, nn) - - real(r8), dimension(:,1-nbdy:), intent(in) :: p_src - real(r8), dimension(:,1-nbdy:), intent(out) :: p_dst - integer, intent(in) :: i_lb, i_ub, j, j_rs, nn - - real(r8), dimension(kdm+1) :: sigmar_1d - real(r8), dimension(kdm) :: sigma_1d - real(r8) :: beta, sdpsum, smean, dpmin_max, dpmin_int, dpmin_sfc, & - pku, pku_test, pmin, dpt, pt, ptu1, ptl1, ptu2, ptl2, w1, x - integer :: l, i, k, kn, ks, ke, kl, ku, errstat - logical :: thin_layers, layer_added - - ! Minimum potential density difference with respect to pressure for - ! potential density to be used in regridding. - beta = bfsq_min/(g*g) - - do l = 1, isp(j) - do i = max(i_lb, ifp(j,l)), min(i_ub, ilp(j,l)) - - ! Copy variables into 1D arrays. - do k = 1, kk - kn = k + nn - sigma_1d(k) = sigma(i,j,kn) - sigmar_1d(k) = sigmar(i,j,k) - enddo - sigmar_1d(kk+1) = sigmar_1d(kk) - - ! Make sure potential density to be used in regridding is - ! monotonically increasing with depth. - kl = kk - ku = kl - 1 - do while (ku > 0) - thin_layers = p_src(kl+1,i) - p_src(ku,i) < epsilp - if (thin_layers .or. & - sigma_1d(kl) - sigma_1d(ku) & - < .5_r8*beta*(p_src(kl+1,i) - p_src(ku,i))) then - sdpsum = sigma_1d(ku)*(p_src(ku+1,i) - p_src(ku,i)) & - + sigma_1d(kl)*(p_src(kl+1,i) - p_src(kl,i)) - if (.not. thin_layers) & - smean = sdpsum/(p_src(kl+1,i) - p_src(ku,i)) - do - layer_added = .false. - if (ku > 1) then - if (thin_layers) then - ku = ku - 1 - sdpsum = sdpsum & - + sigma_1d(ku)*(p_src(ku+1,i) - p_src(ku,i)) - thin_layers = p_src(kl+1,i) - p_src(ku,i) < epsilp - if (.not. thin_layers) & - smean = sdpsum/(p_src(kl+1,i) - p_src(ku,i)) - layer_added = .true. - else - if (smean - sigma_1d(ku-1) & - < .5_r8*beta*(p_src(kl+1,i) - p_src(ku-1,i))) then - ku = ku - 1 - sdpsum = sdpsum & - + sigma_1d(ku)*(p_src(ku+1,i) - p_src(ku,i)) - smean = sdpsum/(p_src(kl+1,i) - p_src(ku,i)) - layer_added = .true. - endif - endif - endif - if (kl < kk) then - if (thin_layers) then - kl = kl + 1 - sdpsum = sdpsum & - + sigma_1d(kl)*(p_src(kl+1,i) - p_src(kl,i)) - thin_layers = p_src(kl+1,i) - p_src(ku,i) < epsilp - if (.not. thin_layers) & - smean = sdpsum/(p_src(kl+1,i) - p_src(ku,i)) - layer_added = .true. - else - if (sigma_1d(kl+1) - smean & - < .5_r8*beta*(p_src(kl+2,i) - p_src(ku,i))) then - kl = kl + 1 - sdpsum = sdpsum & - + sigma_1d(kl)*(p_src(kl+1,i) - p_src(kl,i)) - smean = sdpsum/(p_src(kl+1,i) - p_src(ku,i)) - layer_added = .true. - endif - endif - endif - if (.not. layer_added) exit - enddo - do k = ku, kl - sigma_1d(k) = smean & - + .5_r8*beta*( p_src(k ,i) + p_src(k +1,i) & - - p_src(ku,i) - p_src(kl+1,i)) - enddo - endif - kl = ku - ku = kl - 1 - enddo - - ! Monotonically reconstruct potential density. - errstat = reconstruct(rcgs, d_rcss, sigma_1d, i, j_rs) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(cntiso_regrid_direct_jslice)') - stop '(cntiso_regrid_direct_jslice)' - endif - - ! On the basis of the reconstructed potential density, regrid - ! interface pressures so interface potential densities match target - ! values. - errstat = regrid2(d_rcss, sigmar_1d, p_dst(:,i), regrid_mval, & - i, j_rs) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(cntiso_regrid_direct_jslice)') - stop '(cntiso_regrid_direct_jslice)' - endif - - ! Modify regridded interface pressures to ensure the water column is - ! properly bounded. - k = 1 - do - ks = k - if (p_dst(k,i) /= regrid_mval) exit - p_dst(k,i) = p_src(1,i) - if (k > kk) exit - k = k + 1 - enddo - k = kk + 1 - do - ke = k - if (p_dst(k,i) /= regrid_mval) exit - p_dst(k,i) = p_src(kk+1,i) - if (k == 1) exit - k = k - 1 - enddo - p_dst(1,i) = p_src(1,i) - p_dst(kk+1,i) = p_src(kk+1,i) - - ! If no regrid interface is found in the water column, try to place - ! all water in the layer with potential density bounds that include - ! the column mean potential density. - if (ks == ke) then - sdpsum = 0._r8 - do k = 1, kk - sdpsum = sdpsum + sigma_1d(k)*(p_src(k+1,i) - p_src(k,i)) - enddo - smean = sdpsum/(p_src(kk+1,i) - p_src(1,i)) - ks = 2 - do while (ks <= kk) - if (smean < sigmar_1d(ks)) exit - ks = ks + 1 - enddo - do k = ks, kk - p_dst(k,i) = p_src(kk+1,i) - enddo - ke = ks - 1 - endif - - ! Modify interface pressures so that layer thicknesses are - ! above a specified threshold. - dpmin_max = (p_src(kk+1,i) - p_src(1,i))/kk - dpmin_max = dpmin_surface - dpmin_int = min(dpmin_max, dpmin_surface, dpmin_interior) - ks = max(2, ks) - ke = min(kk, ke) - k = ks - do while (k <= ke) - if (p_dst(k+1,i) - p_dst(k,i) < dpmin_int) then - if (k == ke) then - p_dst(k,i) = p_dst(ke+1,i) - else - ku = k - kl = k + 1 - pku = .5_r8*(p_dst(kl,i) + p_dst(ku,i) - dpmin_int) - do - layer_added = .false. - kl = kl + 1 - pku_test = ((pku - dpmin_int)*(kl - ku) + p_dst(kl,i)) & - /(kl - ku + 1) - if (pku_test + (kl - ku)*dpmin_int > p_dst(kl,i)) then - if (kl == ke + 1) exit - pku = pku_test - layer_added = .true. - else - kl = kl - 1 - endif - ku = ku - 1 - pku_test = ((pku - dpmin_int)*(kl - ku) + p_dst(ku,i)) & - /(kl - ku + 1) - if (pku_test < p_dst(ku,i)) then - if (ku == 1) exit - pku = pku_test - layer_added = .true. - else - ku = ku + 1 - endif - if (.not. layer_added) exit - enddo - if (ku == 1) then - do k = 2, kl - p_dst(k,i) = min(p_dst(ke+1,i), & - p_dst(k-1,i) + dpmin_int) - enddo - do k = kl+1, ke - p_dst(k,i) = & - min(p_dst(ke+1,i), & - max(p_dst(k,i), p_dst(1,i) + dpmin_int*(k - 1))) - enddo - elseif (kl == ke + 1) then - do k = ku, kl - p_dst(k,i) = p_dst(ke+1,i) - enddo - else - p_dst(ku,i) = pku - do k = ku+1, kl - p_dst(k,i) = p_dst(k-1,i) + dpmin_int - enddo - endif - k = kl - endif - endif - k = k + 1 - enddo - - ! Modify regridded interface pressures to ensure that a minimum - ! layer thickness towards the surface is maintained. A smooth - ! transition between modified and unmodified interfaces is sought. - dpmin_sfc = min(dpmin_max, dpmin_surface) - pmin = p_src(1,i) + dpmin_sfc - dpt = dpmin_sfc - do k = 2, ke - dpmin_sfc = dpmin_sfc*dpmin_inflation_factor - dpt = max(p_dst(k+1,i) - p_dst(k,i), dpt, dpmin_sfc) - pt = max(p_dst(k,i), pmin) - ptu1 = pmin - dpt - ptl1 = pmin + dpt - ptu2 = pmin - ptl2 = pmin + 2._r8*dpt - w1 = min(1._r8,(p_dst(k,i) - p_src(1,i))/(pmin - p_src(1,i))) - if (p_dst(k,i) > ptu1 .and. p_dst(k,i) < ptl1) then - x = .5_r8*(p_dst(k,i) - ptu1)/dpt - pt = pmin + dpt*x*x - endif - if (p_dst(k+1,i) > ptu2 .and. p_dst(k+1,i) < ptl2) then - x = .5_r8*(p_dst(k+1,i) - ptu2)/dpt - pt = w1*pt + (1._r8 - w1)*(pmin + dpt*x*x) - endif - p_dst(k,i) = min(p_dst(ke+1,i), max(p_dst(k-1,i) + dpmin_int, pt)) - pmin = pmin + dpmin_sfc - enddo - - enddo - enddo - - end subroutine cntiso_regrid_direct_jslice - - subroutine cntiso_regrid_nudge_jslice(p_src, ksmx, tpc_src, t_srcdi, p_dst, & - stab_fac, i_lb, i_ub, j, j_rs) - - real(r8), dimension(:,1-nbdy:), intent(in) :: p_src - integer, dimension(1-nbdy:), intent(in) :: ksmx - real(r8), dimension(:,:,:,1-nbdy:), intent(in) :: tpc_src, t_srcdi - real(r8), dimension(:,1-nbdy:), intent(out) :: p_dst, stab_fac - integer, intent(in) :: i_lb, i_ub, j, j_rs - - integer, parameter :: & - it = 1, & - is = 2 - - real(r8), dimension(2,kdm) :: sig_srcdi - integer, dimension(1-nbdy:idm+nbdy) :: kdmx - - real(r8), dimension(kdm+1) :: sigmar_1d, pmin, sig_pmin, sig_trg - real(r8), dimension(kdm) :: dsigmar_1d - real(r8) :: dpmin_inflation_factor_i, sig_max, dpmin_sfc, & - ckt, sig_up, sig_lo, dk, dki, dsigdx_up, dsigdx_lo, & - x, xi, si, t, nudge_fac, dsig, dsigdx, dp_up, dp_lo, & - sig_intrp, q - integer :: l, i, k, kt, kl, ktzmin, ktzmax - - dpmin_inflation_factor_i = 1._r8/dpmin_inflation_factor - - do l = 1, isp(j) - do i = max(i_lb, ifp(j, l)), min(i_ub, ilp(j, l)) - - ! Store density in a dual interface array with with values - ! corresponding to upper and lower interface of each layer. Also - ! find the maximum lower interface potential density of the - ! reconstructed column. - sig_max = 0._r8 - do k = 1, ksmx(i) - sig_srcdi(1,k) = sig(t_srcdi(1,k,it,i), t_srcdi(1,k,is,i)) - sig_srcdi(2,k) = sig(t_srcdi(2,k,it,i), t_srcdi(2,k,is,i)) - sig_max = max(sig_max, sig_srcdi(2,k)) - enddo - - ! Copy variables into 1D arrays. - do k = 1, kk - sigmar_1d(k) = sigmar(i,j,k) - enddo - sigmar_1d(kk+1) = sigmar_1d(kk) - do k = 1, kk-1 - dsigmar_1d(k) = sigmar_1d(k+1) - sigmar(i,j,k) - enddo - dsigmar_1d(kk) = dsigmar_1d(kk-1) - - ! Find the index of the first layer which lower interface reference - ! potential density is denser than the maximum lower interface - ! potential density of the reconstructed column. - do k = kk, 1, -1 - if (sigmar_1d(k) < sig_max) exit - enddo - kdmx(i) = max(1, k) - - ! Set minimum interface pressure. - dpmin_sfc = dpmin_surface - pmin(1) = p_src(1,i) - do k = 1, kk - pmin(k+1) = min(pmin(k) + dpmin_sfc, p_src(kk+1,i)) - dpmin_sfc = dpmin_sfc*dpmin_inflation_factor - enddo - p_dst(1,i) = pmin(1) - stab_fac(1,i) = 0._r8 - - nudge_fac = delt1/regrid_nudge_ts - - ! Find the index of the first interface with potential density at - ! minimum interface pressure smaller than the reference potential - ! density of this transition interface. A layer range above and - ! below the transition interface may be specified, making a - ! transition zone where interface reference potential densities are - ! adjusted to achieve a more gradual change from pressure level to - ! isopycnic interfaces. - sig_trg(:) = sigmar_1d(:) - sig_pmin(1) = sig_srcdi(1,1) - kt = 2 - kl = 1 - do while (kt <= kdmx(i)) - do while (p_src(kl+1,i) < pmin(kt)) - kl = kl + 1 - enddo - sig_pmin(kt) = ( (p_src(kl+1,i) - pmin(kt))*sig_srcdi(1,kl) & - + (pmin(kt) - p_src(kl,i))*sig_srcdi(2,kl)) & - /(p_src(kl+1,i) - p_src(kl,i)) - if (sigmar_1d(kt) > sig_pmin(kt)) then - ktzmin = max(3, kt - dktzu) - ktzmax = min(kk - 1, kt + dktzl) - if (ktzmin < kt .and. ktzmax - ktzmin > 1) then - ! For a smooth transition in layer reference potential - ! densities, try to construct a quadratic Bezier curve - ! specified by the density and density gradients at the - ! boundary of the transition zone. If construction of a - ! Bezier curve fails, use a linear change of reference - ! potential densities in the transition zone. - ckt = (sigmar_1d(kt) - sig_pmin(kt)) & - /( sigmar_1d(kt) - sigmar_1d(kt-1) & - - sig_pmin (kt) + sig_pmin (kt-1)) - sig_up = sig_pmin (ktzmin-1)*ckt & - + sig_pmin (ktzmin )*(1._r8 - ckt) - sig_lo = sigmar_1d(ktzmax-1)*ckt & - + sigmar_1d(ktzmax )*(1._r8 - ckt) - dk = real(ktzmax - ktzmin, r8) - dki = 1._r8/dk - dsigdx_up = .5*( ( sig_pmin (ktzmin ) & - - sig_pmin (ktzmin-2))*ckt & - + ( sig_pmin (ktzmin+1) & - - sig_pmin (ktzmin-1))*(1. - ckt))*dk - dsigdx_lo = .5*( ( sigmar_1d(ktzmax ) & - - sigmar_1d(ktzmax-2))*ckt & - + ( sigmar_1d(ktzmax+1) & - - sigmar_1d(ktzmax-1))*(1. - ckt))*dk - dsigdx_up = max(0._r8, dsigdx_up) - if (dsigdx_lo <= dsigdx_up .or. & - sig_up - sig_lo <= - dsigdx_lo .or. & - sig_up - sig_lo >= - dsigdx_up) then - do k = ktzmin, ktzmax - 1 - x = (k - ktzmin + ckt)*dki - sig_trg(k) = sig_up*(1._r8 - x) + sig_lo*x - enddo - else - xi = (sig_up - sig_lo + dsigdx_lo) & - /(dsigdx_lo - dsigdx_up) - si = ( dsigdx_lo*(sig_up + dsigdx_up) & - - dsigdx_up*sig_lo)/(dsigdx_lo - dsigdx_up) - if (abs(xi - .5_r8) < x_eps) then - do k = ktzmin, ktzmax-1 - t = (k - ktzmin + ckt)*dki - sig_trg(k) = & - (1._r8 - t)*((1._r8 - t)*sig_up + 2._r8*t*si) & - + t*t*sig_lo - enddo - else - do k = ktzmin, ktzmax-1 - x = (k - ktzmin + ckt)*dki - t = (sqrt(xi*(xi - 2_r8*x) + x) - xi) & - /(1._r8 - 2_r8*xi) - sig_trg(k) = & - (1._r8 - t)*((1._r8 - t)*sig_up + 2._r8*t*si) & - + t*t*sig_lo - enddo - endif - endif - kt = ktzmin - endif - exit - endif - p_dst(kt,i) = p_src(kt,i) + nudge_fac*(pmin(kt) - p_src(kt,i)) - p_dst(kt,i) = & - min(max(p_dst(kt,i), pmin(kt), & - p_dst(kt-1,i) + dpmin_interior), & - p_src(kk+1,i)) - stab_fac(kt,i) = 0._r8 - kt = kt + 1 - enddo - - ! Starting at the transition interface, nudge the interface - ! pressures to reduce the deviation from the interface reference - ! potential density. - - do k = kt, kk+1 - p_dst(k,i) = p_src(kk+1,i) - stab_fac(k,i) = 1._r8 - enddo - - do k = kt, min(ksmx(i), kdmx(i)) - if (sig_trg(k) < sig_srcdi(2,k-1) .and. & - sig_trg(k) < sig_srcdi(1,k )) then - dsig = sig_trg(k) - sig_srcdi(2,k-1) - dsigdx = dsigdt(t_srcdi(2,k-1,it,i), t_srcdi(2,k-1,is,i)) & - *dpeval1(tpc_src(:,k-1,it,i)) & - + dsigds(t_srcdi(2,k-1,it,i), t_srcdi(2,k-1,is,i)) & - *dpeval1(tpc_src(:,k-1,is,i)) - stab_fac(k,i) = dsigdx/dsigmar_1d(k-1) - dsigdx = dsigmar_1d(k-1)*max(stab_fac(k,i), stab_fac_limit) - p_dst(k,i) = p_src(k,i) & - + max(- .5_r8, dsig*nudge_fac/dsigdx) & - *(p_src(k,i) - p_src(k-1,i)) - elseif (sig_trg(k) > sig_srcdi(2,k-1) .and. & - sig_trg(k) > sig_srcdi(1,k )) then - dsig = sig_trg(k) - sig_srcdi(1,k) - dsigdx = dsigdt(t_srcdi(1,k,it,i), t_srcdi(1,k,is,i)) & - *dpeval0(tpc_src(:,k,it,i)) & - + dsigds(t_srcdi(1,k,it,i), t_srcdi(1,k,is,i)) & - *dpeval0(tpc_src(:,k,is,i)) - stab_fac(k,i) = dsigdx/dsigmar_1d(k) - dsigdx = dsigmar_1d(k)*max(stab_fac(k,i), stab_fac_limit) - p_dst(k,i) = p_src(k,i) & - + min(.5_r8, dsig*nudge_fac/dsigdx) & - *(p_src(k+1,i) - p_src(k,i)) - else - dsigdx_up = dsigdt(t_srcdi(2,k-1,it,i), t_srcdi(2,k-1,is,i)) & - *dpeval1(tpc_src(:,k-1,it,i)) & - + dsigds(t_srcdi(2,k-1,it,i), t_srcdi(2,k-1,is,i)) & - *dpeval1(tpc_src(:,k-1,is,i)) - dsigdx_lo = dsigdt(t_srcdi(1,k,it,i), t_srcdi(1,k,is,i)) & - *dpeval0(tpc_src(:,k,it,i)) & - + dsigds(t_srcdi(1,k,it,i), t_srcdi(1,k,is,i)) & - *dpeval0(tpc_src(:,k,is,i)) - dp_up = max(p_src(k ,i) - p_src(k-1,i), epsilp) - dp_lo = max(p_src(k+1,i) - p_src(k ,i), epsilp) - sig_intrp = ( (sig_srcdi(1,k ) + .5_r8*dsigdx_lo)*dp_up & - + (sig_srcdi(2,k-1) - .5_r8*dsigdx_up)*dp_lo) & - /(dp_up + dp_lo) - sig_intrp = max(min(sig_srcdi(2,k-1),sig_srcdi(1,k)), & - min(max(sig_srcdi(2,k-1),sig_srcdi(1,k)), & - sig_intrp)) - dsig = sig_trg(k) - sig_intrp - if (dsig < 0._r8) then - dsigdx = dsigdx_up + 2._r8*(sig_intrp - sig_srcdi(2,k-1)) - stab_fac(k,i) = dsigdx/dsigmar_1d(k-1) - dsigdx = dsigmar_1d(k-1)*max(stab_fac(k,i), stab_fac_limit) - p_dst(k,i) = p_src(k,i) & - + max(- .5_r8, dsig*nudge_fac/dsigdx) & - *(p_src(k,i) - p_src(k-1,i)) - else - dsigdx = dsigdx_lo + 2._r8*(sig_srcdi(1,k ) - sig_intrp) - stab_fac(k,i) = dsigdx/dsigmar_1d(k) - dsigdx = dsigmar_1d(k)*max(stab_fac(k,i), stab_fac_limit) - p_dst(k,i) = p_src(k,i) & - + min(.5_r8, dsig*nudge_fac/dsigdx) & - *(p_src(k+1,i) - p_src(k,i)) - endif - endif - p_dst(k,i) = & - min(max(p_dst(k,i), pmin(k), p_dst(k-1,i) + dpmin_interior), & - p_src(kk+1,i)) - enddo - - do k = max(kt, min(ksmx(i), kdmx(i))) + 1, kdmx(i) - if (sig_trg(k) < sig_srcdi(2,ksmx(i))) then - dsig = sig_trg(k) - sig_srcdi(2,ksmx(i)) - dsigdx = dsigdt(t_srcdi(2,ksmx(i),it,i), & - t_srcdi(2,ksmx(i),is,i)) & - *dpeval1(tpc_src(:,ksmx(i),it,i)) & - + dsigds(t_srcdi(2,ksmx(i),it,i), & - t_srcdi(2,ksmx(i),is,i)) & - *dpeval1(tpc_src(:,ksmx(i),is,i)) - stab_fac(k,i) = dsigdx/dsigmar_1d(ksmx(i)-1) - dsigdx = dsigmar_1d(ksmx(i)-1) & - *max(stab_fac(k,i), stab_fac_limit) - p_dst(k,i) = p_src(kk+1,i) & - + max(- .5_r8, dsig*nudge_fac/dsigdx) & - *(p_src(kk+1,i) - p_src(ksmx(i),i)) - p_dst(k,i) = & - min(max(p_dst(k,i), pmin(k), & - p_dst(k-1,i) + dpmin_interior), & - p_src(kk+1,i)) - endif - enddo - - enddo - enddo - - end subroutine cntiso_regrid_nudge_jslice - - subroutine cntiso_regrid_smooth_jslice(p_dst_rs, stab_fac_rs, & - smtflxconv_rs, & - i_lb, i_ub, j, jp_rs, jn_rs) - - real(r8), dimension(:,1-nbdy:,:), intent(inout) :: & - p_dst_rs, stab_fac_rs, smtflxconv_rs - integer, intent(in) :: i_lb, i_ub, j, jp_rs, jn_rs - - real(r8) :: cdiff, difmx, flxhi, flxlo, flx, q, sdiff - integer :: l, i, k - - smtflxconv_rs(:,:,jn_rs) = 0._r8 - - do l = 1, isu(j+1) - do i = max(i_lb, ifu(j+1,l)), min(i_ub+1, ilu(j+1,l)) - cdiff = delt1*scuy(i,j+1)*scuxi(i,j+1) - difmx = .5_r8*(difmxp(i-1,j+1) + difmxp(i,j+1)) - do k = 2, kk - flxhi = .125_r8*min(( p_dst_rs(k, i-1,jn_rs) & - - p_dst_rs(k-1,i-1,jn_rs))*scp2(i-1,j+1), & - ( p_dst_rs(k+1,i ,jn_rs) & - - p_dst_rs(k ,i ,jn_rs))*scp2(i ,j+1)) - flxlo = - .125_r8*min(( p_dst_rs(k ,i ,jn_rs) & - - p_dst_rs(k-1,i ,jn_rs))*scp2(i ,j+1), & - ( p_dst_rs(k+1,i-1,jn_rs) & - - p_dst_rs(k ,i-1,jn_rs))*scp2(i-1,j+1)) - q = .5_r8*( max(0._r8, min(stab_fac_limit, & - stab_fac_rs(k,i-1,jn_rs))) & - + max(0._r8, min(stab_fac_limit, & - stab_fac_rs(k,i ,jn_rs)))) - sdiff = min((stab_fac_limit - q)*smooth_diff_max & - /stab_fac_limit, difmx) - flx = min(flxhi, max(flxlo, & - cdiff*sdiff*( p_dst_rs(k,i-1,jn_rs) & - - p_dst_rs(k,i ,jn_rs)))) - smtflxconv_rs(k,i-1,jn_rs) = smtflxconv_rs(k,i-1,jn_rs) + flx - smtflxconv_rs(k,i ,jn_rs) = smtflxconv_rs(k,i ,jn_rs) - flx - enddo - enddo - enddo - - do l = 1, isv(j+1) - do i = max(i_lb, ifv(j+1,l)), min(i_ub, ilv(j+1,l)) - cdiff = delt1*scvx(i,j+1)*scvyi(i,j+1) - difmx = .5_r8*(difmxp(i,j) + difmxp(i,j+1)) - do k = 2, kk - flxhi = .125_r8*min(( p_dst_rs(k, i,jp_rs) & - - p_dst_rs(k-1,i,jp_rs))*scp2(i,j ), & - ( p_dst_rs(k+1,i,jn_rs) & - - p_dst_rs(k ,i,jn_rs))*scp2(i,j+1)) - flxlo = - .125_r8*min(( p_dst_rs(k ,i,jn_rs) & - - p_dst_rs(k-1,i,jn_rs))*scp2(i,j+1), & - ( p_dst_rs(k+1,i,jp_rs) & - - p_dst_rs(k ,i,jp_rs))*scp2(i,j )) - q = .5_r8*( max(0._r8, min(stab_fac_limit, & - stab_fac_rs(k,i,jp_rs))) & - + max(0._r8, min(stab_fac_limit, & - stab_fac_rs(k,i,jn_rs)))) - sdiff = min((stab_fac_limit - q)*smooth_diff_max & - /stab_fac_limit, difmx) - flx = min(flxhi, max(flxlo, & - cdiff*sdiff*( p_dst_rs(k,i,jp_rs) & - - p_dst_rs(k,i,jn_rs)))) - smtflxconv_rs(k,i,jp_rs) = smtflxconv_rs(k,i,jp_rs) + flx - smtflxconv_rs(k,i,jn_rs) = smtflxconv_rs(k,i,jn_rs) - flx - enddo - enddo - enddo - - do l = 1, isp(j) - do i = max(i_lb, ifp(j,l)), min(i_ub, ilp(j,l)) - do k = 2, kk - p_dst_rs(k,i,jp_rs) = p_dst_rs(k,i,jp_rs) & - - smtflxconv_rs(k,i,jp_rs)*scp2i(i,j) - enddo - enddo - enddo - - end subroutine cntiso_regrid_smooth_jslice - - subroutine copy_jslice_to_3d(p_dst, trc_rm, i_lb, i_ub, j, nn) - - real(r8), dimension(:,1-nbdy:), intent(in) :: p_dst - real(r8), dimension(:,:,1-nbdy:), intent(in) :: trc_rm - - integer, intent(in) :: i_lb, i_ub, j, nn - - integer :: l, i, k, kn, nt - - do l = 1, isp(j) - do i = max(i_lb, ifp(j,l)), min(i_ub, ilp(j,l)) - - do k = 1, kk - kn = k + nn - temp(i,j,kn) = trc_rm(k,1,i) - saln(i,j,kn) = trc_rm(k,2,i) - dp(i,j,kn) = p_dst(k+1,i) - p_dst(k,i) - sigma(i,j,kn) = sig(trc_rm(k,1,i), trc_rm(k,2,i)) - if (use_TRC) then - do nt = 1, ntr - trc(i,j,kn,nt) = trc_rm(k,nt+2,i) - enddo - end if - enddo - - enddo - enddo - - end subroutine copy_jslice_to_3d - - subroutine readnml_vcoord - ! --------------------------------------------------------------------------- - ! Read variables in the namelist group 'vcoord' and resolve options. - ! --------------------------------------------------------------------------- - character(len = 80) :: nml_fname - integer :: ios + real(r8) :: dpmin + integer :: nfu, ios, k logical :: fexist - integer :: nfu namelist /vcoord/ & - vcoord_type, reconstruction_method, upper_bndr_ord, lower_bndr_ord, & - density_limiting, tracer_limiting, velocity_limiting, & - density_pc_upper_bndr, density_pc_lower_bndr, & - tracer_pc_upper_bndr, tracer_pc_lower_bndr, & - velocity_pc_upper_bndr, velocity_pc_lower_bndr, & - dpmin_surface, dpmin_inflation_factor, dpmin_interior, & - regrid_nudge_ts, stab_fac_limit, smooth_diff_max, dktzu, dktzl + vcoord_type, dpmin_surface, dpmin_inflation_factor, & + sigref_spec, plevel_spec, sigref, plevel + + real(r8), parameter :: iM_mks2cgs = 1._r8/M_mks2cgs ! Read variables in the namelist group 'vcoord'. if (mnproc == 1) then @@ -966,131 +112,99 @@ subroutine readnml_vcoord call xcbcst(ios) if (ios /= 0) then if (mnproc == 1) & - write (lp,*) 'readnml_vcoord: No vertical coordinate variable '// & - 'group found in namelist. Using defaults.' + write (lp,*) 'readnml_vcoord: No vertical coordinate variable '// & + 'group found in namelist. Using defaults.' else call xcbcst(vcoord_type) - call xcbcst(reconstruction_method) - call xcbcst(upper_bndr_ord) - call xcbcst(lower_bndr_ord) - call xcbcst(density_limiting) - call xcbcst(tracer_limiting) - call xcbcst(velocity_limiting) - call xcbcst(density_pc_upper_bndr) - call xcbcst(density_pc_lower_bndr) - call xcbcst(tracer_pc_upper_bndr) - call xcbcst(tracer_pc_lower_bndr) - call xcbcst(velocity_pc_upper_bndr) - call xcbcst(velocity_pc_lower_bndr) call xcbcst(dpmin_surface) call xcbcst(dpmin_inflation_factor) - call xcbcst(dpmin_interior) - call xcbcst(regrid_nudge_ts) - call xcbcst(stab_fac_limit) - call xcbcst(smooth_diff_max) - call xcbcst(dktzu) - call xcbcst(dktzl) + call xcbcst(sigref_spec) + call xcbcst(plevel_spec) + call xcbcst(sigref) + call xcbcst(plevel) endif if (mnproc == 1) then write (lp,*) 'readnml_vcoord: vertical coordinate variables:' - write (lp,*) ' vcoord_type = ', & - trim(vcoord_type) - write (lp,*) ' reconstruction_method = ', & - trim(reconstruction_method) - write (lp,*) ' upper_bndr_ord = ', upper_bndr_ord - write (lp,*) ' lower_bndr_ord = ', lower_bndr_ord - write (lp,*) ' density_limiting = ', & - trim(density_limiting) - write (lp,*) ' tracer_limiting = ', & - trim(tracer_limiting) - write (lp,*) ' velocity_limiting = ', & - trim(velocity_limiting) - write (lp,*) ' density_pc_upper_bndr = ', density_pc_upper_bndr - write (lp,*) ' density_pc_lower_bndr = ', density_pc_lower_bndr - write (lp,*) ' tracer_pc_upper_bndr = ', tracer_pc_upper_bndr - write (lp,*) ' tracer_pc_lower_bndr = ', tracer_pc_lower_bndr - write (lp,*) ' velocity_pc_upper_bndr = ', velocity_pc_upper_bndr - write (lp,*) ' velocity_pc_lower_bndr = ', velocity_pc_lower_bndr + write (lp,*) ' vcoord_type = ', trim(vcoord_type) write (lp,*) ' dpmin_surface = ', dpmin_surface write (lp,*) ' dpmin_inflation_factor = ', dpmin_inflation_factor - write (lp,*) ' dpmin_interior = ', dpmin_interior - write (lp,*) ' regrid_nudge_ts = ', regrid_nudge_ts - write (lp,*) ' stab_fac_limit = ', stab_fac_limit - write (lp,*) ' smooth_diff_max = ', smooth_diff_max - write (lp,*) ' dktzu = ', dktzu - write (lp,*) ' dktzl = ', dktzl + write (lp,*) ' sigref_spec = ', trim(sigref_spec) + write (lp,*) ' plevel_spec = ', trim(plevel_spec) endif + ! Change units from [m] to [g cm-1 s-2] of depth interval variables. + dpmin_surface = dpmin_surface*onem + ! Resolve options. select case (trim(vcoord_type)) - case ('isopyc_bulkml') - vcoord_type_tag = isopyc_bulkml - case ('cntiso_hybrid') - vcoord_type_tag = cntiso_hybrid - case default - if (mnproc == 1) & - write (lp,'(3a)') & - ' readnml_vcoord: vcoord_type = ', & - trim(vcoord_type), ' is unsupported!' - call xcstop('(readnml_vcoord)') - stop '(readnml_vcoord)' + case ('isopyc_bulkml') + vcoord_tag = vcoord_isopyc_bulkml + case ('cntiso_hybrid') + vcoord_tag = vcoord_cntiso_hybrid + case ('plevel') + vcoord_tag = vcoord_plevel + case default + if (mnproc == 1) & + write (lp,'(3a)') ' readnml_vcoord: vcoord_type = ', & + trim(vcoord_type), ' is unsupported!' + call xcstop('(readnml_vcoord)') + stop '(readnml_vcoord)' end select - select case (trim(reconstruction_method)) - case ('plm') - reconstruction_method_tag = hor3map_plm - case ('ppm') - reconstruction_method_tag = hor3map_ppm - case ('pqm') - reconstruction_method_tag = hor3map_pqm - case default - if (mnproc == 1) & - write (lp,'(3a)') & - ' readnml_vcoord: reconstruction_method = ', & - trim(reconstruction_method), ' is unsupported!' - call xcstop('(readnml_vcoord)') - stop '(readnml_vcoord)' - end select - select case (trim(density_limiting)) - case ('monotonic') - density_limiting_tag = hor3map_monotonic - case default - if (mnproc == 1) & - write (lp,'(3a)') & - ' readnml_vcoord: density_limiting = ', & - trim(density_limiting), ' is unsupported!' - call xcstop('(readnml_vcoord)') - stop '(readnml_vcoord)' - end select - select case (trim(tracer_limiting)) - case ('monotonic') - tracer_limiting_tag = hor3map_monotonic - case ('non_oscillatory') - tracer_limiting_tag = hor3map_non_oscillatory - case default - if (mnproc == 1) & - write (lp,'(3a)') & - ' readnml_vcoord: tracer_limiting = ', & - trim(tracer_limiting), ' is unsupported!' - call xcstop('(readnml_vcoord)') - stop '(readnml_vcoord)' - end select - select case (trim(velocity_limiting)) - case ('monotonic') - velocity_limiting_tag = hor3map_monotonic - case ('non_oscillatory') - velocity_limiting_tag = hor3map_non_oscillatory - case default - if (mnproc == 1) & - write (lp,'(3a)') & - ' readnml_vcoord: velocity_limiting = ', & - trim(velocity_limiting), ' is unsupported!' - call xcstop('(readnml_vcoord)') - stop '(readnml_vcoord)' - end select - - ! Change units from [m] to [g cm-1 s-2] of depth interval variables. - dpmin_surface = dpmin_surface*onem - dpmin_interior = dpmin_interior*onem + if (vcoord_tag /= vcoord_isopyc_bulkml) then + select case (trim(sigref_spec)) + case ('inicon') + case ('namelist') + k = 1 + do while (sigref(k) /= spval) + k = k + 1 + if (k > kdm_max) exit + enddo + if (k /= kdm + 1) then + if (mnproc == 1) & + write (lp,'(3a)') & + ' readnml_vcoord: number of sigref values does not match vertical dimension!' + call xcstop('(readnml_vcoord)') + stop '(readnml_vcoord)' + endif + sigref(:) = sigref(:)*iM_mks2cgs + case default + if (mnproc == 1) & + write (lp,'(3a)') ' readnml_vcoord: sigref_spec = ', & + trim(sigref_spec), ' is unsupported!' + call xcstop('(readnml_vcoord)') + stop '(readnml_vcoord)' + end select + select case (trim(plevel_spec)) + case ('inflation') + dpmin = dpmin_surface + plevel(1) = 0._r8 + do k = 1, kk - 1 + plevel(k+1) = plevel(k) + dpmin + dpmin = dpmin*dpmin_inflation_factor + enddo + case ('namelist') + k = 1 + do while (plevel(k) /= spval) + k = k + 1 + if (k > kdm_max) exit + enddo + if (k /= kdm + 1) then + if (mnproc == 1) & + write (lp,'(3a)') & + ' readnml_vcoord: number of plevel values does not match vertical dimension!' + call xcstop('(readnml_vcoord)') + stop '(readnml_vcoord)' + endif + ! Change units from [m] to [g cm-1 s-2]. + plevel(:) = plevel(:)*onem + case default + if (mnproc == 1) & + write (lp,'(3a)') ' readnml_vcoord: plevel_spec = ', & + trim(plevel_spec), ' is unsupported!' + call xcstop('(readnml_vcoord)') + stop '(readnml_vcoord)' + end select + endif end subroutine readnml_vcoord @@ -1099,703 +213,31 @@ subroutine inivar_vcoord ! Initialize arrays and data structures. ! --------------------------------------------------------------------------- - integer :: i, j, k, nt, errstat - - !$omp parallel do private(i, k) - do j = 1-nbdy, jj+nbdy - do k = 1, kk - do i = 1-nbdy, ii+nbdy - sigmar(i,j,k) = spval - enddo - enddo - enddo - !$omp end parallel do - - if (use_TRC) then - ! Local number of tracers where temperature and salinity is added to the - ! ntr parameter. - ntr_loc = ntr + 2 - else - ! Local number of tracers consisting of temperature and salinity. - ntr_loc = 2 - end if - - ! Allocate reconstruction data structures for tracer source data. - allocate(trc_rcss(ntr_loc), stat = errstat) - if (errstat /= 0) then - write(lp,*) 'Failed to allocate trc_rcss!' - call xchalt('(inivar_vcoord)') - stop '(inivar_vcoord)' - endif - - ! Configuration of the reconstruction data structure that only depends on - ! the source grid. - rcgs%n_src = kk - if (ltedtp_opt == ltedtp_neutral) then - rcgs%i_lbound = -1 - rcgs%i_ubound = ii + 2 - rcgs%j_ubound = 3 - else - rcgs%i_lbound = 0 - rcgs%i_ubound = ii + 1 - rcgs%j_ubound = 2 - endif - rcgs%method = reconstruction_method_tag - rcgs%left_bndr_ord = upper_bndr_ord - rcgs%right_bndr_ord = lower_bndr_ord - - ! Configuration of reconstruction data structures that is specific to - ! various source data. - - d_rcss%limiting = density_limiting_tag - d_rcss%pc_left_bndr = density_pc_upper_bndr - d_rcss%pc_right_bndr = density_pc_lower_bndr - - trc_rcss(1)%limiting = tracer_limiting_tag - trc_rcss(1)%pc_left_bndr = tracer_pc_upper_bndr - trc_rcss(1)%pc_right_bndr = tracer_pc_lower_bndr - if (tracer_limiting_tag == hor3map_non_oscillatory) then - do nt = 2, ntr_loc - trc_rcss(nt)%limiting = hor3map_non_oscillatory_posdef - trc_rcss(nt)%pc_left_bndr = tracer_pc_upper_bndr - trc_rcss(nt)%pc_right_bndr = tracer_pc_lower_bndr - enddo - else - do nt = 2, ntr_loc - trc_rcss(nt)%limiting = tracer_limiting_tag - trc_rcss(nt)%pc_left_bndr = tracer_pc_upper_bndr - trc_rcss(nt)%pc_right_bndr = tracer_pc_lower_bndr - enddo - endif - - v_rcss%limiting = velocity_limiting_tag - v_rcss%pc_left_bndr = velocity_pc_upper_bndr - v_rcss%pc_right_bndr = velocity_pc_lower_bndr - - ! Configuration of remapping data structure. - rms%n_dst = kk - - ! Initialize reconstruction and remapping data structures. - - errstat = initialize_rcgs(rcgs) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(inivar_vcoord)') - stop '(inivar_vcoord)' - endif - - errstat = initialize_rcss(rcgs, d_rcss) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(inivar_vcoord)') - stop '(inivar_vcoord)' - endif - - do nt = 1, ntr_loc - errstat = initialize_rcss(rcgs, trc_rcss(nt)) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(inivar_vcoord)') - stop '(inivar_vcoord)' - endif - enddo - - errstat = initialize_rcss(rcgs, v_rcss) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(inivar_vcoord)') - stop '(inivar_vcoord)' - endif - - errstat = initialize_rms(rcgs, rms) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(inivar_vcoord)') - stop '(inivar_vcoord)' - endif - - end subroutine inivar_vcoord - - subroutine cntiso_hybrid_regrid_direct_remap(m, n, mm, nn, k1m, k1n) - - integer, intent(in) :: m, n, mm, nn, k1m, k1n - - integer, parameter :: p_ord = 4 - - real(r8), dimension(kdm+1,1-nbdy:idm+nbdy,2) :: p_src_rs, p_dst_rs - real(r8), dimension(p_ord+1,kdm,ntr_loc,1-nbdy:idm+nbdy,2) :: tpc_src_rs - real(r8), dimension(2,kdm,ntr_loc,1-nbdy:idm+nbdy,2) :: t_srcdi_rs - real(r8), dimension(2,kdm,1-nbdy:idm+nbdy,2) :: & - p_srcdi_rs, drhodt_srcdi_rs, drhods_srcdi_rs - real(r8), dimension(kdm,ntr_loc,1-nbdy:idm+nbdy,2) :: flxconv_rs - real(r8), dimension(kdm,ntr_loc,1-nbdy:idm+nbdy) :: trc_rm - integer, dimension(1-nbdy:idm+nbdy,2) :: ksmx_rs, kdmx_rs - integer :: j_rs, jm_rs, jp_rs, j, nt - - if (ltedtp_opt /= ltedtp_neutral) then - - j_rs = 1 - - do j = 1, jj - call prep_recon_jslice (p_src_rs(:,:,j_rs), & - ksmx_rs(:,j_rs), & - 1, ii, j, j_rs, nn) - call recon_trc_jslice (ksmx_rs(:,j_rs), & - tpc_src_rs(:,:,:,:,j_rs), & - t_srcdi_rs(:,:,:,:,j_rs), & - 1, ii, j, j_rs, nn) - call cntiso_regrid_direct_jslice(p_src_rs(:,:,j_rs), & - p_dst_rs(:,:,j_rs), & - 1, ii, j, j_rs, nn) - call remap_trc_jslice (p_dst_rs(:,:,j_rs), & - trc_rm, & - 1, ii, j, j_rs) - call copy_jslice_to_3d (p_dst_rs(:,:,j_rs), & - trc_rm, & - 1, ii, j, nn) - enddo - - else - - call xctilr(dp (1-nbdy,1-nbdy,k1n), 1, kk, 1, 1, halo_ps) - call xctilr(temp (1-nbdy,1-nbdy,k1n), 1, kk, 1, 1, halo_ps) - call xctilr(saln (1-nbdy,1-nbdy,k1n), 1, kk, 1, 1, halo_ps) - call xctilr(sigma(1-nbdy,1-nbdy,k1n), 1, kk, 1, 1, halo_ps) - if (use_TRC) then - do nt = 1, ntr - !# if defined(TKE) && !defined(TKEIDF) - ! if (nt == itrtke .or. nt == itrgls) cycle - !# endif - call xctilr(trc(1-nbdy,1-nbdy,k1n,nt), 1, kk, 1, 1, halo_ps) - enddo - end if - call xctilr(difiso, 1,kk, 1,1, halo_ps) - - jm_rs = 1 - jp_rs = 2 - - do j = -1, 0 - jm_rs = 3 - jm_rs - jp_rs = 3 - jp_rs - call prep_recon_jslice (p_src_rs(:,:,jp_rs), & - ksmx_rs(:,jp_rs), & - 0, ii+1, j+1, jp_rs, nn) - call recon_trc_jslice (ksmx_rs(:,jp_rs), & - tpc_src_rs(:,:,:,:,jp_rs), & - t_srcdi_rs(:,:,:,:,jp_rs), & - 0, ii+1, j+1, jp_rs, nn) - call cntiso_regrid_direct_jslice(p_src_rs(:,:,jp_rs), & - p_dst_rs(:,:,jp_rs), & - 0, ii+1, j+1, jp_rs, nn) - call ndiff_prep_jslice (p_src_rs, ksmx_rs, & - tpc_src_rs, t_srcdi_rs, & - p_dst_rs, kdmx_rs, p_srcdi_rs, & - drhodt_srcdi_rs, drhods_srcdi_rs, & - flxconv_rs, & - 0, ii+1, j+1, jp_rs, mm) - enddo - - j = 0 - call ndiff_vflx_jslice(ksmx_rs, tpc_src_rs, t_srcdi_rs, & - p_dst_rs, kdmx_rs, p_srcdi_rs, & - drhodt_srcdi_rs, drhods_srcdi_rs, & - flxconv_rs, & - ntr_loc, 1, ii, j+1, & - jm_rs, jp_rs, mm, nn) - - do j = 1, jj - jm_rs = 3 - jm_rs - jp_rs = 3 - jp_rs - call prep_recon_jslice (p_src_rs(:,:,jp_rs), & - ksmx_rs(:,jp_rs), & - 0, ii+1, j+1, jp_rs, nn) - call recon_trc_jslice (ksmx_rs(:,jp_rs), & - tpc_src_rs(:,:,:,:,jp_rs), & - t_srcdi_rs(:,:,:,:,jp_rs), & - 0, ii+1, j+1, jp_rs, nn) - call cntiso_regrid_direct_jslice(p_src_rs(:,:,jp_rs), & - p_dst_rs(:,:,jp_rs), & - 0, ii+1, j+1, jp_rs, nn) - call ndiff_prep_jslice (p_src_rs, ksmx_rs, & - tpc_src_rs, t_srcdi_rs, & - p_dst_rs, kdmx_rs, p_srcdi_rs, & - drhodt_srcdi_rs, drhods_srcdi_rs, & - flxconv_rs, & - 0, ii+1, j+1, jp_rs, mm) - call ndiff_uflx_jslice (ksmx_rs, tpc_src_rs, t_srcdi_rs, & - p_dst_rs, kdmx_rs, p_srcdi_rs, & - drhodt_srcdi_rs, drhods_srcdi_rs, & - flxconv_rs, & - ntr_loc, 1, ii+1, j, & - jm_rs, mm, nn) - call ndiff_vflx_jslice (ksmx_rs, tpc_src_rs, t_srcdi_rs, & - p_dst_rs, kdmx_rs, p_srcdi_rs, & - drhodt_srcdi_rs, drhods_srcdi_rs, & - flxconv_rs, & - ntr_loc, 1, ii, j+1, & - jm_rs, jp_rs, mm, nn) - call remap_trc_jslice (p_dst_rs(:,:,jm_rs), trc_rm, & - 1, ii, j, jm_rs) - call ndiff_update_trc_jslice (p_dst_rs, flxconv_rs, trc_rm, & - ntr_loc, 1, ii, j, jm_rs) - call copy_jslice_to_3d (p_dst_rs(:,:,jm_rs), & - trc_rm, & - 1, ii, j, nn) - enddo - - endif - - if (csdiag) then - if (mnproc == 1) then - write (lp,*) 'cntiso_hybrid_regrid_direct_remap:' - endif - call chksummsk(dp (1-nbdy,1-nbdy,k1n), ip, kk, 'dp') - call chksummsk(temp (1-nbdy,1-nbdy,k1n), ip, kk, 'temp') - call chksummsk(saln (1-nbdy,1-nbdy,k1n), ip, kk, 'saln') - call chksummsk(sigma(1-nbdy,1-nbdy,k1n), ip, kk, 'sigma') - call chksummsk(sigmar, ip, kk, 'sigmar') - if (use_TRC) then - do nt = 1, ntr - call chksummsk(trc(1-nbdy,1-nbdy,k1n,nt), ip, kk, 'trc') - enddo - end if - endif - - end subroutine cntiso_hybrid_regrid_direct_remap - - subroutine cntiso_hybrid_regrid_remap(m, n, mm, nn, k1m, k1n) - - integer, intent(in) :: m, n, mm, nn, k1m, k1n + integer :: i, j, k - integer, parameter :: p_ord = 4 - - real(r8), dimension(kdm+1,1-nbdy:idm+nbdy,3) :: & - p_src_rs, p_dst_rs, stab_fac_rs, smtflxconv_rs - real(r8), dimension(p_ord+1,kdm,ntr_loc,1-nbdy:idm+nbdy,3) :: tpc_src_rs - real(r8), dimension(2,kdm,ntr_loc,1-nbdy:idm+nbdy,3) :: t_srcdi_rs - real(r8), dimension(2,kdm,1-nbdy:idm+nbdy,3) :: & - p_srcdi_rs, drhodt_srcdi_rs, drhods_srcdi_rs - real(r8), dimension(kdm,ntr_loc,1-nbdy:idm+nbdy,3) :: flxconv_rs - real(r8), dimension(kdm,ntr_loc,1-nbdy:idm+nbdy) :: trc_rm - integer, dimension(1-nbdy:idm+nbdy,3) :: ksmx_rs, kdmx_rs - integer :: j_rs, jm_rs, jp_rs, jn_rs, j, nt - - smtflxconv_rs(:,:,:) = 0._r8 - - if (ltedtp_opt /= ltedtp_neutral) then - - call xctilr(dp (1-nbdy,1-nbdy,k1n), 1, kk, 1, 1, halo_ps) - call xctilr(temp (1-nbdy,1-nbdy,k1n), 1, kk, 1, 1, halo_ps) - call xctilr(saln (1-nbdy,1-nbdy,k1n), 1, kk, 1, 1, halo_ps) - call xctilr(sigma(1-nbdy,1-nbdy,k1n), 1, kk, 1, 1, halo_ps) - - jm_rs = 1 - jp_rs = 2 - - do j = -1, 0 - jm_rs = 3 - jm_rs - jp_rs = 3 - jp_rs - call prep_recon_jslice (p_src_rs(:,:,jp_rs), & - ksmx_rs(:,jp_rs), & - 0, ii+1, j+1, jp_rs, nn) - call recon_trc_jslice (ksmx_rs(:,jp_rs), & - tpc_src_rs(:,:,:,:,jp_rs), & - t_srcdi_rs(:,:,:,:,jp_rs), & - 0, ii+1, j+1, jp_rs, nn) - call cntiso_regrid_nudge_jslice(p_src_rs(:,:,jp_rs), & - ksmx_rs(:,jp_rs), & - tpc_src_rs(:,:,:,:,jp_rs), & - t_srcdi_rs(:,:,:,:,jp_rs), & - p_dst_rs(:,:,jp_rs), & - stab_fac_rs(:,:,jp_rs), & - 0, ii+1, j+1, jp_rs) - enddo - - j = 0 - call cntiso_regrid_smooth_jslice(p_dst_rs, stab_fac_rs, & - smtflxconv_rs, & - 1, ii, j, jm_rs, jp_rs) - - do j = 1, jj - jm_rs = 3 - jm_rs - jp_rs = 3 - jp_rs - call prep_recon_jslice (p_src_rs(:,:,jp_rs), & - ksmx_rs(:,jp_rs), & - 0, ii+1, j+1, jp_rs, nn) - call recon_trc_jslice (ksmx_rs(:,jp_rs), & - tpc_src_rs(:,:,:,:,jp_rs), & - t_srcdi_rs(:,:,:,:,jp_rs), & - 0, ii+1, j+1, jp_rs, nn) - call cntiso_regrid_nudge_jslice (p_src_rs(:,:,jp_rs), & - ksmx_rs(:,jp_rs), & - tpc_src_rs(:,:,:,:,jp_rs), & - t_srcdi_rs(:,:,:,:,jp_rs), & - p_dst_rs(:,:,jp_rs), & - stab_fac_rs(:,:,jp_rs), & - 0, ii+1, j+1, jp_rs) - call cntiso_regrid_smooth_jslice(p_dst_rs, stab_fac_rs, & - smtflxconv_rs, & - 1, ii, j, jm_rs, jp_rs) - call remap_trc_jslice (p_dst_rs(:,:,jm_rs), & - trc_rm, & - 1, ii, j, jm_rs) - call copy_jslice_to_3d (p_dst_rs(:,:,jm_rs), & - trc_rm, & - 1, ii, j, nn) - enddo - - else - - call xctilr(dp (1-nbdy,1-nbdy,k1n), 1, kk, 2, 2, halo_ps) - call xctilr(temp (1-nbdy,1-nbdy,k1n), 1, kk, 2, 2, halo_ps) - call xctilr(saln (1-nbdy,1-nbdy,k1n), 1, kk, 2, 2, halo_ps) - call xctilr(sigma(1-nbdy,1-nbdy,k1n), 1, kk, 2, 2, halo_ps) - if (use_TRC) then - do nt = 1, ntr - !# if defined(TKE) && !defined(TKEIDF) - ! if (nt == itrtke .or. nt == itrgls) cycle - !# endif - call xctilr(trc(1-nbdy,1-nbdy,k1n,nt), 1, kk, 1, 1, halo_ps) - enddo - end if - call xctilr(difiso, 1,kk, 1,1, halo_ps) - - j = -3 - jm_rs = 1 - jp_rs = 2 - jn_rs = 3 - call prep_recon_jslice (p_src_rs(:,:,jn_rs), & - ksmx_rs(:,jn_rs), & - -1, ii+2, j+2, jn_rs, nn) - call recon_trc_jslice (ksmx_rs(:,jn_rs), & - tpc_src_rs(:,:,:,:,jn_rs), & - t_srcdi_rs(:,:,:,:,jn_rs), & - -1, ii+2, j+2, jn_rs, nn) - call cntiso_regrid_nudge_jslice(p_src_rs(:,:,jn_rs), & - ksmx_rs(:,jn_rs), & - tpc_src_rs(:,:,:,:,jn_rs), & - t_srcdi_rs(:,:,:,:,jn_rs), & - p_dst_rs(:,:,jn_rs), & - stab_fac_rs(:,:,jn_rs), & - -1, ii+2, j+2, jn_rs) - - j = -2 - jm_rs = jp_rs - jp_rs = jn_rs - jn_rs = mod(jn_rs,3) + 1 - call prep_recon_jslice (p_src_rs(:,:,jn_rs), & - ksmx_rs(:,jn_rs), & - -1, ii+2, j+2, jn_rs, nn) - call recon_trc_jslice (ksmx_rs(:,jn_rs), & - tpc_src_rs(:,:,:,:,jn_rs), & - t_srcdi_rs(:,:,:,:,jn_rs), & - -1, ii+2, j+2, jn_rs, nn) - call cntiso_regrid_nudge_jslice (p_src_rs(:,:,jn_rs), & - ksmx_rs(:,jn_rs), & - tpc_src_rs(:,:,:,:,jn_rs), & - t_srcdi_rs(:,:,:,:,jn_rs), & - p_dst_rs(:,:,jn_rs), & - stab_fac_rs(:,:,jn_rs), & - -1, ii+2, j+2, jn_rs) - call cntiso_regrid_smooth_jslice(p_dst_rs, stab_fac_rs, & - smtflxconv_rs, & - 0, ii+1, j+1, jp_rs, jn_rs) - - do j = -1, 0 - jm_rs = jp_rs - jp_rs = jn_rs - jn_rs = mod(jn_rs,3) + 1 - call prep_recon_jslice (p_src_rs(:,:,jn_rs), & - ksmx_rs(:,jn_rs), & - -1, ii+2, j+2, jn_rs, nn) - call recon_trc_jslice (ksmx_rs(:,jn_rs), & - tpc_src_rs(:,:,:,:,jn_rs), & - t_srcdi_rs(:,:,:,:,jn_rs), & - -1, ii+2, j+2, jn_rs, nn) - call cntiso_regrid_nudge_jslice (p_src_rs(:,:,jn_rs), & - ksmx_rs(:,jn_rs), & - tpc_src_rs(:,:,:,:,jn_rs), & - t_srcdi_rs(:,:,:,:,jn_rs), & - p_dst_rs(:,:,jn_rs), & - stab_fac_rs(:,:,jn_rs), & - -1, ii+2, j+2, jn_rs) - call cntiso_regrid_smooth_jslice(p_dst_rs, stab_fac_rs, & - smtflxconv_rs, & - 0, ii+1, j+1, jp_rs, jn_rs) - call ndiff_prep_jslice (p_src_rs, ksmx_rs, & - tpc_src_rs, t_srcdi_rs, & - p_dst_rs, kdmx_rs, p_srcdi_rs, & - drhodt_srcdi_rs, drhods_srcdi_rs, & - flxconv_rs, & - 0, ii+1, j+1, jp_rs, mm) - enddo - - j = 0 - call ndiff_vflx_jslice(ksmx_rs, tpc_src_rs, t_srcdi_rs, & - p_dst_rs, kdmx_rs, p_srcdi_rs, & - drhodt_srcdi_rs, drhods_srcdi_rs, & - flxconv_rs, & - ntr_loc, 1, ii, j+1, & - jm_rs, jp_rs, mm, nn) - - do j = 1, jj - jm_rs = jp_rs - jp_rs = jn_rs - jn_rs = mod(jn_rs,3) + 1 - call prep_recon_jslice (p_src_rs(:,:,jn_rs), & - ksmx_rs(:,jn_rs), & - -1, ii+2, j+2, jn_rs, nn) - call recon_trc_jslice (ksmx_rs(:,jn_rs), & - tpc_src_rs(:,:,:,:,jn_rs), & - t_srcdi_rs(:,:,:,:,jn_rs), & - -1, ii+2, j+2, jn_rs, nn) - call cntiso_regrid_nudge_jslice (p_src_rs(:,:,jn_rs), & - ksmx_rs(:,jn_rs), & - tpc_src_rs(:,:,:,:,jn_rs), & - t_srcdi_rs(:,:,:,:,jn_rs), & - p_dst_rs(:,:,jn_rs), & - stab_fac_rs(:,:,jn_rs), & - -1, ii+2, j+2, jn_rs) - call cntiso_regrid_smooth_jslice(p_dst_rs, stab_fac_rs, & - smtflxconv_rs, & - 0, ii+1, j+1, jp_rs, jn_rs) - call ndiff_prep_jslice (p_src_rs, ksmx_rs, & - tpc_src_rs, t_srcdi_rs, & - p_dst_rs, kdmx_rs, p_srcdi_rs, & - drhodt_srcdi_rs, drhods_srcdi_rs, & - flxconv_rs, & - 0, ii+1, j+1, jp_rs, mm) - call ndiff_uflx_jslice (ksmx_rs, tpc_src_rs, t_srcdi_rs, & - p_dst_rs, kdmx_rs, p_srcdi_rs, & - drhodt_srcdi_rs, drhods_srcdi_rs, & - flxconv_rs, & - ntr_loc, 1, ii+1, j, jm_rs, mm, nn) - call ndiff_vflx_jslice (ksmx_rs, tpc_src_rs, t_srcdi_rs, & - p_dst_rs, kdmx_rs, p_srcdi_rs, & - drhodt_srcdi_rs, drhods_srcdi_rs, & - flxconv_rs, & - ntr_loc, 1, ii, j+1, & - jm_rs, jp_rs, mm, nn) - call remap_trc_jslice (p_dst_rs(:,:,jm_rs), trc_rm, & - 1, ii, j, jm_rs) - call ndiff_update_trc_jslice (p_dst_rs, flxconv_rs, trc_rm, & - ntr_loc, 1, ii, j, jm_rs) - call copy_jslice_to_3d (p_dst_rs(:,:,jm_rs), & - trc_rm, & - 1, ii, j, nn) - enddo - - endif - - if (csdiag) then - if (mnproc == 1) then - write (lp,*) 'cntiso_hybrid_regrid_remap:' - endif - call chksummsk(dp (1-nbdy,1-nbdy,k1n), ip, kk, 'dp') - call chksummsk(temp (1-nbdy,1-nbdy,k1n), ip, kk, 'temp') - call chksummsk(saln (1-nbdy,1-nbdy,k1n), ip, kk, 'saln') - call chksummsk(sigma(1-nbdy,1-nbdy,k1n), ip, kk, 'sigma') - if (use_TRC) then - do nt = 1, ntr - call chksummsk(trc(1-nbdy,1-nbdy,k1n,nt), ip, kk, 'trc') - enddo - end if - endif - - end subroutine cntiso_hybrid_regrid_remap - - subroutine remap_velocity(m, n, mm, nn, k1m, k1n) - - integer, intent(in) :: m, n, mm, nn, k1m, k1n - - real(r8), dimension(kdm+1) :: p_1d, p_dst_1d - real(r8), dimension(kdm) :: u_1d, v_1d - real(r8) :: q - integer :: i, j, k, l, kn, errstat - - !$omp parallel do private(k, kn, l, i) - do j = 1, jj - do k = 1, kk - kn = k + nn - do l = 1, isu(j) - do i = max(1, ifu(j,l)), min(ii, ilu(j,l)) - pu(i,j,k+1) = pu(i,j,k) + dpu(i,j,kn) - enddo - enddo - do l = 1, isv(j) - do i = max(1, ifv(j,l)), min(ii, ilv(j,l)) - pv(i,j,k+1) = pv(i,j,k) + dpv(i,j,kn) - enddo - enddo - enddo - enddo - !$omp end parallel do - - call xctilr(dp(1-nbdy,1-nbdy,k1n), 1, kk, 3, 3, halo_ps) - - !$omp parallel do private(k, kn, l, i) - do j = -2, jj+3 - do k = 1, kk - kn = k + nn - do l = 1, isp(j) - do i = max(-2, ifp(j,l)), min(ii+3, ilp(j,l)) - p(i,j,k+1) = p(i,j,k) + dp(i,j,kn) - enddo - enddo - enddo - enddo - !$omp end parallel do - - !$omp parallel do private(k,kn,l,i,q) - do j = -1, jj+2 - do k = 1, kk - kn = k + nn - do l = 1, isu(j) - do i = max(-1, ifu(j,l)), min(ii+2, ilu(j,l)) - q = min(p(i,j,kk+1), p(i-1,j,kk+1)) - dpu(i,j,kn) = & - .5_r8*( (min(q, p(i-1,j,k+1)) - min(q, p(i-1,j,k))) & - + (min(q, p(i ,j,k+1)) - min(q, p(i ,j,k)))) - enddo - enddo - do l = 1, isv(j) - do i = max(-1, ifv(j,l)), min(ii+2, ilv(j,l)) - q = min(p(i,j,kk+1), p(i,j-1,kk+1)) - dpv(i,j,kn) = & - .5_r8*( (min(q, p(i,j-1,k+1)) - min(q, p(i,j-1,k))) & - + (min(q, p(i,j ,k+1)) - min(q, p(i,j ,k)))) + if (vcoord_tag == vcoord_isopyc_bulkml .or. & + trim(sigref_spec) == 'inicon') then + !$omp parallel do private(i, k) + do j = 1-nbdy, jj+nbdy + do k = 1, kk + do i = 1-nbdy, ii+nbdy + sigmar(i,j,k) = spval enddo enddo enddo - enddo - !$omp end parallel do - - do j = 1, jj - - do l = 1, isu(j) - do i = max(1, ifu(j,l)), min(ii, ilu(j,l)) - - ! Copy variables into 1D arrays. Rescale source interfaces so the - ! pressure range of source and destination columns match. - p_dst_1d(1) = pu(i,j,1) - do k = 1, kk - kn = k + nn - u_1d(k) = u(i,j,kn) - p_dst_1d(k+1) = p_dst_1d(k) + dpu(i,j,kn) - enddo - q = p_dst_1d(kk+1)/pu(i,j,kk+1) - do k = 1, kk+1 - p_1d(k) = pu(i,j,k)*q - enddo - - ! Prepare reconstruction with current interface pressures. - errstat = prepare_reconstruction(rcgs, p_1d, i, 1) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(remap_velocity)') - stop '(remap_velocity)' - endif - - ! Prepare remapping to layer structure with regridded interface - ! pressures. - errstat = prepare_remapping(rcgs, rms, p_dst_1d, i, 1) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(remap_velocity)') - stop '(remap_velocity)' - endif - - ! Reconstruct and remap u-component of velocity. - errstat = reconstruct(rcgs, v_rcss, u_1d, i, 1) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(remap_velocity)') - stop '(remap_velocity)' - endif - errstat = remap(v_rcss, rms, u_1d, i, 1) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(remap_velocity)') - stop '(remap_velocity)' - endif - - ! Update 3D arrays - do k = 1, kk - kn = k + nn - u(i,j,kn) = u_1d(k) - enddo - - enddo - enddo - - do l = 1, isv(j) - do i = max(1, ifv(j,l)), min(ii, ilv(j,l)) - - ! Copy variables into 1D arrays. Rescale source interfaces so the - ! pressure range of source and destination columns match. - p_dst_1d(1) = pv(i,j,1) - do k = 1, kk - kn = k + nn - v_1d(k) = v(i,j,kn) - p_dst_1d(k+1) = p_dst_1d(k) + dpv(i,j,kn) - enddo - q = p_dst_1d(kk+1)/pv(i,j,kk+1) - do k = 1, kk+1 - p_1d(k) = pv(i,j,k)*q - enddo - - ! Prepare reconstruction with current interface pressures. - errstat = prepare_reconstruction(rcgs, p_1d, i, 1) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(remap_velocity)') - stop '(remap_velocity)' - endif - - ! Prepare remapping to layer structure with regridded interface - ! pressures. - errstat = prepare_remapping(rcgs, rms, p_dst_1d, i, 1) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(remap_velocity)') - stop '(remap_velocity)' - endif - - ! Reconstruct and remap v-component of velocity. - errstat = reconstruct(rcgs, v_rcss, v_1d, i, 1) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(remap_velocity)') - stop '(remap_velocity)' - endif - errstat = remap(v_rcss, rms, v_1d, i, 1) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(remap_velocity)') - stop '(remap_velocity)' - endif - - ! Update 3D arrays - do k = 1, kk - kn = k + nn - v(i,j,kn) = v_1d(k) + !$omp end parallel do + else + !$omp parallel do private(i, k) + do j = 1-nbdy, jj+nbdy + do k = 1, kk + do i = 1-nbdy, ii+nbdy + sigmar(i,j,k) = sigref(k) enddo - enddo enddo - - enddo - - if (csdiag) then - if (mnproc == 1) then - write (lp,*) 'remap_velocity:' - endif - call chksummsk(dpu(1-nbdy,1-nbdy,k1n), iu, kk, 'dpu') - call chksummsk(dpv(1-nbdy,1-nbdy,k1n), iv, kk, 'dpv') - call chksummsk(u (1-nbdy,1-nbdy,k1n), iu, kk, 'u') - call chksummsk(v (1-nbdy,1-nbdy,k1n), iv, kk, 'v') + !$omp end parallel do endif - end subroutine remap_velocity + end subroutine inivar_vcoord end module mod_vcoord